diff options
Diffstat (limited to 'lisp')
508 files changed, 19076 insertions, 14500 deletions
diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 57527bb5afc..84c5733918a 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -196,7 +196,6 @@ $(lisp)/finder-inf.el: autoloads .PHONY: $(lisp)/loaddefs.el $(lisp)/loaddefs.el: gen-lisp $(LOADDEFS) - @echo Directories for loaddefs: ${SUBDIRS_ALMOST} $(AM_V_GEN)$(emacs) -l autoload \ --eval '(setq autoload-ensure-writable t)' \ --eval '(setq autoload-builtin-package-versions t)' \ diff --git a/lisp/abbrev.el b/lisp/abbrev.el index 190b3504fa7..2d61a96010e 100644 --- a/lisp/abbrev.el +++ b/lisp/abbrev.el @@ -255,11 +255,7 @@ have been saved." (if (abbrev--table-symbols table) (insert-abbrev-table-description table nil))) (when (unencodable-char-position (point-min) (point-max) 'utf-8) - (setq coding-system-for-write - (if (> emacs-major-version 24) - 'utf-8-emacs - ;; For compatibility with Emacs 22 (See Bug#8308) - 'emacs-mule))) + (setq coding-system-for-write 'utf-8-emacs)) (goto-char (point-min)) (insert (format ";;-*-coding: %s;-*-\n" coding-system-for-write)) (write-region nil nil file nil (and (not verbose) 0))))) 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-widgets.el b/lisp/allout-widgets.el index fbdddca7d76..03fc3e2f0e1 100644 --- a/lisp/allout-widgets.el +++ b/lisp/allout-widgets.el @@ -207,6 +207,7 @@ See `allout-widgets-mode' for allout widgets mode features." :version "24.1" :type 'plist :group 'allout-widgets) +(make-obsolete-variable 'allout-widgets-item-image-properties-xemacs nil "28.1") ;;;_ . Developer ;;;_ = allout-widgets-run-unit-tests-on-load (defcustom allout-widgets-run-unit-tests-on-load nil @@ -323,8 +324,7 @@ In addition, you can invoked `allout-widgets-mode' allout-mode buffers where this is set to enable and disable widget enhancements, directly.") ;;;###autoload -(put 'allout-widgets-mode-inhibit 'safe-local-variable - (if (fboundp 'booleanp) 'booleanp (lambda (x) (member x '(t nil))))) +(put 'allout-widgets-mode-inhibit 'safe-local-variable 'booleanp) (make-variable-buffer-local 'allout-widgets-mode-inhibit) ;;;_ = allout-inhibit-body-modification-hook (defvar allout-inhibit-body-modification-hook nil @@ -415,15 +415,17 @@ not altered with an escape sequence.") ;;;_ , Widget element formatting ;;;_ = allout-item-icon-keymap (defvar allout-item-icon-keymap - (let ((km (make-sparse-keymap))) + (let ((km (make-sparse-keymap)) + (as-parent (if (current-local-map) + (make-composed-keymap (current-local-map) + (current-global-map)) + (current-global-map)))) + ;; The keymap parent is reset on the each local var when mode starts. + (set-keymap-parent km as-parent) (dolist (digit '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9")) (define-key km digit 'digit-argument)) (define-key km "-" 'negative-argument) -;; (define-key km [(return)] 'allout-tree-expand-command) -;; (define-key km [(meta return)] 'allout-toggle-torso-command) -;; (define-key km [(down-mouse-1)] 'allout-item-button-click) -;; (define-key km [(down-mouse-2)] 'allout-toggle-torso-event-command) ;; Override underlying mouse-1 and mouse-2 bindings in icon territory: (define-key km [(mouse-1)] (lambda () (interactive) nil)) (define-key km [(mouse-2)] (lambda () (interactive) nil)) @@ -433,17 +435,16 @@ not altered with an escape sequence.") km) "General tree-node key bindings.") +(make-variable-buffer-local 'allout-item-icon-keymap) ;;;_ = allout-item-body-keymap (defvar allout-item-body-keymap (let ((km (make-sparse-keymap)) - (local-map (current-local-map))) -;; (define-key km [(control return)] 'allout-tree-expand-command) -;; (define-key km [(meta return)] 'allout-toggle-torso-command) - ;; XXX We need to reset this per buffer's mode; we do so in - ;; allout-widgets-mode. - (if local-map - (set-keymap-parent km local-map)) - + (as-parent (if (current-local-map) + (make-composed-keymap (current-local-map) + (current-global-map)) + (current-global-map)))) + ;; The keymap parent is reset on the each local var when mode starts. + (set-keymap-parent km as-parent) km) "General key bindings for the text content of outline items.") (make-variable-buffer-local 'allout-item-body-keymap) @@ -456,6 +457,7 @@ not altered with an escape sequence.") (set-keymap-parent km allout-item-icon-keymap) km) "Keymap used in the item cue area - the space between the icon and headline.") +(make-variable-buffer-local 'allout-cue-span-keymap) ;;;_ = allout-escapes-category (defvar allout-escapes-category nil "Symbol for category of text property used to hide escapes of prefix-like @@ -566,8 +568,13 @@ outline hot-spot navigation (see `allout-mode')." (add-to-invisibility-spec '(allout-torso . t)) (add-to-invisibility-spec 'allout-escapes) - (if (current-local-map) - (set-keymap-parent allout-item-body-keymap (current-local-map))) + (let ((as-parent (if (current-local-map) + (make-composed-keymap (current-local-map) + (current-global-map)) + (current-global-map)))) + (set-keymap-parent allout-item-body-keymap as-parent) + ;; allout-cue-span-keymap uses allout-item-icon-keymap as parent. + (set-keymap-parent allout-item-icon-keymap as-parent)) (add-hook 'allout-exposure-change-functions 'allout-widgets-exposure-change-recorder nil 'local) @@ -677,7 +684,7 @@ outline hot-spot navigation (see `allout-mode')." (setplist 'allout-cue-span-category nil) (put 'allout-cue-span-category 'evaporate t) (put 'allout-cue-span-category - 'modification-hooks '(allout-body-modification-handler)) + 'modification-hooks '(allout-graphics-modification-handler)) (put 'allout-cue-span-category 'local-map allout-cue-span-keymap) (put 'allout-cue-span-category 'mouse-face widget-button-face) (put 'allout-cue-span-category 'pointer 'arrow) @@ -988,6 +995,7 @@ Generally invoked via `allout-exposure-change-functions'." ;; have to distinguish between concealing and exposing so that, eg, ;; `allout-expose-topic's mix is handled properly. handled-expose + handled-conceal covered deactivate-mark) @@ -1502,8 +1510,7 @@ recursive operation." ;; the actual location of the item text: :location 'allout-item-location - :button-keymap allout-item-icon-keymap ; XEmacs - :keymap allout-item-icon-keymap ; Emacs + :keymap allout-item-icon-keymap ;; Element regions: :guides-span nil @@ -1594,7 +1601,10 @@ We return the item-widget corresponding to the item at point." (if is-container (progn (widget-put item-widget :is-container t) (setq reverse-siblings-chart (list 1))) - (goto-char (widget-apply parent :actual-position :from)) + (let ((parent-position (widget-apply parent + :actual-position :from))) + (when parent-position + (goto-char parent-position))) (if (widget-get parent :is-container) ;; `allout-goto-prefix' will go to first non-container item: (allout-goto-prefix) @@ -1994,8 +2004,7 @@ reapplying this method will rectify the glyphs." ;; NOTE: most of the cue-area (when (not (widget-get item-widget :is-container)) - (let* ((cue-start (or (widget-get item-widget :distinctive-end) - (widget-get item-widget :icon-end))) + (let* ((cue-start (widget-get item-widget :icon-end)) (body-start (widget-get item-widget :body-start)) ;(expanded (widget-get item-widget :expanded)) ;(has-subitems (widget-get item-widget :has-subitems)) @@ -2050,19 +2059,22 @@ Optional FORCE means force reassignment of the region property." ;;;_ > allout-widgets-undecorate-region (start end) (defun allout-widgets-undecorate-region (start end) "Eliminate widgets and decorations for all items in region from START to END." - (let ((next start) - widget) + (let (done next widget + (end (or end (point-max)))) (save-excursion (goto-char start) - (while (< (setq next (next-single-char-property-change next - 'display - (current-buffer) - end)) - end) - (goto-char next) - (when (setq widget (allout-get-item-widget)) - ;; if the next-property/overly progression got us to a widget: - (allout-widgets-undecorate-item widget t)))))) + (while (not done) + (when (and (allout-on-current-heading-p) + (setq widget (allout-get-item-widget))) + (if widget + (allout-widgets-undecorate-item widget t))) + (goto-char (setq next + (next-single-char-property-change (point) + 'display + (current-buffer) + end))) + (if (>= next end) + (setq done t)))))) ;;;_ > allout-widgets-undecorate-text (text) (defun allout-widgets-undecorate-text (text) "Eliminate widgets and decorations for all items in TEXT." @@ -2316,15 +2328,13 @@ We use a caching strategy, so the caller doesn't need to do so." (allout-widgets-copy-list (cadr got)) (while (and types (not got)) (setq got - (allout-find-image + (find-image (list (append (list :type (car types) :file (concat use-dir (symbol-name name) "." (symbol-name (car types)))) - (if (featurep 'xemacs) - allout-widgets-item-image-properties-xemacs - allout-widgets-item-image-properties-emacs) + allout-widgets-item-image-properties-emacs )))) (setq types (cdr types))) (if got @@ -2345,11 +2355,7 @@ We use a caching strategy, so the caller doesn't need to do so." 'frame-property) (t nil))) ;;;_ > allout-find-image (specs) -(defalias 'allout-find-image - (if (fboundp 'find-image) - 'find-image - nil) ; aka, not-yet-implemented for xemacs. -) +(define-obsolete-function-alias 'allout-find-image #'find-image "28.1") ;;;_ > allout-widgets-copy-list (list) (defun allout-widgets-copy-list (list) ;; duplicated from cl.el 'copy-list' as of 2008-08-17 @@ -2389,7 +2395,7 @@ The elements of LIST are not copied, just the list structure itself." ;;;_ : provide (provide 'allout-widgets) -;;;_. Local emacs vars. -;;;_ , Local variables: -;;;_ , allout-layout: (-1 : 0) -;;;_ , End: +;;;_ . Local emacs vars. +;;;_ , Local variables: +;;;_ , allout-layout: (-1 : 0) +;;;_ , End: diff --git a/lisp/allout.el b/lisp/allout.el index 174f1e3dc21..05d9153a31d 100644 --- a/lisp/allout.el +++ b/lisp/allout.el @@ -410,8 +410,7 @@ where auto-fill occurs." :group 'allout) (make-variable-buffer-local 'allout-use-hanging-indents) ;;;###autoload -(put 'allout-use-hanging-indents 'safe-local-variable - (if (fboundp 'booleanp) 'booleanp (lambda (x) (member x '(t nil))))) +(put 'allout-use-hanging-indents 'safe-local-variable 'booleanp) ;;;_ = allout-reindent-bodies (defcustom allout-reindent-bodies (if allout-use-hanging-indents 'text) @@ -440,8 +439,7 @@ just the header." :group 'allout) (make-variable-buffer-local 'allout-show-bodies) ;;;###autoload -(put 'allout-show-bodies 'safe-local-variable - (if (fboundp 'booleanp) 'booleanp (lambda (x) (member x '(t nil))))) +(put 'allout-show-bodies 'safe-local-variable 'booleanp) ;;;_ = allout-beginning-of-line-cycles (defcustom allout-beginning-of-line-cycles t @@ -662,8 +660,7 @@ are always respected by the topic maneuvering functions." :group 'allout) (make-variable-buffer-local 'allout-old-style-prefixes) ;;;###autoload -(put 'allout-old-style-prefixes 'safe-local-variable - (if (fboundp 'booleanp) 'booleanp (lambda (x) (member x '(t nil))))) +(put 'allout-old-style-prefixes 'safe-local-variable 'booleanp) ;;;_ = allout-stylish-prefixes -- alternating bullets (defcustom allout-stylish-prefixes t "Do fancy stuff with topic prefix bullets according to level, etc. @@ -711,8 +708,7 @@ is non-nil." :group 'allout) (make-variable-buffer-local 'allout-stylish-prefixes) ;;;###autoload -(put 'allout-stylish-prefixes 'safe-local-variable - (if (fboundp 'booleanp) 'booleanp (lambda (x) (member x '(t nil))))) +(put 'allout-stylish-prefixes 'safe-local-variable 'booleanp) ;;;_ = allout-numbered-bullet (defcustom allout-numbered-bullet "#" @@ -726,10 +722,7 @@ disables numbering maintenance." :group 'allout) (make-variable-buffer-local 'allout-numbered-bullet) ;;;###autoload -(put 'allout-numbered-bullet 'safe-local-variable - (if (fboundp 'string-or-null-p) - 'string-or-null-p - (lambda (x) (or (stringp x) (null x))))) +(put 'allout-numbered-bullet 'safe-local-variable 'string-or-null-p) ;;;_ = allout-file-xref-bullet (defcustom allout-file-xref-bullet "@" "Bullet signifying file cross-references, for `allout-resolve-xref'. @@ -738,10 +731,7 @@ Set this var to the bullet you want to use for file cross-references." :type '(choice (const nil) string) :group 'allout) ;;;###autoload -(put 'allout-file-xref-bullet 'safe-local-variable - (if (fboundp 'string-or-null-p) - 'string-or-null-p - (lambda (x) (or (stringp x) (null x))))) +(put 'allout-file-xref-bullet 'safe-local-variable 'string-or-null-p) ;;;_ = allout-presentation-padding (defcustom allout-presentation-padding 2 "Presentation-format white-space padding factor, for greater indent." @@ -1675,10 +1665,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 +2103,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 +2127,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 +2428,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) @@ -2499,20 +2474,16 @@ Outermost is first." (allout-back-to-current-heading) (allout-end-of-current-line)) (t - (if (not (allout-mark-active-p)) + (if (not mark-active) (push-mark)) (allout-end-of-entry)))))) + ;;;_ > allout-mark-active-p () (defun allout-mark-active-p () "True if the mark is currently or always active." - ;; `(cond (boundp...))' (or `(if ...)') invokes special byte-compiler - ;; provisions, at least in GNU Emacs to prevent warnings about lack of, - ;; eg, region-active-p. - (cond ((boundp 'mark-active) - mark-active) - ((fboundp 'region-active-p) - (region-active-p)) - (t))) + (declare (obsolete nil "28.1")) + mark-active) + ;;;_ > allout-next-heading () (defsubst allout-next-heading () "Move to the heading for the topic (possibly invisible) after this one. @@ -3443,7 +3414,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 +4429,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 +4470,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 +4481,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 +4514,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 +4613,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 +4723,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) @@ -5474,11 +5438,9 @@ header and body. The elements of that list are: (cdr format))))))) ;; Put the list with first at front, to last at back: (nreverse result)))) -;;;_ > allout-region-active-p () -(defmacro allout-region-active-p () - (cond ((fboundp 'use-region-p) '(use-region-p)) - ((fboundp 'region-active-p) '(region-active-p)) - (t 'mark-active))) + +(define-obsolete-function-alias 'allout-region-active-p 'region-active-p "28.1") + ;;_ > allout-process-exposed (&optional func from to frombuf ;;; tobuf format) (defun allout-process-exposed (&optional func from to frombuf tobuf @@ -5511,7 +5473,7 @@ Defaults: ; defaulting if necessary: (if (not func) (setq func 'allout-insert-listified)) (if (not (and from to)) - (if (allout-region-active-p) + (if (region-active-p) (setq from (region-beginning) to (region-end)) (setq from (point-min) to (point-max)))) (if frombuf @@ -5946,7 +5908,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 +6504,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/apropos.el b/lisp/apropos.el index 23f70d10fd4..6d8c7847b02 100644 --- a/lisp/apropos.el +++ b/lisp/apropos.el @@ -1,4 +1,4 @@ -;;; apropos.el --- apropos commands for users and programmers +;;; apropos.el --- apropos commands for users and programmers -*- lexical-binding: t -*- ;; Copyright (C) 1989, 1994-1995, 2001-2020 Free Software Foundation, ;; Inc. @@ -82,49 +82,41 @@ commands also has an optional argument to request a more extensive search. Additionally, this option makes the function `apropos-library' include key-binding information in its output." - :group 'apropos :type 'boolean) (defface apropos-symbol '((t (:inherit bold))) "Face for the symbol name in Apropos output." - :group 'apropos :version "24.3") (defface apropos-keybinding '((t (:inherit underline))) "Face for lists of keybinding in Apropos output." - :group 'apropos :version "24.3") (defface apropos-property '((t (:inherit font-lock-builtin-face))) "Face for property name in Apropos output, or nil for none." - :group 'apropos :version "24.3") (defface apropos-function-button '((t (:inherit (font-lock-function-name-face button)))) "Button face indicating a function, macro, or command in Apropos." - :group 'apropos :version "24.3") (defface apropos-variable-button '((t (:inherit (font-lock-variable-name-face button)))) "Button face indicating a variable in Apropos." - :group 'apropos :version "24.3") (defface apropos-user-option-button '((t (:inherit (font-lock-variable-name-face button)))) "Button face indicating a user option in Apropos." - :group 'apropos :version "24.4") (defface apropos-misc-button '((t (:inherit (font-lock-constant-face button)))) "Button face indicating a miscellaneous object type in Apropos." - :group 'apropos :version "24.3") (defcustom apropos-match-face 'match @@ -132,14 +124,12 @@ include key-binding information in its output." This applies when you look for matches in the documentation or variable value for the pattern; the part that matches gets displayed in this font." :type '(choice (const nil) face) - :group 'apropos :version "24.3") (defcustom apropos-sort-by-scores nil "Non-nil means sort matches by scores; best match is shown first. This applies to all `apropos' commands except `apropos-documentation'. If value is `verbose', the computed score is shown for each match." - :group 'apropos :type '(choice (const :tag "off" nil) (const :tag "on" t) (const :tag "show scores" verbose))) @@ -148,7 +138,6 @@ If value is `verbose', the computed score is shown for each match." "Non-nil means sort matches by scores; best match is shown first. This applies to `apropos-documentation' only. If value is `verbose', the computed score is shown for each match." - :group 'apropos :type '(choice (const :tag "off" nil) (const :tag "on" t) (const :tag "show scores" verbose))) @@ -160,6 +149,10 @@ If value is `verbose', the computed score is shown for each match." ;; definition of RET, so that users can use it anywhere in an ;; apropos item, not just on top of a button. (define-key map "\C-m" 'apropos-follow) + + ;; Movement keys + (define-key map "n" 'apropos-next-symbol) + (define-key map "p" 'apropos-previous-symbol) map) "Keymap used in Apropos mode.") @@ -348,7 +341,7 @@ before finding a label." (defun apropos-words-to-regexp (words wild) - "Make regexp matching any two of the words in WORDS. + "Return a regexp matching any two of the words in WORDS. WILD should be a subexpression matching wildcards between matches." (setq words (delete-dups (copy-sequence words))) (if (null (cdr words)) @@ -380,9 +373,11 @@ kind of objects to search." (user-error "No word list given")) pattern))) -(defun apropos-parse-pattern (pattern) +(defun apropos-parse-pattern (pattern &optional multiline-p) "Rewrite a list of words to a regexp matching all permutations. If PATTERN is a string, that means it is already a regexp. +MULTILINE-P, if non-nil, means produce a regexp that will match +the words even if separated by newlines. This updates variables `apropos-pattern', `apropos-pattern-quoted', `apropos-regexp', `apropos-words', and `apropos-all-words-regexp'." (setq apropos-words nil @@ -393,6 +388,9 @@ This updates variables `apropos-pattern', `apropos-pattern-quoted', ;; any combination of two or more words like this: ;; (a|b|c).*(a|b|c) which may give some false matches, ;; but as long as it also gives the right ones, that's ok. + ;; (Actually, when MULTILINE-P is non-nil, instead of '.' we + ;; use a trick that would find a match even if the words are + ;; on different lines. (let ((words pattern)) (setq apropos-pattern (mapconcat 'identity pattern " ") apropos-pattern-quoted (regexp-quote apropos-pattern)) @@ -409,9 +407,13 @@ This updates variables `apropos-pattern', `apropos-pattern-quoted', (setq apropos-words (cons s apropos-words) apropos-all-words (cons a apropos-all-words)))) (setq apropos-all-words-regexp - (apropos-words-to-regexp apropos-all-words ".+")) + (apropos-words-to-regexp apropos-all-words + ;; The [^b-a] trick matches any + ;; character including a newline. + (if multiline-p "[^b-a]+?" ".+"))) (setq apropos-regexp - (apropos-words-to-regexp apropos-words ".*?"))) + (apropos-words-to-regexp apropos-words + (if multiline-p "[^b-a]*?" ".*?")))) (setq apropos-pattern-quoted (regexp-quote pattern) apropos-all-words-regexp pattern apropos-pattern pattern @@ -541,6 +543,20 @@ will be buffer-local when set." (and (local-variable-if-set-p symbol) (get symbol 'variable-documentation))))) +;;;###autoload +(defun apropos-function (pattern) + "Show functions that match PATTERN. + +PATTERN can be a word, a list of words (separated by spaces), +or a regexp (using some regexp special characters). If it is a word, +search for matches for that word as a substring. If it is a list of words, +search for matches for any two (or more) of those words. + +This is the same as running `apropos-command' with a \\[universal-argument] prefix, +or a non-nil `apropos-do-all' argument." + (interactive (list (apropos-read-pattern "function"))) + (apropos-command pattern t)) + ;; For auld lang syne: ;;;###autoload (defalias 'command-apropos 'apropos-command) @@ -640,7 +656,7 @@ search for matches for any two (or more) of those words. With \\[universal-argument] prefix, or if `apropos-do-all' is non-nil, consider all symbols (if they match PATTERN). -Returns list of symbols and documentation found." +Return list of symbols and documentation found." (interactive (list (apropos-read-pattern "symbol") current-prefix-arg)) (setq apropos--current (list #'apropos pattern do-all)) @@ -659,12 +675,11 @@ Returns list of symbols and documentation found." (defun apropos-library-button (sym) (if (null sym) "<nothing>" - (let ((name (copy-sequence (symbol-name sym)))) + (let ((name (symbol-name sym))) (make-text-button name nil 'type 'apropos-library 'face 'apropos-symbol - 'apropos-symbol name) - name))) + 'apropos-symbol name)))) ;;;###autoload (defun apropos-library (file) @@ -794,7 +809,7 @@ Returns list of symbols and values found." (interactive (list (apropos-read-pattern "value") current-prefix-arg)) (setq apropos--current (list #'apropos-value pattern do-all)) - (apropos-parse-pattern pattern) + (apropos-parse-pattern pattern t) (or do-all (setq do-all apropos-do-all)) (setq apropos-accumulator ()) (let (f v p) @@ -834,7 +849,7 @@ Optional arg BUFFER (default: current buffer) is the buffer to check." (interactive (list (apropos-read-pattern "value of buffer-local variable"))) (unless buffer (setq buffer (current-buffer))) (setq apropos--current (list #'apropos-local-value pattern buffer)) - (apropos-parse-pattern pattern) + (apropos-parse-pattern pattern t) (setq apropos-accumulator ()) (let ((var nil)) (mapatoms @@ -876,7 +891,7 @@ Returns list of symbols and documentation found." (interactive (list (apropos-read-pattern "documentation") current-prefix-arg)) (setq apropos--current (list #'apropos-documentation pattern do-all)) - (apropos-parse-pattern pattern) + (apropos-parse-pattern pattern t) (or do-all (setq do-all apropos-do-all)) (setq apropos-accumulator () apropos-files-scanned ()) (let ((standard-input (get-buffer-create " apropos-temp")) @@ -917,16 +932,14 @@ Returns list of symbols and documentation found." (defun apropos-value-internal (predicate symbol function) - (if (funcall predicate symbol) - (progn - (setq symbol (prin1-to-string (funcall function symbol))) - (if (string-match apropos-regexp symbol) - (progn - (if apropos-match-face - (put-text-property (match-beginning 0) (match-end 0) - 'face apropos-match-face - symbol)) - symbol))))) + (when (funcall predicate symbol) + (setq symbol (prin1-to-string (funcall function symbol))) + (when (string-match apropos-regexp symbol) + (if apropos-match-face + (put-text-property (match-beginning 0) (match-end 0) + 'face apropos-match-face + symbol)) + symbol))) (defun apropos-documentation-internal (doc) (cond @@ -948,6 +961,10 @@ Returns list of symbols and documentation found." doc)))) (defun apropos-format-plist (pl sep &optional compare) + "Return a string representation of the plist PL. +Paired elements are separated by the string SEP. Only include +properties matching the current `apropos-regexp' when COMPARE is +non-nil." (setq pl (symbol-plist pl)) (let (p p-out) (while pl @@ -956,13 +973,12 @@ Returns list of symbols and documentation found." (put-text-property 0 (length (symbol-name (car pl))) 'face 'apropos-property p) (setq p nil)) - (if p - (progn - (and compare apropos-match-face - (put-text-property (match-beginning 0) (match-end 0) - 'face apropos-match-face - p)) - (setq p-out (concat p-out (if p-out sep) p)))) + (when p + (and compare apropos-match-face + (put-text-property (match-beginning 0) (match-end 0) + 'face apropos-match-face + p)) + (setq p-out (concat p-out (if p-out sep) p))) (setq pl (nthcdr 2 pl))) p-out)) @@ -1270,6 +1286,21 @@ as a heading." (or (apropos-next-label-button (line-beginning-position)) (error "There is nothing to follow here")))) +(defun apropos-next-symbol () + "Move cursor down to the next symbol in an apropos-mode buffer." + (interactive) + (forward-line) + (while (and (not (eq (face-at-point) 'apropos-symbol)) + (< (point) (point-max))) + (forward-line))) + +(defun apropos-previous-symbol () + "Move cursor back to the last symbol in an apropos-mode buffer." + (interactive) + (forward-line -1) + (while (and (not (eq (face-at-point) 'apropos-symbol)) + (> (point) (point-min))) + (forward-line -1))) (defun apropos-describe-plist (symbol) "Display a pretty listing of SYMBOL's plist." diff --git a/lisp/arc-mode.el b/lisp/arc-mode.el index d6e85bf3835..ae85fc55add 100644 --- a/lisp/arc-mode.el +++ b/lisp/arc-mode.el @@ -1,4 +1,4 @@ -;;; arc-mode.el --- simple editing of archives +;;; arc-mode.el --- simple editing of archives -*- lexical-binding: t; -*- ;; Copyright (C) 1995, 1997-1998, 2001-2020 Free Software Foundation, ;; Inc. @@ -52,17 +52,17 @@ ;; ARCHIVE TYPES: Currently only the archives below are handled, but the ;; structure for handling just about anything is in place. ;; -;; Arc Lzh Zip Zoo Rar 7z -;; -------------------------------------------- -;; View listing Intern Intern Intern Intern Y Y -;; Extract member Y Y Y Y Y Y -;; Save changed member Y Y Y Y N Y -;; Add new member N N N N N N -;; Delete member Y Y Y Y N Y -;; Rename member Y Y N N N N -;; Chmod - Y Y - N N -;; Chown - Y - - N N -;; Chgrp - Y - - N N +;; Arc Lzh Zip Zoo Rar 7z Ar +;; -------------------------------------------------- +;; View listing Intern Intern Intern Intern Y Y Y +;; Extract member Y Y Y Y Y Y Y +;; Save changed member Y Y Y Y N Y Y +;; Add new member N N N N N N N +;; Delete member Y Y Y Y N Y N +;; Rename member Y Y N N N N N +;; Chmod - Y Y - N N N +;; Chown - Y - - N N N +;; Chgrp - Y - - N N N ;; ;; Special thanks to Bill Brodie <wbrodie@panix.com> for very useful tips ;; on the first released version of this package. @@ -101,6 +101,8 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) + ;; ------------------------------------------------------------------------- ;;; Section: Configuration. @@ -108,22 +110,6 @@ "Simple editing of archives." :group 'data) -(defgroup archive-arc nil - "ARC-specific options to archive." - :group 'archive) - -(defgroup archive-lzh nil - "LZH-specific options to archive." - :group 'archive) - -(defgroup archive-zip nil - "ZIP-specific options to archive." - :group 'archive) - -(defgroup archive-zoo nil - "ZOO-specific options to archive." - :group 'archive) - (defcustom archive-tmpdir ;; make-temp-name is safe here because we use this name ;; to create a directory. @@ -131,35 +117,48 @@ (expand-file-name (if (eq system-type 'ms-dos) "ar" "archive.tmp") temporary-file-directory)) "Directory for temporary files made by `arc-mode.el'." - :type 'directory - :group 'archive) + :type 'directory) (defcustom archive-remote-regexp "^/[^/:]*[^/:.]:" "Regexp recognizing archive files names that are not local. A non-local file is one whose file name is not proper outside Emacs. A local copy of the archive will be used when updating." - :type 'regexp - :group 'archive) + :type 'regexp) (define-obsolete-variable-alias 'archive-extract-hooks 'archive-extract-hook "24.3") (defcustom archive-extract-hook nil "Hook run when an archive member has been extracted." - :type 'hook - :group 'archive) + :type 'hook) (defcustom archive-visit-single-files nil "If non-nil, opening an archive with a single file visits that file. If nil, visiting such an archive displays the archive summary." :version "25.1" :type '(choice (const :tag "Visit the single file" t) - (const :tag "Show the archive summary" nil)) - :group 'archive) + (const :tag "Show the archive summary" nil))) + +(defcustom archive-hidden-columns '(Ids) + "Columns hidden from display." + :version "28.1" + :type '(set (const Mode) + (const Ids) + (const Date&Time) + (const Ratio))) + +(defconst archive-alternate-hidden-columns '(Mode Date&Time) + "Columns hidden when `archive-alternate-display' is used.") + ;; ------------------------------ ;; Arc archive configuration ;; We always go via a local file since there seems to be no reliable way ;; to extract to stdout without junk getting added. + +(defgroup archive-arc nil + "ARC-specific options to archive." + :group 'archive) + (defcustom archive-arc-extract '("arc" "x") "Program and its options to run in order to extract an arc file member. @@ -168,8 +167,7 @@ name will be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-arc) + (string :format "%v")))) (defcustom archive-arc-expunge '("arc" "d") @@ -178,8 +176,7 @@ Archive and member names will be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-arc) + (string :format "%v")))) (defcustom archive-arc-write-file-member '("arc" "u") @@ -188,11 +185,14 @@ Archive and member name will be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-arc) + (string :format "%v")))) ;; ------------------------------ ;; Lzh archive configuration +(defgroup archive-lzh nil + "LZH-specific options to archive." + :group 'archive) + (defcustom archive-lzh-extract '("lha" "pq") "Program and its options to run in order to extract an lzh file member. @@ -201,8 +201,7 @@ be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-lzh) + (string :format "%v")))) (defcustom archive-lzh-expunge '("lha" "d") @@ -211,8 +210,7 @@ Archive and member names will be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-lzh) + (string :format "%v")))) (defcustom archive-lzh-write-file-member '("lha" "a") @@ -221,8 +219,7 @@ Archive and member name will be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-lzh) + (string :format "%v")))) ;; ------------------------------ ;; Zip archive configuration @@ -231,6 +228,10 @@ Archive and member name will be added." (when 7z (file-name-nondirectory 7z)))) +(defgroup archive-zip nil + "ZIP-specific options to archive." + :group 'archive) + (defcustom archive-zip-extract (cond ((executable-find "unzip") '("unzip" "-qq" "-c")) (archive-7z-program `(,archive-7z-program "x" "-so")) @@ -242,8 +243,7 @@ be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-zip) + (string :format "%v")))) ;; For several reasons the latter behavior is not desirable in general. ;; (1) It uses more disk space. (2) Error checking is worse or non- @@ -260,8 +260,7 @@ Archive and member names will be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-zip) + (string :format "%v")))) (defcustom archive-zip-update (cond ((executable-find "zip") '("zip" "-q")) @@ -274,8 +273,7 @@ file. Archive and member name will be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-zip) + (string :format "%v")))) (defcustom archive-zip-update-case (cond ((executable-find "zip") '("zip" "-q" "-k")) @@ -288,8 +286,7 @@ Archive and member name will be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-zip) + (string :format "%v")))) (declare-function msdos-long-file-names "msdos.c") (defcustom archive-zip-case-fiddle (and (eq system-type 'ms-dos) @@ -300,11 +297,14 @@ that uses caseless file names. In addition, this flag forces members added/updated in the zip archive to be truncated to DOS 8+3 file-name restrictions." :type 'boolean - :version "27.1" - :group 'archive-zip) + :version "27.1") ;; ------------------------------ ;; Zoo archive configuration +(defgroup archive-zoo nil + "ZOO-specific options to archive." + :group 'archive) + (defcustom archive-zoo-extract '("zoo" "xpq") "Program and its options to run in order to extract a zoo file member. @@ -313,8 +313,7 @@ be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-zoo) + (string :format "%v")))) (defcustom archive-zoo-expunge '("zoo" "DqPP") @@ -323,8 +322,7 @@ Archive and member names will be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-zoo) + (string :format "%v")))) (defcustom archive-zoo-write-file-member '("zoo" "a") @@ -333,11 +331,14 @@ Archive and member name will be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-zoo) + (string :format "%v")))) ;; ------------------------------ ;; 7z archive configuration +(defgroup archive-7z nil + "7Z-specific options to archive." + :group 'archive) + (defcustom archive-7z-extract `(,(or archive-7z-program "7z") "x" "-so") "Program and its options to run in order to extract a 7z file member. @@ -347,8 +348,7 @@ be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-7z) + (string :format "%v")))) (defcustom archive-7z-expunge `(,(or archive-7z-program "7z") "d") @@ -358,8 +358,7 @@ Archive and member names will be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-7z) + (string :format "%v")))) (defcustom archive-7z-update `(,(or archive-7z-program "7z") "u") @@ -370,18 +369,17 @@ file. Archive and member name will be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-7z) + (string :format "%v")))) ;; ------------------------------------------------------------------------- ;;; Section: Variables (defvar archive-subtype nil "Symbol describing archive type.") -(defvar archive-file-list-start nil "Position of first contents line.") -(defvar archive-file-list-end nil "Position just after last contents line.") -(defvar archive-proper-file-start nil "Position of real archive's start.") +(defvar-local archive-file-list-start nil "Position of first contents line.") +(defvar-local archive-file-list-end nil "Position just after last contents line.") +(defvar-local archive-proper-file-start nil "Position of real archive's start.") (defvar archive-read-only nil "Non-nil if the archive is read-only on disk.") -(defvar archive-local-name nil "Name of local copy of remote archive.") +(defvar-local archive-local-name nil "Name of local copy of remote archive.") (defvar archive-mode-map (let ((map (make-keymap))) (set-keymap-parent map special-mode-map) @@ -393,6 +391,7 @@ file. Archive and member name will be added." (define-key map "e" 'archive-extract) (define-key map "f" 'archive-extract) (define-key map "\C-m" 'archive-extract) + (define-key map "C" 'archive-copy-file) (define-key map "m" 'archive-mark) (define-key map "n" 'archive-next-line) (define-key map "\C-n" 'archive-next-line) @@ -428,11 +427,13 @@ file. Archive and member name will be added." (cons "Immediate" (make-sparse-keymap "Immediate"))) (define-key map [menu-bar immediate alternate] '(menu-item "Alternate Display" archive-alternate-display - :enable (boundp (archive-name "alternate-display")) :help "Toggle alternate file info display")) (define-key map [menu-bar immediate view] '(menu-item "View This File" archive-view :help "Display file at cursor in View Mode")) + (define-key map [menu-bar immediate view] + '(menu-item "Copy This File" archive-copy-file + :help "Copy file at cursor to another location")) (define-key map [menu-bar immediate display] '(menu-item "Display in Other Window" archive-display-other-window :help "Display file at cursor in another window")) @@ -483,36 +484,58 @@ file. Archive and member name will be added." :help "Delete all flagged files from archive")) map) "Local keymap for archive mode listings.") -(defvar archive-file-name-indent nil "Column where file names start.") +(defvar-local archive-file-name-indent nil "Column where file names start.") -(defvar archive-remote nil "Non-nil if the archive is outside file system.") -(make-variable-buffer-local 'archive-remote) +(defvar-local archive-remote nil "Non-nil if the archive is outside file system.") (put 'archive-remote 'permanent-local t) -(defvar archive-member-coding-system nil "Coding-system of archive member.") -(make-variable-buffer-local 'archive-member-coding-system) +(defvar-local archive-member-coding-system nil "Coding-system of archive member.") -(defvar archive-alternate-display nil +(defvar-local archive-alternate-display nil "Non-nil when alternate information is shown.") -(make-variable-buffer-local 'archive-alternate-display) (put 'archive-alternate-display 'permanent-local t) (defvar archive-superior-buffer nil "In archive members, points to archive.") (put 'archive-superior-buffer 'permanent-local t) -(defvar archive-subfile-mode nil "Non-nil in archive member buffers.") -(make-variable-buffer-local 'archive-subfile-mode) +(defvar-local archive-subfile-mode nil + "Non-nil in archive member buffers. +Its value is an `archive--file-desc'.") (put 'archive-subfile-mode 'permanent-local t) -(defvar archive-file-name-coding-system nil) -(make-variable-buffer-local 'archive-file-name-coding-system) +(defvar-local archive-file-name-coding-system nil) (put 'archive-file-name-coding-system 'permanent-local t) -(defvar archive-files nil - "Vector of file descriptors. -Each descriptor is a vector of the form - [EXT-FILE-NAME INT-FILE-NAME CASE-FIDDLED MODE ...]") -(make-variable-buffer-local 'archive-files) +(cl-defstruct (archive--file-desc + (:constructor nil) + (:constructor archive--file-desc + ;; ext-file-name and int-file-name are usually `eq' + ;; except when int-file-name is the downcased + ;; ext-file-name. + (ext-file-name int-file-name mode size time + &key pos ratio uid gid))) + ext-file-name int-file-name + (mode nil :type integer) + (size nil :type integer) + (time nil :type string) + (ratio nil :type string) + uid gid + pos) + +;; Features in formats: +;; +;; ARC: size, date&time (date and time strings internally generated) +;; LZH: size, date&time, mode, uid, gid (mode, date, time generated, ugid:int) +;; ZIP: size, date&time, mode (mode, date, time generated) +;; ZOO: size, date&time (date and time strings internally generated) +;; AR : size, date&time, mode, user, group (internally generated) +;; RAR: size, date&time, ratio (all as strings, using `lsar') +;; 7Z : size, date&time (all as strings, using `7z' or `7za') +;; +;; LZH has alternate display (with UID/GID i.s.o MODE/DATE/TIME + +(defvar-local archive-files nil + "Vector of `archive--file-desc' objects.") ;; ------------------------------------------------------------------------- ;;; Section: Support functions. @@ -520,9 +543,9 @@ Each descriptor is a vector of the form (defun arc-insert-unibyte (&rest args) "Like insert but don't make unibyte string and eight-bit char multibyte." (dolist (elt args) - (if (integerp elt) - (insert (if (< elt 128) elt (decode-char 'eight-bit elt))) - (insert elt)))) + (insert (if (and (integerp elt) (>= elt 128)) + (decode-char 'eight-bit elt) + elt)))) (defsubst archive-name (suffix) (intern (concat "archive-" (symbol-name archive-subtype) "-" suffix))) @@ -544,73 +567,19 @@ in which case a second argument, length LEN, should be supplied." (aref str (- len i))))) result)) -(defun archive-int-to-mode (mode) - "Turn an integer like 0700 (i.e., 448) into a mode string like -rwx------." - ;; FIXME: merge with tar-grind-file-mode. - (string - (if (zerop (logand 8192 mode)) - (if (zerop (logand 16384 mode)) ?- ?d) - ?c) ; completeness - (if (zerop (logand 256 mode)) ?- ?r) - (if (zerop (logand 128 mode)) ?- ?w) - (if (zerop (logand 64 mode)) - (if (zerop (logand 2048 mode)) ?- ?S) - (if (zerop (logand 2048 mode)) ?x ?s)) - (if (zerop (logand 32 mode)) ?- ?r) - (if (zerop (logand 16 mode)) ?- ?w) - (if (zerop (logand 8 mode)) - (if (zerop (logand 1024 mode)) ?- ?S) - (if (zerop (logand 1024 mode)) ?x ?s)) - (if (zerop (logand 4 mode)) ?- ?r) - (if (zerop (logand 2 mode)) ?- ?w) - (if (zerop (logand 1 mode)) ?- ?x))) - -(defun archive-calc-mode (oldmode newmode &optional error) +(define-obsolete-function-alias 'archive-int-to-mode + 'file-modes-number-to-symbolic "28.1") + +(defun archive-calc-mode (oldmode newmode) "From the integer OLDMODE and the string NEWMODE calculate a new file mode. NEWMODE may be an octal number including a leading zero in which case it will become the new mode.\n NEWMODE may also be a relative specification like \"og-rwx\" in which case -OLDMODE will be modified accordingly just like chmod(2) would have done.\n -If optional third argument ERROR is non-nil an error will be signaled if -the mode is invalid. If ERROR is nil then nil will be returned." - (cond ((string-match "^0[0-7]*$" newmode) - (let ((result 0) - (len (length newmode)) - (i 1)) - (while (< i len) - (setq result (+ (ash result 3) (aref newmode i) (- ?0)) - i (1+ i))) - (logior (logand oldmode 65024) result))) - ((string-match "^\\([agou]+\\)\\([---+=]\\)\\([rwxst]+\\)$" newmode) - (let ((who 0) - (result oldmode) - (op (aref newmode (match-beginning 2))) - (bits 0) - (i (match-beginning 3))) - (while (< i (match-end 3)) - (let ((rwx (aref newmode i))) - (setq bits (logior bits (cond ((= rwx ?r) 292) - ((= rwx ?w) 146) - ((= rwx ?x) 73) - ((= rwx ?s) 3072) - ((= rwx ?t) 512))) - i (1+ i)))) - (while (< who (match-end 1)) - (let* ((whoc (aref newmode who)) - (whomask (cond ((= whoc ?a) 4095) - ((= whoc ?u) 1472) - ((= whoc ?g) 2104) - ((= whoc ?o) 7)))) - (if (= op ?=) - (setq result (logand result (lognot whomask)))) - (if (= op ?-) - (setq result (logand result (lognot (logand whomask bits)))) - (setq result (logior result (logand whomask bits))))) - (setq who (1+ who))) - result)) - (t - (if error - (error "Invalid mode specification: %s" newmode))))) +OLDMODE will be modified accordingly just like chmod(2) would have done." + ;; FIXME: Use `file-modes-symbolic-to-number'! + (if (string-match "\\`0[0-7]*\\'" newmode) + (logior (logand oldmode #o177000) (string-to-number newmode 8)) + (file-modes-symbolic-to-number newmode oldmode))) (defun archive-dosdate (date) "Stringify dos packed DATE record." @@ -622,7 +591,8 @@ the mode is invalid. If ERROR is nil then nil will be returned." (format "%2d-%s-%d" day (aref ["Jan" "Feb" "Mar" "Apr" "May" "Jun" - "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"] (1- month)) + "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"] + (1- month)) year)))) (defun archive-dostime (time) @@ -658,10 +628,12 @@ Does not signal an error if optional argument NOERROR is non-nil." (if (and (>= (point) archive-file-list-start) (< no (length archive-files))) (let ((item (aref archive-files no))) - (if (vectorp item) + (if (and (archive--file-desc-p item) + (let ((mode (archive--file-desc-mode item))) + (zerop (logand 16384 mode)))) item (if (not noerror) - (error "Entry is not a regular member of the archive")))) + (user-error "Entry is not a regular member of the archive")))) (if (not noerror) (error "Line does not describe a member of the archive"))))) ;; ------------------------------------------------------------------------- @@ -684,41 +656,34 @@ archive. ;; mode on and off. You can corrupt things that way. (if (zerop (buffer-size)) ;; At present we cannot create archives from scratch - (funcall (or (default-value 'major-mode) 'fundamental-mode)) + (funcall (or (default-value 'major-mode) #'fundamental-mode)) (if (and (not force) archive-files) nil (kill-all-local-variables) (let* ((type (archive-find-type)) (typename (capitalize (symbol-name type)))) - (make-local-variable 'archive-subtype) - (setq archive-subtype type) + (setq-local archive-subtype type) ;; Buffer contains treated image of file before the file contents - (make-local-variable 'revert-buffer-function) - (setq revert-buffer-function 'archive-mode-revert) - (auto-save-mode 0) + (add-function :around (local 'revert-buffer-function) + #'archive--mode-revert) - (add-hook 'write-contents-functions 'archive-write-file nil t) + (add-hook 'write-contents-functions #'archive-write-file nil t) - (make-local-variable 'require-final-newline) - (setq require-final-newline nil) - (make-local-variable 'local-enable-local-variables) - (setq local-enable-local-variables nil) + (setq-local truncate-lines t) + (setq-local require-final-newline nil) + (setq-local local-enable-local-variables nil) ;; Prevent loss of data when saving the file. - (make-local-variable 'file-precious-flag) - (setq file-precious-flag t) + (setq-local file-precious-flag t) - (make-local-variable 'archive-read-only) ;; Archives which are inside other archives and whose ;; names are invalid for this OS, can't be written. - (setq archive-read-only - (or (not (file-writable-p (buffer-file-name))) - (and archive-subfile-mode - (string-match file-name-invalid-regexp - (aref archive-subfile-mode 0))))) - - ;; Should we use a local copy when accessing from outside Emacs? - (make-local-variable 'archive-local-name) + (setq-local archive-read-only + (or (not (file-writable-p (buffer-file-name))) + (and archive-subfile-mode + (string-match file-name-invalid-regexp + (archive--file-desc-ext-file-name + archive-subfile-mode))))) ;; An archive can contain another archive whose name is invalid ;; on local filesystem. Treat such archives as remote. @@ -728,16 +693,12 @@ archive. (string-match file-name-invalid-regexp (buffer-file-name))))) - (setq major-mode 'archive-mode) + (setq major-mode #'archive-mode) (setq mode-name (concat typename "-Archive")) ;; Run archive-foo-mode-hook and archive-mode-hook (run-mode-hooks (archive-name "mode-hook") 'archive-mode-hook) (use-local-map archive-mode-map)) - (make-local-variable 'archive-proper-file-start) - (make-local-variable 'archive-file-list-start) - (make-local-variable 'archive-file-list-end) - (make-local-variable 'archive-file-name-indent) (setq archive-file-name-coding-system (or file-name-coding-system default-file-name-coding-system @@ -803,7 +764,7 @@ when parsing the archive." (let ((create-lockfiles nil) ; avoid changing dir mtime by lock_file (inhibit-read-only t)) (setq archive-proper-file-start (copy-marker (point-min) t)) - (set (make-local-variable 'change-major-mode-hook) 'archive-desummarize) + (add-hook 'change-major-mode-hook #'archive-desummarize nil t) (or shut-up (message "Parsing archive file...")) (buffer-disable-undo (current-buffer)) @@ -825,27 +786,35 @@ when parsing the archive." (goto-char archive-file-list-start) (archive-next-line no))) +(cl-defstruct (archive--file-summary + (:constructor nil) + (:constructor archive--file-summary (text name-start name-end))) + text name-start name-end) + (defun archive-summarize-files (files) "Insert a description of a list of files annotated with proper mouse face." (setq archive-file-list-start (point-marker)) - (setq archive-file-name-indent (if files (aref (car files) 1) 0)) + ;; Here we assume that they all start at the same column. + (setq archive-file-name-indent + ;; FIXME: We assume chars=columns (no double-wide chars and such). + (if files (archive--file-summary-name-start (car files)) 0)) ;; We don't want to do an insert for each element since that takes too ;; long when the archive -- which has to be moved in memory -- is large. (insert - (apply - #'concat - (mapcar - (lambda (fil) - ;; Using `concat' here copies the text also, so we can add - ;; properties without problems. - (let ((text (concat (aref fil 0) "\n"))) - (add-text-properties - (aref fil 1) (aref fil 2) - '(mouse-face highlight - help-echo "mouse-2: extract this file into a buffer") - text) - text)) - files))) + (mapconcat + (lambda (fil) + ;; Using `concat' here copies the text also, so we can add + ;; properties without problems. + (let ((text (concat (archive--file-summary-text fil) "\n"))) + (add-text-properties + (archive--file-summary-name-start fil) + (archive--file-summary-name-end fil) + '(mouse-face highlight + help-echo "mouse-2: extract this file into a buffer") + text) + text)) + files + "")) (setq archive-file-list-end (point-marker))) (defun archive-alternate-display () @@ -854,7 +823,27 @@ To avoid very long lines archive mode does not show all information. This function changes the set of information shown for each files." (interactive) (setq archive-alternate-display (not archive-alternate-display)) + (setq-local archive-hidden-columns + (if archive-alternate-display + archive-alternate-hidden-columns + (eval (car (or (get 'archive-hidden-columns 'customized-value) + (get 'archive-hidden-columns 'standard-value))) + t))) (archive-resummarize)) + +(defun archive-hideshow-column (column) + "Toggle visibility of COLUMN." + (interactive + (list (intern + (completing-read "Toggle visibility of: " + '(Mode Ids Ratio Date&Time) + nil t)))) + (setq-local archive-hidden-columns + (if (memq column archive-hidden-columns) + (remove column archive-hidden-columns) + (cons column archive-hidden-columns))) + (archive-resummarize)) + ;; ------------------------------------------------------------------------- ;;; Section: Local archive copy handling @@ -899,7 +888,8 @@ using `make-temp-file', and the generated name is returned." ;; "foo.zip:bar.zip", which is invalid on DOS/Windows. ;; So use the actual name if available. (archive-name - (or (and archive-subfile-mode (aref archive-subfile-mode 0)) + (or (and archive-subfile-mode (archive--file-desc-ext-file-name + archive-subfile-mode)) archive))) (setq archive-local-name (archive-unique-fname archive-name archive-tmpdir)) @@ -918,6 +908,7 @@ using `make-temp-file', and the generated name is returned." (lno (archive-get-lineno)) (inhibit-read-only t)) (if unchanged nil + ;; FIXME: Use archive-resummarize? (setq archive-files nil) (erase-buffer) (insert-file-contents name) @@ -968,7 +959,7 @@ using `make-temp-file', and the generated name is returned." (delete-file tmpfile))))) (defun archive-file-name-handler (op &rest args) - (or (eq op 'file-exists-p) + (or (eq op #'file-exists-p) (let ((file-name-handler-alist nil)) (apply op args)))) @@ -1002,14 +993,83 @@ using `make-temp-file', and the generated name is returned." (kill-local-variable 'buffer-file-coding-system) (after-insert-file-set-coding (- (point-max) (point-min)))))) +(defun archive-goto-file (file) + "Go to FILE in the current buffer. +FILE should be a relative file name. If FILE can't be found, +return nil. Otherwise point is returned." + (let ((start (point)) + found) + (goto-char (point-min)) + (while (and (not found) + (not (eobp))) + (forward-line 1) + (when-let ((descr (archive-get-descr t))) + (when (equal (archive--file-desc-ext-file-name descr) file) + (setq found t)))) + (if (not found) + (progn + (goto-char start) + nil) + (point)))) + +(defun archive-next-file-displayer (file regexp n) + "Return a closure to display the next file after FILE that matches REGEXP." + (let ((short (replace-regexp-in-string "\\`.*:" "" file)) + next) + (archive-goto-file short) + (while (and (not next) + ;; Stop if we reach the end/start of the buffer. + (if (> n 0) + (not (eobp)) + (not (save-excursion + (beginning-of-line) + (bobp))))) + (archive-next-line n) + (when-let ((descr (archive-get-descr t))) + (let ((candidate (archive--file-desc-ext-file-name descr)) + (buffer (current-buffer))) + (when (and candidate + (string-match-p regexp candidate)) + (setq next (lambda () + (kill-buffer (current-buffer)) + (switch-to-buffer buffer) + (archive-extract))))))) + (unless next + ;; If we didn't find a next/prev file, then restore + ;; point. + (archive-goto-file short)) + next)) + +(defun archive-copy-file (file new-name) + "Copy FILE to a location specified by NEW-NAME. +Interactively, FILE is the file at point, and the function prompts +for NEW-NAME." + (interactive + (let ((name (archive--file-desc-ext-file-name (archive-get-descr)))) + (list name + (read-file-name (format "Copy %s to: " name))))) + (when (file-directory-p new-name) + (setq new-name (expand-file-name file new-name))) + (when (and (file-exists-p new-name) + (not (yes-or-no-p (format "%s already exists; overwrite? " + new-name)))) + (user-error "Not overwriting %s" new-name)) + (let* ((descr (archive-get-descr)) + (archive (buffer-file-name)) + (extractor (archive-name "extract")) + (ename (archive--file-desc-ext-file-name descr))) + (with-temp-buffer + (archive--extract-file extractor archive ename) + (write-region (point-min) (point-max) new-name)))) + (defun archive-extract (&optional other-window-p event) "In archive mode, extract this entry of the archive into its own buffer." (interactive (list nil last-input-event)) (if event (posn-set-point (event-end event))) (let* ((view-p (eq other-window-p 'view)) (descr (archive-get-descr)) - (ename (aref descr 0)) - (iname (aref descr 1)) + (ename (archive--file-desc-ext-file-name descr)) + (iname (archive--file-desc-int-file-name descr)) (archive-buffer (current-buffer)) (arcdir default-directory) (archive (buffer-file-name)) @@ -1038,32 +1098,12 @@ using `make-temp-file', and the generated name is returned." (abbreviate-file-name buffer-file-name)) ;; Set the default-directory to the dir of the superior buffer. (setq default-directory arcdir) - (make-local-variable 'archive-superior-buffer) - (setq archive-superior-buffer archive-buffer) + (setq-local archive-superior-buffer archive-buffer) (add-hook 'write-file-functions #'archive-write-file-member nil t) (setq archive-subfile-mode descr) (setq archive-file-name-coding-system file-name-coding) (if (and - (null - (let (;; We may have to encode the file name argument for - ;; external programs. - (coding-system-for-write - (and enable-multibyte-characters - archive-file-name-coding-system)) - ;; We read an archive member by no-conversion at - ;; first, then decode appropriately by calling - ;; archive-set-buffer-as-visiting-file later. - (coding-system-for-read 'no-conversion) - ;; Avoid changing dir mtime by lock_file - (create-lockfiles nil)) - (condition-case err - (if (fboundp extractor) - (funcall extractor archive ename) - (archive-*-extract archive ename - (symbol-value extractor))) - (error - (ding (message "%s" (error-message-string err))) - nil)))) + (null (archive--extract-file extractor archive ename)) just-created) (progn (set-buffer-modified-p nil) @@ -1096,6 +1136,27 @@ using `make-temp-file', and the generated name is returned." (other-window-p (switch-to-buffer-other-window buffer)) (t (switch-to-buffer buffer)))))) +(defun archive--extract-file (extractor archive ename) + (let (;; We may have to encode the file name argument for + ;; external programs. + (coding-system-for-write + (and enable-multibyte-characters + archive-file-name-coding-system)) + ;; We read an archive member by no-conversion at + ;; first, then decode appropriately by calling + ;; archive-set-buffer-as-visiting-file later. + (coding-system-for-read 'no-conversion) + ;; Avoid changing dir mtime by lock_file + (create-lockfiles nil)) + (condition-case err + (if (fboundp extractor) + (funcall extractor archive ename) + (archive-*-extract archive ename + (symbol-value extractor))) + (error + (ding (message "%s" (error-message-string err))) + nil)))) + (defun archive-*-extract (archive name command) (let* ((default-directory (file-name-as-directory archive-tmpdir)) (tmpfile (expand-file-name (file-name-nondirectory name) @@ -1253,7 +1314,7 @@ using `make-temp-file', and the generated name is returned." t) (defun archive-*-write-file-member (archive descr command) - (let* ((ename (aref descr 0)) + (let* ((ename (archive--file-desc-ext-file-name descr)) (tmpfile (expand-file-name ename archive-tmpdir)) (top (directory-file-name (file-name-as-directory archive-tmpdir))) (default-directory (file-name-as-directory top))) @@ -1270,9 +1331,10 @@ using `make-temp-file', and the generated name is returned." ;; further processing clobbers it (we restore it in ;; archive-write-file-member, above). (setq archive-member-coding-system last-coding-system-used) - (if (aref descr 3) + (if (archive--file-desc-mode descr) ;; Set the file modes, but make sure we can read it. - (set-file-modes tmpfile (logior ?\400 (aref descr 3)))) + (set-file-modes tmpfile + (logior ?\400 (archive--file-desc-mode descr)))) (setq ename (encode-coding-string ename archive-file-name-coding-system)) (let* ((coding-system-for-write 'no-conversion) @@ -1376,7 +1438,7 @@ Use \\[archive-unmark-all-files] to remove all marks." "Change the protection bits associated with all marked or this member. The new protection bits can either be specified as an octal number or as a relative change like \"g+rw\" as for chmod(2)." - (interactive "sNew mode (octal or relative): ") + (interactive "sNew mode (octal or symbolic): ") (if archive-read-only (error "Archive is read-only")) (let ((func (archive-name "chmod-entry"))) (if (fboundp func) @@ -1415,7 +1477,9 @@ as a relative change like \"g+rw\" as for chmod(2)." (goto-char archive-file-list-start) (while (< (point) archive-file-list-end) (if (= (following-char) ?D) - (setq files (cons (aref (archive-get-descr) 0) files))) + (setq files (cons (archive--file-desc-ext-file-name + (archive-get-descr)) + files))) (forward-line 1))) (setq files (nreverse files)) (and files @@ -1461,12 +1525,11 @@ as a relative change like \"g+rw\" as for chmod(2)." (error "Renaming is not supported for this archive type")))) ;; Revert the buffer and recompute the dired-like listing. -(defun archive-mode-revert (&optional _no-auto-save _no-confirm) +(defun archive--mode-revert (orig-fun &rest args) (let ((no (archive-get-lineno))) (setq archive-files nil) - (let ((revert-buffer-function nil) - (coding-system-for-read 'no-conversion)) - (revert-buffer t t)) + (let ((coding-system-for-read 'no-conversion)) + (apply orig-fun t t (cddr args))) (archive-mode) (goto-char archive-file-list-start) (archive-next-line no))) @@ -1477,15 +1540,135 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (interactive) (let ((inhibit-read-only t)) (undo))) + +(defun archive--fit (str len) + (let* ((spaces (- len (string-width str))) + (pre (/ spaces 2))) + (if (< spaces 1) + (substring str 0 len) + (concat (make-string pre ?\s) str (make-string (- spaces pre) ?\s))))) + +(defun archive--fit2 (str1 str2 len) + (let* ((spaces (- len (string-width str1) (string-width str2)))) + (if (< spaces 1) + (substring (concat str1 str2) 0 len) + (concat str1 (make-string spaces ?\s) str2)))) + +(defun archive--enabled-p (column) + (not (memq column archive-hidden-columns))) + +(defun archive--summarize-descs (descs) + (goto-char (point-min)) + (if (null descs) + (progn (insert "M ... Filename\n") + (insert "- ----- ---------------\n") + (archive-summarize-files nil) + (insert "- ----- ---------------\n")) + (let* ((sample (car descs)) + (maxsize 0) + (maxidlen 0) + (totalsize 0) + (times (archive--enabled-p 'Date&Time)) + (ids (and (archive--enabled-p 'Ids) + (or (archive--file-desc-uid sample) + (archive--file-desc-gid sample)))) + ;; For ratio, date/time, and mode, we presume that + ;; they're either present on all entries or on nonel, and that they + ;; take the same space on each of them. + (ratios (and (archive--enabled-p 'Ratio) + (archive--file-desc-ratio sample))) + (ratiolen (if ratios (string-width ratios))) + (timelen (length (archive--file-desc-time sample))) + (samplemode (and (archive--enabled-p 'Mode) + (archive--file-desc-mode sample))) + (modelen (length (if samplemode (file-modes-number-to-symbolic samplemode))))) + (dolist (desc descs) + (when ids + (let* ((uid (archive--file-desc-uid desc)) + (gid (archive--file-desc-uid desc)) + (len (cond + ((not uid) (string-width gid)) + ((not gid) (string-width uid)) + (t (+ (string-width uid) (string-width gid) 1))))) + (if (> len maxidlen) (setq maxidlen len)))) + (let ((size (archive--file-desc-size desc))) + (cl-incf totalsize size) + (if (> size maxsize) (setq maxsize size)))) + (let* ((sizelen (length (number-to-string maxsize))) + (dash + (concat + "- " + (if (> modelen 0) (concat (make-string modelen ?-) " ")) + (if ids (concat (make-string maxidlen ?-) " ")) + (make-string sizelen ?-) " " + (if ratios (concat (make-string (1+ ratiolen) ?-) " ")) + " " + (if times (concat (make-string timelen ?-) " ")) + "----------------\n")) + (startcol (+ 2 + (if (> modelen 0) (+ 2 modelen) 0) + (if ids (+ maxidlen 2) 0) + sizelen 2 + (if ratios (+ 2 ratiolen) 0) + (if times (+ timelen 2) 0)))) + (insert + (concat "M " + (if (> modelen 0) (concat (archive--fit "Mode" modelen) " ")) + (if ids (concat (archive--fit2 "Uid" "Gid" maxidlen) " ")) + (archive--fit "Size" sizelen) " " + (if ratios (concat (archive--fit "Cmp" (1+ ratiolen)) " ")) + " " + (if times (concat (archive--fit "Date&time" timelen) " ")) + " Filename\n")) + (insert dash) + (archive-summarize-files + (mapcar (lambda (desc) + (let* ((size (number-to-string + (archive--file-desc-size desc))) + (text + (concat " " + (when (> modelen 0) + (concat (file-modes-number-to-symbolic + (archive--file-desc-mode desc)) + " ")) + (when ids + (concat (archive--fit2 + (archive--file-desc-uid desc) + (archive--file-desc-gid desc) + maxidlen) " ")) + (make-string (- sizelen (length size)) ?\s) + size + " " + (when ratios + (concat (archive--file-desc-ratio desc) + "% ")) + " " + (when times + (concat (archive--file-desc-time desc) + " ")) + (archive--file-desc-int-file-name desc)))) + (archive--file-summary + text startcol (length text)))) + descs)) + (insert dash) + (insert (format (format "%%%dd %%s %%d files\n" + (+ 2 + (if (> modelen 0) (+ 2 modelen) 0) + (if ids (+ maxidlen 2) 0) + sizelen)) + totalsize + (make-string (+ (if times (+ 2 timelen) 0) + (if ratios (+ 2 ratiolen) 0) 1) + ?\s) + (length descs)))))) + (apply #'vector descs)) + ;; ------------------------------------------------------------------------- ;;; Section: Arc Archives (defun archive-arc-summarize () (let ((p 1) - (totalsize 0) - (maxlen 8) - files - visual) + files) (while (and (< (+ p 29) (point-max)) (= (get-byte p) ?\C-z) (> (get-byte (1+ p)) 0)) @@ -1498,48 +1681,28 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (modtime (archive-l-e (+ p 21) 2)) (ucsize (archive-l-e (+ p 25) 4)) (fiddle (string= efnname (upcase efnname))) - (ifnname (if fiddle (downcase efnname) efnname)) - (text (format " %8d %-11s %-8s %s" - ucsize - (archive-dosdate moddate) - (archive-dostime modtime) - ifnname))) - (setq maxlen (max maxlen fnlen) - totalsize (+ totalsize ucsize) - visual (cons (vector text - (- (length text) (length ifnname)) - (length text)) - visual) - files (cons (vector efnname ifnname fiddle nil (1- p)) + (ifnname (if fiddle (downcase efnname) efnname))) + (setq files (cons (archive--file-desc + efnname ifnname nil ucsize + (concat (archive-dosdate moddate) + " " (archive-dostime modtime)) + :pos (1- p)) files) p (+ p 29 csize)))) - (goto-char (point-min)) - (let ((dash (concat "- -------- ----------- -------- " - (make-string maxlen ?-) - "\n"))) - (insert "M Length Date Time File\n" - dash) - (archive-summarize-files (nreverse visual)) - (insert dash - (format " %8d %d file%s" - totalsize - (length files) - (if (= 1 (length files)) "" "s")) - "\n")) - (apply #'vector (nreverse files)))) + (archive--summarize-descs (nreverse files)))) (defun archive-arc-rename-entry (newname descr) (if (string-match "[:\\/]" newname) (error "File names in arc files must not contain a directory component")) (if (> (length newname) 12) (error "File names in arc files are limited to 12 characters")) - (let ((name (concat newname (substring "\0\0\0\0\0\0\0\0\0\0\0\0\0" - (length newname)))) + (let ((name (concat newname (make-string (- 13 (length newname)) ?\0))) (inhibit-read-only t)) (save-restriction (save-excursion (widen) - (goto-char (+ archive-proper-file-start (aref descr 4) 2)) + (goto-char (+ archive-proper-file-start 2 + (archive--file-desc-pos descr))) (delete-char 13) (arc-insert-unibyte name))))) ;; ------------------------------------------------------------------------- @@ -1547,10 +1710,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (defun archive-lzh-summarize (&optional start) (let ((p (or start 1)) ;; 1 for .lzh, something further on for .exe - (totalsize 0) - (maxlen 8) - files - visual) + files) (while (progn (goto-char p) ;beginning of a base header. (looking-at "\\(.\\|\n\\)\\(.\\|\n\\)-l[hz][0-9ds]-")) (let* ((hsize (get-byte p)) ;size of the base header (level 0 and 1) @@ -1561,9 +1721,9 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (time2 (archive-l-e (+ p 17) 2)) ;and UNIX format in level 2 header.) (hdrlvl (get-byte (+ p 20))) ;header level thsize ;total header size (base + extensions) - fnlen efnname osid fiddle ifnname width p2 + fnlen efnname osid fiddle ifnname p2 neh ;beginning of next extension header (level 1 and 2) - mode modestr uid gid text dir prname + mode uid gid dir prname gname uname modtime moddate) (if (= hdrlvl 3) (error "can't handle lzh level 3 header type")) (when (or (= hdrlvl 0) (= hdrlvl 1)) @@ -1576,26 +1736,26 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (setq neh (+ p2 3)) ;specific to level 1 header (if (= hdrlvl 2) (setq neh (+ p 24)))) ;specific to level 2 header - (if neh ;if level 1 or 2 we expect extension headers to follow + (if neh ;if level 1 or 2 we expect extension headers to follow (let* ((ehsize (archive-l-e neh 2)) ;size of the extension header (etype (get-byte (+ neh 2)))) ;extension type (while (not (= ehsize 0)) - (cond - ((= etype 1) ;file name + (cond + ((= etype 1) ;file name (let ((i (+ neh 3))) (while (< i (+ neh ehsize)) (setq efnname (concat efnname (char-to-string (get-byte i)))) (setq i (1+ i))))) - ((= etype 2) ;directory name + ((= etype 2) ;directory name (let ((i (+ neh 3))) (while (< i (+ neh ehsize)) - (setq dir (concat dir - (if (= (get-byte i) - 255) - "/" - (char-to-string - (char-after i))))) - (setq i (1+ i))))) + (setq dir (concat dir + (if (= (get-byte i) + 255) + "/" + (char-to-string + (char-after i))))) + (setq i (1+ i))))) ((= etype 80) ;Unix file permission (setq mode (archive-l-e (+ neh 3) 2))) ((= etype 81) ;UNIX file group/user ID @@ -1611,7 +1771,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (while (< i (+ neh ehsize)) (setq uname (concat uname (char-to-string (char-after i)))) (setq i (1+ i))))) - ) + ) (setq neh (+ neh ehsize)) (setq ehsize (archive-l-e neh 2)) (setq etype (get-byte (+ neh 2)))) @@ -1637,60 +1797,25 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." ((= 0 osid) (string= efnname (upcase efnname))))) (setq ifnname (if fiddle (downcase efnname) efnname)) (setq prname (if dir (concat dir ifnname) ifnname)) - (setq width (if prname (string-width prname) 0)) - (setq modestr (if mode (archive-int-to-mode mode) "??????????")) (setq moddate (if (= hdrlvl 2) (archive-unixdate time1 time2) ;level 2 header in UNIX format (archive-dosdate time2))) ;level 0 and 1 header in DOS format (setq modtime (if (= hdrlvl 2) (archive-unixtime time1 time2) (archive-dostime time1))) - (setq text (if archive-alternate-display - (format " %8d %5S %5S %s" - ucsize - (or uid "?") - (or gid "?") - ifnname) - (format " %10s %8d %-11s %-8s %s" - modestr - ucsize - moddate - modtime - prname))) - (setq maxlen (max maxlen width) - totalsize (+ totalsize ucsize) - visual (cons (vector text - (- (length text) (length prname)) - (length text)) - visual) - files (cons (vector prname ifnname fiddle mode (1- p)) - files)) + (push (archive--file-desc + prname ifnname mode ucsize + (concat moddate " " modtime) + :pos (1- p) + :uid (or uname (if uid (number-to-string uid))) + :gid (or gname (if gid (number-to-string gid)))) + files) (cond ((= hdrlvl 1) (setq p (+ p hsize 2 csize))) ((or (= hdrlvl 2) (= hdrlvl 0)) (setq p (+ p thsize 2 csize)))) )) - (goto-char (point-min)) - (let ((dash (concat (if archive-alternate-display - "- -------- ----- ----- " - "- ---------- -------- ----------- -------- ") - (make-string maxlen ?-) - "\n")) - (header (if archive-alternate-display - "M Length Uid Gid File\n" - "M Filemode Length Date Time File\n")) - (sumline (if archive-alternate-display - " %8.0f %d file%s" - " %8.0f %d file%s"))) - (insert header dash) - (archive-summarize-files (nreverse visual)) - (insert dash - (format sumline - totalsize - (length files) - (if (= 1 (length files)) "" "s")) - "\n")) - (apply #'vector (nreverse files)))) + (archive--summarize-descs (nreverse files)))) (defconst archive-lzh-alternate-display t) @@ -1709,7 +1834,8 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (save-restriction (save-excursion (widen) - (let* ((p (+ archive-proper-file-start (aref descr 4))) + (let* ((p (+ archive-proper-file-start + (archive--file-desc-pos descr))) (oldhsize (get-byte p)) (oldfnlen (get-byte (+ p 21))) (newfnlen (length newname)) @@ -1729,7 +1855,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (save-restriction (widen) (dolist (fil files) - (let* ((p (+ archive-proper-file-start (aref fil 4))) + (let* ((p (+ archive-proper-file-start (archive--file-desc-pos fil))) (hsize (get-byte p)) (fnlen (get-byte (+ p 21))) (p2 (+ p 22 fnlen)) @@ -1746,7 +1872,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (delete-char 1) (arc-insert-unibyte (archive-lzh-resum (1+ p) hsize))) (message "Member %s does not have %s field" - (aref fil 1) errtxt))))))) + (archive--file-desc-int-file-name fil) errtxt))))))) (defun archive-lzh-chown-entry (newuid files) (archive-lzh-ogm newuid files "an uid" 10)) @@ -1756,8 +1882,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (defun archive-lzh-chmod-entry (newmode files) (archive-lzh-ogm - ;; This should work even though newmode will be dynamically accessed. - (lambda (old) (archive-calc-mode old newmode t)) + (lambda (old) (archive-calc-mode old newmode)) files "a unix-style mode" 8)) ;; ------------------------------------------------------------------------- @@ -1794,11 +1919,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (goto-char (- (point-max) (- 22 18))) (search-backward-regexp "[P]K\005\006") (let ((p (archive-l-e (+ (point) 16) 4)) - (maxlen 8) - (totalsize 0) - files - visual - emacs-int-has-32bits) + files) (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 @@ -1824,7 +1945,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (fnlen (archive-l-e (+ p 28) 2)) (exlen (archive-l-e (+ p 30) 2)) (fclen (archive-l-e (+ p 32) 2)) - (lheader (archive-l-e (+ p 42) 4)) + ;; (lheader (archive-l-e (+ p 42) 4)) (efnname (let ((str (buffer-substring (+ p 46) (+ p 46 fnlen)))) (decode-coding-string str archive-file-name-coding-system))) @@ -1839,44 +1960,18 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (logand 1 (get-byte (+ p 38)))) ?\222 0))) (t nil))) - (modestr (if mode (archive-int-to-mode mode) "??????????")) (fiddle (and archive-zip-case-fiddle - (not (not (memq creator '(0 2 4 5 9)))) + (memq creator '(0 2 4 5 9)) (string= (upcase efnname) efnname))) - (ifnname (if fiddle (downcase efnname) efnname)) - (width (string-width ifnname)) - (text (format " %10s %8d %-11s %-8s %s" - modestr - ucsize - (archive-dosdate moddate) - (archive-dostime modtime) - ifnname))) - (setq maxlen (max maxlen width) - totalsize (+ totalsize ucsize) - visual (cons (vector text - (- (length text) (length ifnname)) - (length text)) - visual) - files (cons (if isdir - nil - (vector efnname ifnname fiddle mode - (list (1- p) lheader))) - files) + (ifnname (if fiddle (downcase efnname) efnname))) + (setq files (cons (archive--file-desc + efnname ifnname mode ucsize + (concat (archive-dosdate moddate) + " " (archive-dostime modtime)) + :pos (1- p)) + files) p (+ p 46 fnlen exlen fclen)))) - (goto-char (point-min)) - (let ((dash (concat "- ---------- -------- ----------- -------- " - (make-string maxlen ?-) - "\n"))) - (insert "M Filemode Length Date Time File\n" - dash) - (archive-summarize-files (nreverse visual)) - (insert dash - (format " %8d %d file%s" - totalsize - (length files) - (if (= 1 (length files)) "" "s")) - "\n")) - (apply #'vector (nreverse files)))) + (archive--summarize-descs (nreverse files)))) (defun archive-zip-extract (archive name) (cond @@ -1901,21 +1996,27 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." name) archive-zip-extract)))) +(defun archive--file-desc-case-fiddled (fd) + (not (eq (archive--file-desc-int-file-name fd) + (archive--file-desc-ext-file-name fd)))) + (defun archive-zip-write-file-member (archive descr) (archive-*-write-file-member archive descr - (if (aref descr 2) archive-zip-update-case archive-zip-update))) + (if (archive--file-desc-case-fiddled descr) + archive-zip-update-case archive-zip-update))) (defun archive-zip-chmod-entry (newmode files) (save-restriction (save-excursion (widen) (dolist (fil files) - (let* ((p (+ archive-proper-file-start (car (aref fil 4)))) + (let* ((p (+ archive-proper-file-start + (archive--file-desc-pos fil))) (creator (get-byte (+ p 5))) - (oldmode (aref fil 3)) - (newval (archive-calc-mode oldmode newmode t)) + (oldmode (archive--file-desc-mode fil)) + (newval (archive-calc-mode oldmode newmode)) (inhibit-read-only t)) (cond ((memq creator '(2 3)) ; Unix (goto-char (+ p 40)) @@ -1934,10 +2035,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (defun archive-zoo-summarize () (let ((p (1+ (archive-l-e 25 4))) - (maxlen 8) - (totalsize 0) - files - visual) + files) (while (and (string= "\334\247\304\375" (buffer-substring p (+ p 4))) (> (archive-l-e (+ p 6) 4) 0)) (let* ((next (1+ (archive-l-e (+ p 6) 4))) @@ -1964,36 +2062,14 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (decode-coding-string str archive-file-name-coding-system))) (fiddle (and (= lfnlen 0) (string= efnname (upcase efnname)))) - (ifnname (if fiddle (downcase efnname) efnname)) - (width (string-width ifnname)) - (text (format " %8d %-11s %-8s %s" - ucsize - (archive-dosdate moddate) - (archive-dostime modtime) - ifnname))) - (setq maxlen (max maxlen width) - totalsize (+ totalsize ucsize) - visual (cons (vector text - (- (length text) (length ifnname)) - (length text)) - visual) - files (cons (vector efnname ifnname fiddle nil (1- p)) + (ifnname (if fiddle (downcase efnname) efnname))) + (setq files (cons (archive--file-desc + efnname ifnname nil ucsize + (concat (archive-dosdate moddate) + " " (archive-dostime modtime))) files) p next))) - (goto-char (point-min)) - (let ((dash (concat "- -------- ----------- -------- " - (make-string maxlen ?-) - "\n"))) - (insert "M Length Date Time File\n" - dash) - (archive-summarize-files (nreverse visual)) - (insert dash - (format " %8d %d file%s" - totalsize - (length files) - (if (= 1 (length files)) "" "s")) - "\n")) - (apply #'vector (nreverse files)))) + (archive--summarize-descs (nreverse files)))) (defun archive-zoo-extract (archive name) (archive-extract-by-stdout archive name archive-zoo-extract)) @@ -2005,17 +2081,16 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." ;; File is used internally for `archive-rar-exe-summarize'. (unless file (setq file buffer-file-name)) (let* ((copy (file-local-copy file)) - (maxname 10) - (maxsize 5) (files ())) (with-temp-buffer - (call-process "lsar" nil t nil "-l" (or file copy)) - (if copy (delete-file copy)) + (unwind-protect + (call-process "lsar" nil t nil "-l" (or file copy)) + (if copy (delete-file copy))) (goto-char (point-min)) - (re-search-forward "^\\(\s+=+\s*\\)+\n") + (re-search-forward "^\\(?:\s+=+\\)+\s*\n") (while (looking-at (concat "^\s+[0-9.]+\s+D?-+\s+" ; Flags "\\([0-9-]+\\)\s+" ; Size - "\\([-0-9.%]+\\)\s+" ; Ratio + "\\([-0-9.]+\\)%?\s+" ; Ratio "\\([0-9a-zA-Z]+\\)\s+" ; Mode "\\([0-9-]+\\)\s+" ; Date "\\([0-9:]+\\)\s+" ; Time @@ -2024,36 +2099,14 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (goto-char (match-end 0)) (let ((name (match-string 6)) (size (match-string 1))) - (if (> (length name) maxname) (setq maxname (length name))) - (if (> (length size) maxsize) (setq maxsize (length size))) - (push (vector name name nil nil - ;; Size, Ratio. - size (match-string 2) - ;; Date, Time. - (match-string 4) (match-string 5)) + (push (archive--file-desc name name nil + ;; Size + (string-to-number size) + ;; Date&Time. + (concat (match-string 4) " " (match-string 5)) + :ratio (match-string 2)) files)))) - (setq files (nreverse files)) - (goto-char (point-min)) - (let* ((format (format " %%s %%s %%%ds %%5s %%s" maxsize)) - (sep (format format "----------" "-----" (make-string maxsize ?-) - "-----" "")) - (column (length sep))) - (insert (format format " Date " "Time " "Size" "Ratio" "Filename") "\n") - (insert sep (make-string maxname ?-) "\n") - (archive-summarize-files (mapcar (lambda (desc) - (let ((text - (format format - (aref desc 6) - (aref desc 7) - (aref desc 4) - (aref desc 5) - (aref desc 1)))) - (vector text - column - (length text)))) - files)) - (insert sep (make-string maxname ?-) "\n") - (apply #'vector files)))) + (archive--summarize-descs (nreverse files)))) (defun archive-rar-extract (archive name) ;; unrar-free seems to have no way to extract to stdout or even to a file. @@ -2100,9 +2153,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." ;;; Section: 7z Archives (defun archive-7z-summarize () - (let ((maxname 10) - (maxsize 5) - (file buffer-file-name) + (let ((file buffer-file-name) (files ())) (with-temp-buffer (call-process archive-7z-program nil t nil "l" "-slt" file) @@ -2119,29 +2170,9 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (time (save-excursion (and (re-search-forward "^Modified = \\(.*\\)\n") (match-string 1))))) - (if (> (length name) maxname) (setq maxname (length name))) - (if (> (length size) maxsize) (setq maxsize (length size))) - (push (vector name name nil nil time nil nil size) + (push (archive--file-desc name name nil (string-to-number size) time) files)))) - (setq files (nreverse files)) - (goto-char (point-min)) - (let* ((format (format " %%%ds %%s %%s" maxsize)) - (sep (format format (make-string maxsize ?-) "-------------------" "")) - (column (length sep))) - (insert (format format "Size " "Date Time " " Filename") "\n") - (insert sep (make-string maxname ?-) "\n") - (archive-summarize-files (mapcar (lambda (desc) - (let ((text - (format format - (aref desc 7) - (aref desc 4) - (aref desc 1)))) - (vector text - column - (length text)))) - files)) - (insert sep (make-string maxname ?-) "\n") - (apply #'vector files)))) + (archive--summarize-descs (nreverse files)))) (defun archive-7z-extract (archive name) ;; 7z doesn't provide a `quiet' option to suppress non-essential @@ -2168,79 +2199,43 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (defconst archive-ar-file-header-re "\\(.\\{16\\}\\)\\([ 0-9]\\{12\\}\\)\\([ 0-9]\\{6\\}\\)\\([ 0-9]\\{6\\}\\)\\([ 0-7]\\{8\\}\\)\\([ 0-9]\\{10\\}\\)`\n") +(defun archive-ar--name (name) + "Return the external name represented by the entry NAME. +NAME is expected to be the 16-bytes part of an ar record." + (cond ((equal name "// ") + (propertize ".<ExtNamesTable>." 'face 'italic)) + ((equal name "/ ") + (propertize ".<LookupTable>." 'face 'italic)) + ((string-match "/? *\\'" name) + ;; FIXME: Decode? Add support for longer names? + (substring name 0 (match-beginning 0))))) + (defun archive-ar-summarize () ;; File is used internally for `archive-rar-exe-summarize'. - (let* ((maxname 10) - (maxtime 16) - (maxuser 5) - (maxgroup 5) - (maxmode 8) - (maxsize 5) - (files ())) + (let* ((files ())) (goto-char (point-min)) (search-forward "!<arch>\n") (while (looking-at archive-ar-file-header-re) - (let ((name (match-string 1)) - extname - (time (string-to-number (match-string 2))) - (user (match-string 3)) - (group (match-string 4)) - (mode (string-to-number (match-string 5) 8)) - (size (string-to-number (match-string 6)))) + (let* ((name (match-string 1)) + extname + (time (string-to-number (match-string 2))) + (user (match-string 3)) + (group (match-string 4)) + (mode (string-to-number (match-string 5) 8)) + (sizestr (match-string 6)) + (size (string-to-number sizestr))) ;; Move to the beginning of the data. (goto-char (match-end 0)) (setq time (format-time-string "%Y-%m-%d %H:%M" time)) - (setq extname - (cond ((equal name "// ") - (propertize ".<ExtNamesTable>." 'face 'italic)) - ((equal name "/ ") - (propertize ".<LookupTable>." 'face 'italic)) - ((string-match "/? *\\'" name) - (substring name 0 (match-beginning 0))))) + (setq extname (archive-ar--name name)) (setq user (substring user 0 (string-match " +\\'" user))) (setq group (substring group 0 (string-match " +\\'" group))) - (setq mode (tar-grind-file-mode mode)) ;; Move to the end of the data. (forward-char size) (if (eq ?\n (char-after)) (forward-char 1)) - (setq size (number-to-string size)) - (if (> (length name) maxname) (setq maxname (length name))) - (if (> (length time) maxtime) (setq maxtime (length time))) - (if (> (length user) maxuser) (setq maxuser (length user))) - (if (> (length group) maxgroup) (setq maxgroup (length group))) - (if (> (length mode) maxmode) (setq maxmode (length mode))) - (if (> (length size) maxsize) (setq maxsize (length size))) - (push (vector name extname nil mode - time user group size) + (push (archive--file-desc extname extname mode size time + :uid user :gid group) files))) - (setq files (nreverse files)) - (goto-char (point-min)) - (let* ((format (format "%%%ds %%%ds/%%-%ds %%%ds %%%ds %%s" - maxmode maxuser maxgroup maxsize maxtime)) - (sep (format format (make-string maxmode ?-) - (make-string maxuser ?-) - (make-string maxgroup ?-) - (make-string maxsize ?-) - (make-string maxtime ?-) "")) - (column (length sep))) - (insert (format format " Mode " "User" "Group" " Size " - " Date " "Filename") - "\n") - (insert sep (make-string maxname ?-) "\n") - (archive-summarize-files (mapcar (lambda (desc) - (let ((text - (format format - (aref desc 3) - (aref desc 5) - (aref desc 6) - (aref desc 7) - (aref desc 4) - (aref desc 1)))) - (vector text - column - (length text)))) - files)) - (insert sep (make-string maxname ?-) "\n") - (apply #'vector files)))) + (archive--summarize-descs (nreverse files)))) (defun archive-ar-extract (archive name) (let ((destbuf (current-buffer)) @@ -2257,10 +2252,11 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (let ((this (match-string 1))) (setq size (string-to-number (match-string 6))) (goto-char (match-end 0)) - (if (equal name this) + (if (equal name (archive-ar--name this)) (setq from (point)) ;; Move to the end of the data. - (forward-char size) (if (eq ?\n (char-after)) (forward-char 1))))) + (forward-char size) + (if (eq ?\n (char-after)) (forward-char 1))))) (when from (set-buffer-multibyte nil) (with-current-buffer destbuf @@ -2270,6 +2266,13 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." ;; Inform the caller that the call succeeded. t)))))) +(defun archive-ar-write-file-member (archive descr) + (archive-*-write-file-member + archive + descr + '("ar" "r"))) + + ;; ------------------------------------------------------------------------- ;; This line was a mistake; it is kept now for compatibility. ;; rms 15 Oct 98 diff --git a/lisp/autoarg.el b/lisp/autoarg.el index c0307aa92b1..d41527775f4 100644 --- a/lisp/autoarg.el +++ b/lisp/autoarg.el @@ -1,4 +1,4 @@ -;;; autoarg.el --- make digit keys supply prefix args +;;; autoarg.el --- make digit keys supply prefix args -*- lexical-binding: t -*- ;; Copyright (C) 1998, 2000-2020 Free Software Foundation, Inc. @@ -59,9 +59,8 @@ ;; (define-key autoarg-mode-map [?\r] 'autoarg-terminate) (defvar autoarg-kp-digits - (let (alist) - (dotimes (i 10 alist) - (push (cons (intern (format "kp-%d" i)) i) alist)))) + (mapcar (lambda (i) (cons (intern (format "kp-%d" i)) i)) + (reverse (number-sequence 0 9)))) (defun autoarg-kp-digit-argument (arg) "Part of the numeric argument for the next command, like `digit-argument'." diff --git a/lisp/autoinsert.el b/lisp/autoinsert.el index 25961d41089..4af3d631a2c 100644 --- a/lisp/autoinsert.el +++ b/lisp/autoinsert.el @@ -396,7 +396,7 @@ Matches the visited file name against the elements of `auto-insert-alist'." ;; which might ask the user for something (switch-to-buffer (current-buffer)) (if (and (consp action) - (not (eq (car action) 'lambda))) + (not (functionp action))) (skeleton-insert action) (funcall action))))) (if (vectorp action) diff --git a/lisp/autorevert.el b/lisp/autorevert.el index 011febfe728..6e08176f5ff 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..e568ab52460 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, BSD, 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. +;; - BSD by using the `apm' program. +;; - 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,41 +43,75 @@ :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 + "Preferred UPower device name(s). +When `battery-status-function' is set to `battery-upower', this +user option specifies which power sources to query for status +information and merge into a single report. + +When nil (the default), `battery-upower' queries all present +battery and line power devices as determined by the UPower +EnumerateDevices method. A string or a nonempty list of strings +names particular devices to query instead. UPower battery and +line power device names typically follow the patterns +\"battery_BATN\" and \"line_power_ACN\", respectively, with N +starting at 0 when present. Device names should not include the +leading D-Bus path \"/org/freedesktop/UPower/devices/\"." + :version "28.1" + :type '(choice (const :tag "Autodetect all devices" nil) + (string :tag "Device") + (repeat :tag "Devices" string))) + +(defcustom battery-upower-subscribe t + "Whether to subscribe to UPower device change signals. +When nil, battery status information is polled every +`battery-update-interval' seconds. When non-nil (the default), +the battery status is also updated whenever a power source is +added or removed, or when the system starts or stops running on +battery power. + +This only takes effect when `battery-status-function' is set to +`battery-upower' before enabling `display-battery-mode'." + :version "28.1" + :type 'boolean) + +(defconst battery-upower-service "org.freedesktop.UPower" + "Well-known name of the UPower D-Bus service. +See URL `https://upower.freedesktop.org/docs/ref-dbus.html'.") + +(defun battery--files (dir) + "Return a list of absolute file names in DIR or nil on error. +Value does not include \".\" or \"..\"." + (ignore-errors (directory-files dir t directory-files-no-dot-files-regexp))) (defun battery--find-linux-sysfs-batteries () - (let ((dirs nil)) - (dolist (file (directory-files "/sys/class/power_supply/" t)) - (when (and (or (file-directory-p file) - (file-symlink-p file)) - (file-exists-p (expand-file-name "capacity" file))) - (push file dirs))) + "Return a list of all sysfs battery directories." + (let (dirs) + (dolist (dir (battery--files "/sys/class/power_supply/")) + (when (file-exists-p (expand-file-name "capacity" dir)) + (push dir dirs))) (nreverse dirs))) (defcustom battery-status-function - (cond ((and (eq system-type 'gnu/linux) - (file-readable-p "/proc/apm")) - #'battery-linux-proc-apm) + (cond ((member battery-upower-service (dbus-list-activatable-names)) + #'battery-upower) + ((and (eq system-type 'gnu/linux) + (battery--find-linux-sysfs-batteries)) + #'battery-linux-sysfs) ((and (eq system-type 'gnu/linux) (file-directory-p "/proc/acpi/battery")) #'battery-linux-proc-acpi) ((and (eq system-type 'gnu/linux) - (file-directory-p "/sys/class/power_supply/") - (battery--find-linux-sysfs-batteries)) - #'battery-linux-sysfs) + (file-readable-p "/proc/apm")) + #'battery-linux-proc-apm) ((and (eq system-type 'berkeley-unix) (file-executable-p "/usr/sbin/apm")) #'battery-bsd-apm) ((and (eq system-type 'darwin) - (condition-case nil - (with-temp-buffer - (and (eq (call-process "pmset" nil t nil "-g" "ps") 0) - (> (buffer-size) 0))) - (error nil))) + (ignore-errors + (with-temp-buffer + (and (eq (call-process "pmset" nil t nil "-g" "ps") 0) + (not (bobp)))))) #'battery-pmset) ((fboundp 'w32-battery-status) #'w32-battery-status)) @@ -84,8 +123,8 @@ 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) + :version "28.1" + :type '(choice (const nil) function)) (defcustom battery-echo-area-format "Power %L, battery %B (%p%% load, remaining time %t)" @@ -96,17 +135,20 @@ string are substituted as defined by the current value of the variable `battery-status-function'. Here are the ones generally available: %c Current capacity (mAh or mWh) %r Current rate of charge or discharge +%L AC line status (verbose) %B Battery status (verbose) %b Battery status: empty means high, `-' means low, `!' means critical, and `+' means charging %d Temperature (in degrees Celsius) -%L AC line status (verbose) %p Battery load percentage +%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'" - :type '(choice string (const nil)) - :group 'battery) +%t Remaining time (to charge or discharge) in the form `h:min' + +The full `format-spec' formatting syntax is supported." + :link '(info-link "(elisp) Custom Format Strings") + :type '(choice string (const nil))) (defvar battery-mode-line-string nil "String to display in the mode line.") @@ -115,11 +157,10 @@ 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) + (cond ((eq battery-status-function #'battery-linux-proc-acpi) "[%b%p%%,%d°C]") (battery-status-function "[%b%p%%]")) @@ -130,34 +171,46 @@ string are substituted as defined by the current value of the variable `battery-status-function'. Here are the ones generally available: %c Current capacity (mAh or mWh) %r Current rate of charge or discharge +%L AC line status (verbose) %B Battery status (verbose) %b Battery status: empty means high, `-' means low, `!' means critical, and `+' means charging %d Temperature (in degrees Celsius) -%L AC line status (verbose) %p Battery load percentage +%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'" - :type '(choice string (const nil)) - :group 'battery) +%t Remaining time (to charge or discharge) in the form `h:min' + +The full `format-spec' formatting syntax is supported." + :link '(info-link "(elisp) Custom Format Strings") + :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) + +(defface battery-load-low + '((t :inherit warning)) + "Face used in mode line string when battery load is low. +See the option `battery-load-low'." + :version "28.1") + +(defface battery-load-critical + '((t :inherit error)) + "Face used in mode line string when battery load is critical. +See the option `battery-load-critical'." + :version "28.1") (defvar battery-update-timer nil "Interval timer object.") @@ -181,17 +234,21 @@ 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)) + (battery--upower-unsubscribe) (if (and battery-status-function battery-mode-line-format) (if (not display-battery-mode) (setq global-mode-string (delq 'battery-mode-line-string global-mode-string)) (add-to-list 'global-mode-string 'battery-mode-line-string t) + (and (eq battery-status-function #'battery-upower) + battery-upower-subscribe + (battery--upower-subsribe)) (setq battery-update-timer (run-at-time nil battery-update-interval - 'battery-update-handler)) + #'battery-update-handler)) (battery-update)) (message "Battery status not available") (setq display-battery-mode nil))) @@ -203,34 +260,42 @@ seconds." (defun battery-update () "Update battery status information in the mode line." (let* ((data (and battery-status-function (funcall battery-status-function))) - (percentage (car (read-from-string (cdr (assq ?p data)))))) - (setq battery-mode-line-string - (propertize (if (and battery-mode-line-format - (numberp percentage) - (<= percentage battery-mode-line-limit)) - (battery-format battery-mode-line-format data) - "") - 'face - (and (numberp percentage) - (<= percentage battery-load-critical) - 'error) - 'help-echo "Battery status information"))) - (force-mode-line-update)) + (percentage (car (read-from-string (cdr (assq ?p data))))) + (res (and battery-mode-line-format + (or (not (numberp percentage)) + (<= percentage battery-mode-line-limit)) + (battery-format battery-mode-line-format data))) + (len (length res))) + (unless (zerop len) + (cond ((not (numberp percentage))) + ((< percentage battery-load-critical) + (add-face-text-property 0 len 'battery-load-critical t res)) + ((< percentage battery-load-low) + (add-face-text-property 0 len 'battery-load-low t res))) + (put-text-property 0 len 'help-echo "Battery status information" res)) + (setq battery-mode-line-string (or res ""))) + (force-mode-line-update t)) + ;;; `/proc/apm' interface for Linux. -(defconst battery-linux-proc-apm-regexp - (concat "^\\([^ ]+\\)" ; Driver version. - " \\([^ ]+\\)" ; APM BIOS version. - " 0x\\([0-9a-f]+\\)" ; APM BIOS flags. - " 0x\\([0-9a-f]+\\)" ; AC line status. - " 0x\\([0-9a-f]+\\)" ; Battery status. - " 0x\\([0-9a-f]+\\)" ; Battery flags. - " \\(-?[0-9]+\\)%" ; Load percentage. - " \\(-?[0-9]+\\)" ; Remaining time. - " \\(.*\\)" ; Time unit. - "$") +;; Regular expression matching contents of `/proc/apm'. +(rx-define battery--linux-proc-apm + (: bol (group (+ (not ?\s))) ; Driver version. + " " (group (+ (not ?\s))) ; APM BIOS version. + " 0x" (group (+ xdigit)) ; APM BIOS flags. + " 0x" (group (+ xdigit)) ; AC line status. + " 0x" (group (+ xdigit)) ; Battery status. + " 0x" (group (+ xdigit)) ; Battery flags. + " " (group (? ?-) (+ digit)) ?% ; Load percentage. + " " (group (? ?-) (+ digit)) ; Remaining time. + " " (group (* nonl)) ; Time unit + eol)) + +(defconst battery-linux-proc-apm-regexp (rx battery--linux-proc-apm) "Regular expression matching contents of `/proc/apm'.") +(make-obsolete-variable 'battery-linux-proc-apm-regexp + "it is no longer used." "28.1") (defun battery-linux-proc-apm () "Get APM status information from Linux (the kernel). @@ -250,12 +315,12 @@ The following %-sequences are provided: %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 (driver-version bios-version bios-interface line-status - battery-status battery-status-symbol load-percentage - seconds minutes hours remaining-time tem) + (let ( driver-version bios-version bios-interface line-status + battery-status battery-status-symbol load-percentage + seconds minutes hours remaining-time tem ) (with-temp-buffer (ignore-errors (insert-file-contents "/proc/apm")) - (when (re-search-forward battery-linux-proc-apm-regexp) + (when (re-search-forward (rx battery--linux-proc-apm) nil t) (setq driver-version (match-string 1)) (setq bios-version (match-string 2)) (setq tem (string-to-number (match-string 3) 16)) @@ -268,9 +333,7 @@ The following %-sequences are provided: (cond ((= tem 0) (setq line-status "off-line")) ((= tem 1) (setq line-status "on-line")) ((= tem 2) (setq line-status "on backup"))) - (setq tem (string-to-number (match-string 6) 16)) - (if (= tem 255) - (setq battery-status "N/A") + (unless (= (string-to-number (match-string 6) 16) 255) (setq tem (string-to-number (match-string 5) 16)) (cond ((= tem 0) (setq battery-status "high" battery-status-symbol "")) @@ -287,7 +350,7 @@ The following %-sequences are provided: (setq minutes (/ seconds 60) hours (/ seconds 3600)) (setq remaining-time - (format "%d:%02d" hours (- minutes (* 60 hours)))))))) + (format "%d:%02d" hours (% minutes 60))))))) (list (cons ?v (or driver-version "N/A")) (cons ?V (or bios-version "N/A")) (cons ?I (or bios-interface "N/A")) @@ -295,27 +358,31 @@ The following %-sequences are provided: (cons ?B (or battery-status "N/A")) (cons ?b (or battery-status-symbol "")) (cons ?p (or load-percentage "N/A")) - (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")) + (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"))))) ;;; `/proc/acpi/' interface for Linux. +(rx-define battery--acpi-rate (&rest hour) + (: (group (+ digit)) " " (group ?m (in "AW") hour))) +(rx-define battery--acpi-capacity (battery--acpi-rate ?h)) + (defun battery-linux-proc-acpi () "Get ACPI status information from Linux (the kernel). -This function works only with the `/proc/acpi/' format introduced -in Linux version 2.4.20 and 2.6.0. +This function works only with the `/proc/acpi/' interface +introduced in Linux version 2.4.20 and 2.6.0. The following %-sequences are provided: %c Current capacity (mAh) -%r Current rate +%r Current rate of charge or discharge +%L AC line status (verbose) %B Battery status (verbose) %b Battery status, empty means high, `-' means low, `!' means critical, and `+' means charging %d Temperature (in degrees Celsius) -%L AC line status (verbose) %p Battery load percentage %m Remaining time (to charge or discharge) in minutes %h Remaining time (to charge or discharge) in hours @@ -331,45 +398,51 @@ The following %-sequences are provided: ;; information together since displaying for a variable amount of ;; batteries seems overkill for format-strings. (with-temp-buffer - (dolist (dir (ignore-errors (directory-files "/proc/acpi/battery/" - t "\\`[^.]"))) - (erase-buffer) - (ignore-errors (insert-file-contents (expand-file-name "state" dir))) - (when (re-search-forward "present: +yes$" nil t) - (and (re-search-forward "charging state: +\\(.*\\)$" nil t) + (dolist (dir (battery--files "/proc/acpi/battery/")) + (ignore-errors + (insert-file-contents (expand-file-name "state" dir) nil nil nil t)) + (goto-char (point-min)) + (when (re-search-forward (rx "present:" (+ space) "yes" eol) nil t) + (and (re-search-forward (rx "charging state:" (+ space) + (group (not space) (* nonl)) eol) + nil t) (member charging-state '("unknown" "charged" nil)) ;; On most multi-battery systems, most of the time only one ;; battery is "charging"/"discharging", the others are ;; "unknown". (setq charging-state (match-string 1))) - (when (re-search-forward "present rate: +\\([0-9]+\\) \\(m[AW]\\)$" + (when (re-search-forward (rx "present rate:" (+ space) + (battery--acpi-rate) eol) nil t) (setq rate (+ (or rate 0) (string-to-number (match-string 1)))) (when (> rate 0) - (setq rate-type (or (and rate-type - (if (string= rate-type (match-string 2)) - rate-type - (error - "Inconsistent rate types (%s vs. %s)" - rate-type (match-string 2)))) - (match-string 2))))) - (when (re-search-forward "remaining capacity: +\\([0-9]+\\) m[AW]h$" + (cond ((not rate-type) + (setq rate-type (match-string 2))) + ((not (string= rate-type (match-string 2))) + (error "Inconsistent rate types (%s vs. %s)" + rate-type (match-string 2)))))) + (when (re-search-forward (rx "remaining capacity:" (+ space) + battery--acpi-capacity eol) nil t) (setq capacity (+ (or capacity 0) (string-to-number (match-string 1)))))) (goto-char (point-max)) (ignore-errors (insert-file-contents (expand-file-name "info" dir))) - (when (re-search-forward "present: +yes$" nil t) - (when (re-search-forward "design capacity: +\\([0-9]+\\) m[AW]h$" + (when (re-search-forward (rx "present:" (+ space) "yes" eol) nil t) + (when (re-search-forward (rx "design capacity:" (+ space) + battery--acpi-capacity eol) nil t) (cl-incf design-capacity (string-to-number (match-string 1)))) - (when (re-search-forward "last full capacity: +\\([0-9]+\\) m[AW]h$" + (when (re-search-forward (rx "last full capacity:" (+ space) + battery--acpi-capacity eol) nil t) (cl-incf last-full-capacity (string-to-number (match-string 1)))) - (when (re-search-forward - "design capacity warning: +\\([0-9]+\\) m[AW]h$" nil t) + (when (re-search-forward (rx "design capacity warning:" (+ space) + battery--acpi-capacity eol) + nil t) (cl-incf warn (string-to-number (match-string 1)))) - (when (re-search-forward "design capacity low: +\\([0-9]+\\) m[AW]h$" + (when (re-search-forward (rx "design capacity low:" (+ space) + battery--acpi-capacity eol) nil t) (cl-incf low (string-to-number (match-string 1))))))) (setq full-capacity (if (> last-full-capacity 0) @@ -383,77 +456,70 @@ The following %-sequences are provided: 60) rate)) hours (/ minutes 60))) - (list (cons ?c (or (and capacity (number-to-string capacity)) "N/A")) + (list (cons ?c (if capacity (number-to-string capacity) "N/A")) (cons ?L (or (battery-search-for-one-match-in-files - (mapcar (lambda (e) (concat e "/state")) - (ignore-errors - (directory-files "/proc/acpi/ac_adapter/" - t "\\`[^.]"))) - "state: +\\(.*\\)$" 1) - + (mapcar (lambda (d) (expand-file-name "state" d)) + (battery--files "/proc/acpi/ac_adapter/")) + (rx "state:" (+ space) (group (not space) (* nonl)) eol) + 1) "N/A")) (cons ?d (or (battery-search-for-one-match-in-files - (mapcar (lambda (e) (concat e "/temperature")) - (ignore-errors - (directory-files "/proc/acpi/thermal_zone/" - t "\\`[^.]"))) - "temperature: +\\([0-9]+\\) C$" 1) - + (mapcar (lambda (d) (expand-file-name "temperature" d)) + (battery--files "/proc/acpi/thermal_zone/")) + (rx "temperature:" (+ space) (group (+ digit)) " C" eol) + 1) "N/A")) - (cons ?r (or (and rate (concat (number-to-string rate) " " - rate-type)) "N/A")) + (cons ?r (if rate + (concat (number-to-string rate) " " rate-type) + "N/A")) (cons ?B (or charging-state "N/A")) - (cons ?b (or (and (string= charging-state "charging") "+") - (and capacity (< capacity low) "!") - (and capacity (< capacity warn) "-") - "")) - (cons ?h (or (and hours (number-to-string hours)) "N/A")) - (cons ?m (or (and minutes (number-to-string minutes)) "N/A")) - (cons ?t (or (and minutes - (format "%d:%02d" hours (- minutes (* 60 hours)))) - "N/A")) - (cons ?p (or (and full-capacity capacity - (> full-capacity 0) - (number-to-string - (floor (* 100 capacity) full-capacity))) - "N/A"))))) + (cons ?b (cond ((string= charging-state "charging") "+") + ((and capacity (< capacity low)) "!") + ((and capacity (< capacity warn)) "-") + (""))) + (cons ?h (if hours (number-to-string hours) "N/A")) + (cons ?m (if minutes (number-to-string minutes) "N/A")) + (cons ?t (if minutes (format "%d:%02d" hours (% minutes 60)) "N/A")) + (cons ?p (if (and full-capacity capacity (> full-capacity 0)) + (number-to-string (floor (* 100 capacity) full-capacity)) + "N/A"))))) ;;; `/sys/class/power_supply/BATN' interface for Linux. (defun battery-linux-sysfs () - "Get ACPI status information from Linux kernel. + "Get sysfs status information from Linux kernel. This function works only with the new `/sys/class/power_supply/' -format introduced in Linux version 2.4.25. +interface introduced in Linux version 2.4.25. The following %-sequences are provided: %c Current capacity (mAh or mWh) -%r Current rate +%r Current rate of charge or discharge +%L Power source (verbose) %B Battery status (verbose) +%b Battery status, empty means high, `-' means low, + `!' means critical, and `+' means charging %d Temperature (in degrees Celsius) %p Battery load percentage -%L AC line status (verbose) %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 (charging-state temperature hours - ;; Some batteries report charges and current, other energy and power. + (let (;; Some batteries report charges and current, others energy and power. ;; In order to reliably be able to combine those data, we convert them ;; all to energy/power (since we can't combine different charges if ;; they're not at the same voltage). (energy-full 0.0) (energy-now 0.0) (power-now 0.0) - (voltage-now 10.8)) ;Arbitrary default, in case the info is missing. + (voltage-now 10.8) ; Arbitrary default, in case the info is missing. + charging-state temperature hours percentage-now) ;; SysFS provides information about each battery present in the ;; system in a separate subdirectory. We are going to merge the ;; available information together. (with-temp-buffer - (dolist (dir (ignore-errors - (battery--find-linux-sysfs-batteries))) - (erase-buffer) - (ignore-errors (insert-file-contents - (expand-file-name "uevent" dir))) + (dolist (dir (battery--find-linux-sysfs-batteries)) + (ignore-errors + (insert-file-contents (expand-file-name "uevent" dir) nil nil nil t)) (goto-char (point-min)) (when (re-search-forward "POWER_SUPPLY_VOLTAGE_NOW=\\([0-9]*\\)$" nil t) @@ -489,7 +555,7 @@ The following %-sequences are provided: voltage-now)) (cl-incf energy-now (* (string-to-number now-string) voltage-now))) - ((and (progn (goto-char (point-min)) t) + ((and (goto-char (point-min)) (re-search-forward "POWER_SUPPLY_ENERGY_FULL=\\([0-9]*\\)$" nil t) (setq full-string (match-string 1)) @@ -498,15 +564,16 @@ The following %-sequences are provided: (setq now-string (match-string 1))) (cl-incf energy-full (string-to-number full-string)) (cl-incf energy-now (string-to-number now-string))))) - (goto-char (point-min)) (unless (zerop power-now) (let ((remaining (if (string= charging-state "Discharging") energy-now (- energy-full energy-now)))) (setq hours (/ remaining power-now))))))) - (list (cons ?c (cond ((or (> energy-full 0) (> energy-now 0)) - (number-to-string (/ energy-now voltage-now))) - (t "N/A"))) + (when (and (> energy-full 0) (> energy-now 0)) + (setq percentage-now (/ (* 100 energy-now) energy-full))) + (list (cons ?c (if (or (> energy-full 0) (> energy-now 0)) + (number-to-string (/ energy-now voltage-now)) + "N/A")) (cons ?r (if (> power-now 0.0) (format "%.1f" (/ power-now 1000000.0)) "N/A")) @@ -517,104 +584,205 @@ The following %-sequences are provided: "N/A")) (cons ?d (or temperature "N/A")) (cons ?B (or charging-state "N/A")) - (cons ?p (cond ((and (> energy-full 0) (> energy-now 0)) - (format "%.1f" - (/ (* 100 energy-now) energy-full))) - (t "N/A"))) - (cons ?L (cond - ((battery-search-for-one-match-in-files - (list "/sys/class/power_supply/AC/online" - "/sys/class/power_supply/ACAD/online" - "/sys/class/power_supply/ADP1/online") - "1" 0) - "AC") - ((battery-search-for-one-match-in-files - (list "/sys/class/power_supply/AC/online" - "/sys/class/power_supply/ACAD/online" - "/sys/class/power_supply/ADP1/online") - "0" 0) - "BAT") - (t "N/A")))))) + (cons ?b (cond ((string= charging-state "Charging") "+") + ((not percentage-now) "") + ((< percentage-now battery-load-critical) "!") + ((< percentage-now battery-load-low) "-") + (""))) + (cons ?p (if percentage-now (format "%.1f" percentage-now) "N/A")) + (cons ?L (pcase (battery-search-for-one-match-in-files + '("/sys/class/power_supply/AC/online" + "/sys/class/power_supply/ACAD/online" + "/sys/class/power_supply/ADP1/online") + (rx (in "01")) 0) + ("0" "BAT") + ("1" "AC") + (_ "N/A")))))) -(declare-function dbus-get-property "dbus.el" - (bus service path interface property)) - -;;; `upowerd' interface. -(defsubst battery-upower-prop (pname &optional device) - (dbus-get-property - :system - "org.freedesktop.UPower" - (concat "/org/freedesktop/UPower/devices/" (or device battery-upower-device)) - "org.freedesktop.UPower" - pname)) +;;; UPower interface. + +(defconst battery-upower-interface "org.freedesktop.UPower" + "Name of the UPower D-Bus interface. +See URL `https://upower.freedesktop.org/docs/UPower.html'.") + +(defconst battery-upower-path "/org/freedesktop/UPower" + "D-Bus object providing `battery-upower-interface'.") + +(defconst battery-upower-device-interface "org.freedesktop.UPower.Device" + "Name of the UPower Device D-Bus interface. +See URL `https://upower.freedesktop.org/docs/Device.html'.") + +(defconst battery-upower-device-path "/org/freedesktop/UPower/devices" + "D-Bus object providing `battery-upower-device-interface'.") + +(defvar battery--upower-signals nil + "Handles for UPower signal subscriptions.") + +(defun battery--upower-signal-handler (&rest _) + "Update battery status on receiving a UPower D-Bus signal." + (timer-event-handler battery-update-timer)) + +(defun battery--upower-props-changed (_interface changed _invalidated) + "Update status when system starts/stops running on battery. +Intended as a UPower PropertiesChanged signal handler." + (when (assoc "OnBattery" changed) + (battery--upower-signal-handler))) + +(defun battery--upower-unsubscribe () + "Unsubscribe from UPower device change signals." + (mapc #'dbus-unregister-object battery--upower-signals) + (setq battery--upower-signals ())) + +(defun battery--upower-subsribe () + "Subscribe to UPower device change signals." + (push (dbus-register-signal :system battery-upower-service + battery-upower-path + dbus-interface-properties + "PropertiesChanged" + #'battery--upower-props-changed) + battery--upower-signals) + (dolist (method '("DeviceAdded" "DeviceRemoved")) + (push (dbus-register-signal :system battery-upower-service + battery-upower-path + battery-upower-interface + method #'battery--upower-signal-handler) + battery--upower-signals))) + +(defun battery--upower-device-properties (device) + "Return value for all available properties for the UPower DEVICE." + (dbus-get-all-properties + :system battery-upower-service + (expand-file-name device battery-upower-device-path) + battery-upower-device-interface)) + +(defun battery--upower-devices () + "List all UPower devices according to `battery-upower-device'." + (cond ((stringp battery-upower-device) + (list battery-upower-device)) + (battery-upower-device) + ((dbus-call-method :system battery-upower-service + battery-upower-path + battery-upower-interface + "EnumerateDevices")))) + +(defun battery--upower-state (props state) + "Merge the UPower battery state in PROPS with STATE. +This is an extension of the UPower DisplayDevice algorithm for +merging multiple battery states into one. PROPS is an alist of +battery properties from `battery-upower-device-interface', and +STATE is a symbol representing the state to merge with." + ;; Map UPower enum into our printable symbols. + (let* ((new (pcase (cdr (assoc "State" props)) + (1 'charging) + (2 'discharging) + (3 'empty) + (4 'fully-charged) + (5 'pending-charge) + (6 'pending-discharge))) + ;; Unknown state represented by nil. + (either (delq nil (list new state)))) + ;; Earlier states override later ones. + (car (cond ((memq 'charging either)) + ((memq 'discharging either)) + ((memq 'pending-charge either)) + ((memq 'pending-discharge either)) + ;; Only options left are full or empty, + ;; but if they conflict return nil. + ((null (cdr either)) either) + ((apply #'eq either) either))))) (defun battery-upower () - "Get battery status from dbus Upower interface. -This function works only in systems with `upowerd' daemon -running. + "Get battery status from UPower D-Bus interface. +This function works only in systems that provide a UPower D-Bus +service. The following %-sequences are provided: %c Current capacity (mWh) -%p Battery load percentage -%r Current rate -%B Battery status (verbose) +%r Current rate of charge or discharge %L AC line status (verbose) +%B Battery status (verbose) +%b Battery status: empty means high, `-' means low, + `!' means critical, and `+' means charging +%d Temperature (in degrees Celsius) +%p Battery load percentage %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")) - (cons ?t (or remaining-time "N/A"))))) + (let ((count 0) props type line-status state load temperature + secs mins hrs total-energy total-rate total-tte total-ttf) + ;; Merge information from all available or specified UPower + ;; devices like other `battery-status-function's. + (dolist (device (battery--upower-devices)) + (setq props (battery--upower-device-properties device)) + (setq type (cdr (assoc "Type" props))) + (cond + ((and (eq type 1) (not (eq line-status 'online))) + ;; It's a line power device: `online' if currently providing + ;; power, any other non-nil value if simply present. + (setq line-status (if (cdr (assoc "Online" props)) 'online t))) + ((and (eq type 2) (cdr (assoc "IsPresent" props))) + ;; It's a battery. + (setq count (1+ count)) + (setq state (battery--upower-state props state)) + (let ((energy (cdr (assoc "Energy" props))) + (rate (cdr (assoc "EnergyRate" props))) + (percent (cdr (assoc "Percentage" props))) + (temp (cdr (assoc "Temperature" props))) + (tte (cdr (assoc "TimeToEmpty" props))) + (ttf (cdr (assoc "TimeToFull" props)))) + (when energy (setq total-energy (+ (or total-energy 0) energy))) + (when rate (setq total-rate (+ (or total-rate 0) rate))) + (when percent (setq load (+ (or load 0) percent))) + (when temp (setq temperature (+ (or temperature 0) temp))) + (when tte (setq total-tte (+ (or total-tte 0) tte))) + (when ttf (setq total-ttf (+ (or total-ttf 0) ttf))))))) + (when (> count 1) + ;; Averages over multiple batteries. + (when load (setq load (/ load count))) + (when temperature (setq temperature (/ temperature count)))) + (when (setq secs (if (eq line-status 'online) total-ttf total-tte)) + (setq mins (/ secs 60)) + (setq hrs (/ secs 3600))) + (list (cons ?c (if total-energy + (format "%.0f" (* total-energy 1000)) + "N/A")) + (cons ?r (if total-rate (format "%.1f W" total-rate) "N/A")) + (cons ?L (cond ((eq line-status 'online) "on-line") + (line-status "off-line") + ("N/A"))) + (cons ?B (format "%s" (or state 'unknown))) + (cons ?b (cond ((eq state 'charging) "+") + ((and load (< load battery-load-critical)) "!") + ((and load (< load battery-load-low)) "-") + (""))) + ;; Zero usually means unknown. + (cons ?d (if (and temperature (/= temperature 0)) + (format "%.0f" temperature) + "N/A")) + (cons ?p (if load (format "%.0f" load) "N/A")) + (cons ?s (if secs (number-to-string secs) "N/A")) + (cons ?m (if mins (number-to-string mins) "N/A")) + (cons ?h (if hrs (number-to-string hrs) "N/A")) + (cons ?t (if hrs (format "%d:%02d" hrs (% mins 60)) "N/A"))))) ;;; `apm' interface for BSD. + (defun battery-bsd-apm () "Get APM status information from BSD apm binary. The following %-sequences are provided: +%P Advanced power saving mode state (verbose) %L AC line status (verbose) %B Battery status (verbose) %b Battery status, empty means high, `-' means low, - `!' means critical, and `+' means charging -%P Advanced power saving mode state (verbose) -%p Battery charge percentage -%s Remaining battery charge time in seconds -%m Remaining battery charge time in minutes -%h Remaining battery charge time in hours -%t Remaining battery charge time in the form `h:min'" + `!' means critical, and `+' means charging +%p Battery load percentage +%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* ((os-name (car (split-string ;; FIXME: Can't we use something like `system-type'? (shell-command-to-string "/usr/bin/uname")))) @@ -680,7 +848,7 @@ The following %-sequences are provided: (setq seconds (string-to-number battery-life) minutes (truncate seconds 60))) (setq hours (truncate minutes 60) - remaining-time (format "%d:%02d" hours (mod minutes 60)))) + remaining-time (format "%d:%02d" hours (% minutes 60)))) (list (cons ?L (or line-status "N/A")) (cons ?B (or (car battery-status) "N/A")) (cons ?b (or (cdr battery-status) "N/A")) @@ -688,9 +856,9 @@ The following %-sequences are provided: "N/A" battery-percentage)) (cons ?P (or apm-mode "N/A")) - (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")) + (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"))))) @@ -705,21 +873,25 @@ The following %-sequences are provided: %b Battery status, empty means high, `-' means low, `!' means critical, and `+' means charging %p Battery load percentage -%h Remaining time in hours -%m Remaining time in minutes -%t Remaining time in the form `h:min'" - (let (power-source load-percentage battery-status battery-status-symbol - remaining-time hours minutes) +%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 ( power-source load-percentage battery-status battery-status-symbol + remaining-time hours minutes ) (with-temp-buffer (ignore-errors (call-process "pmset" nil t nil "-g" "ps")) (goto-char (point-min)) - (when (re-search-forward "\\(?:Currentl?y\\|Now\\) drawing from '\\(AC\\|Battery\\) Power'" nil t) + (when (re-search-forward ;; Handle old typo in output. + "\\(?:Currentl?y\\|Now\\) drawing from '\\(AC\\|Battery\\) Power'" + nil t) (setq power-source (match-string 1)) - (when (re-search-forward "^ -InternalBattery-0\\([ \t]+(id=[0-9]+)\\)*[ \t]+" nil t) + (when (re-search-forward (rx bol " -InternalBattery-0" (+ space) + (* "(id=" (+ digit) ")" (+ space))) + nil t) (when (looking-at "\\([0-9]\\{1,3\\}\\)%") (setq load-percentage (match-string 1)) (goto-char (match-end 0)) - (cond ((looking-at "; charging") + (cond ((looking-at-p "; charging") (setq battery-status "charging" battery-status-symbol "+")) ((< (string-to-number load-percentage) battery-load-critical) @@ -750,13 +922,7 @@ The following %-sequences are provided: (defun battery-format (format alist) "Substitute %-sequences in FORMAT." - (replace-regexp-in-string - "%." - (lambda (str) - (let ((char (aref str 1))) - (if (eq char ?%) "%" - (or (cdr (assoc char alist)) "")))) - format t t)) + (format-spec format alist 'delete)) (defun battery-search-for-one-match-in-files (files regexp match-num) "Search REGEXP in the content of the files listed in FILES. diff --git a/lisp/bookmark.el b/lisp/bookmark.el index e69d9f529cf..36a361c3f4b 100644 --- a/lisp/bookmark.el +++ b/lisp/bookmark.el @@ -200,6 +200,7 @@ A non-nil value may result in truncated bookmark names." (define-key map "f" 'bookmark-insert-location) ;"f"ind (define-key map "r" 'bookmark-rename) (define-key map "d" 'bookmark-delete) + (define-key map "D" 'bookmark-delete-all) (define-key map "l" 'bookmark-load) (define-key map "w" 'bookmark-write) (define-key map "s" 'bookmark-save) @@ -734,8 +735,10 @@ CODING is the symbol of the coding-system in which the file is encoded." (if (memq (coding-system-base coding) '(undecided prefer-utf-8)) (setq coding 'utf-8-emacs)) (insert - (format ";;;; Emacs Bookmark Format Version %d ;;;; -*- coding: %S -*-\n" - bookmark-file-format-version (coding-system-base coding))) + (format + ";;;; Emacs Bookmark Format Version %d\ +;;;; -*- coding: %S; mode: lisp-data -*-\n" + bookmark-file-format-version (coding-system-base coding))) (insert ";;; This format is meant to be slightly human-readable;\n" ";;; nevertheless, you probably don't want to edit it.\n" ";;; " @@ -1372,6 +1375,23 @@ probably because we were called from there." (bookmark-save))) +;;;###autoload +(defun bookmark-delete-all (&optional no-confirm) + "Permanently delete all bookmarks. +If optional argument NO-CONFIRM is non-nil, don't ask for +confirmation." + (interactive "P") + (when (or no-confirm + (yes-or-no-p "Permanently delete all bookmarks? ")) + (bookmark-maybe-load-default-file) + (setq bookmark-alist-modification-count + (+ bookmark-alist-modification-count (length bookmark-alist))) + (setq bookmark-alist nil) + (bookmark-bmenu-surreptitiously-rebuild-list) + (when (bookmark-time-to-save-p) + (bookmark-save)))) + + (defun bookmark-time-to-save-p (&optional final-time) "Return t if it is time to save bookmarks to disk, nil otherwise. Optional argument FINAL-TIME means this is being called when Emacs @@ -1598,12 +1618,15 @@ unique numeric suffixes \"<2>\", \"<3>\", etc." (define-key map "\C-d" 'bookmark-bmenu-delete-backwards) (define-key map "x" 'bookmark-bmenu-execute-deletions) (define-key map "d" 'bookmark-bmenu-delete) + (define-key map "D" 'bookmark-bmenu-delete-all) (define-key map " " 'next-line) (define-key map "n" 'next-line) (define-key map "p" 'previous-line) (define-key map "\177" 'bookmark-bmenu-backup-unmark) (define-key map "u" 'bookmark-bmenu-unmark) + (define-key map "U" 'bookmark-bmenu-unmark-all) (define-key map "m" 'bookmark-bmenu-mark) + (define-key map "M" 'bookmark-bmenu-mark-all) (define-key map "l" 'bookmark-bmenu-load) (define-key map "r" 'bookmark-bmenu-rename) (define-key map "R" 'bookmark-bmenu-relocate) @@ -1625,8 +1648,10 @@ unique numeric suffixes \"<2>\", \"<3>\", etc." ["Select Marked Bookmarks" bookmark-bmenu-select t] "---" ["Mark Bookmark" bookmark-bmenu-mark t] + ["Mark all Bookmarks" bookmark-bmenu-mark-all t] ["Unmark Bookmark" bookmark-bmenu-unmark t] ["Unmark Backwards" bookmark-bmenu-backup-unmark t] + ["Unmark all Bookmarks" bookmark-bmenu-unmark-all t] ["Toggle Display of Filenames" bookmark-bmenu-toggle-filenames t] ["Display Location of Bookmark" bookmark-bmenu-locate t] "---" @@ -1634,6 +1659,7 @@ unique numeric suffixes \"<2>\", \"<3>\", etc." ["Rename Bookmark" bookmark-bmenu-rename t] ["Relocate Bookmark's File" bookmark-bmenu-relocate t] ["Mark Bookmark for Deletion" bookmark-bmenu-delete t] + ["Mark all Bookmarks for Deletion" bookmark-bmenu-delete-all t] ["Delete Marked Bookmarks" bookmark-bmenu-execute-deletions t]) ("Annotations" ["Show Annotation for Current Bookmark" bookmark-bmenu-show-annotation t] @@ -1665,6 +1691,19 @@ Don't affect the buffer ring order." ;;;###autoload +(defun bookmark-bmenu-get-buffer () + "Return the Bookmark List, building it if it doesn't exists. +Don't affect the buffer ring order." + (or (get-buffer bookmark-bmenu-buffer) + (save-excursion + (save-window-excursion + (bookmark-bmenu-list) + (get-buffer bookmark-bmenu-buffer))))) + +(custom-add-choice 'tab-bar-new-tab-choice + '(const :tag "Bookmark List" bookmark-bmenu-get-buffer)) + +;;;###autoload (defun bookmark-bmenu-list () "Display a list of existing bookmarks. The list is displayed in a buffer named `*Bookmark List*'. @@ -1721,7 +1760,7 @@ deletion, or > if it is flagged for displaying." ;; according to `bookmark-bookmarks-timestamp'. (defun bookmark-bmenu-set-header () "Set the immutable header line." - (let ((header (concat "%% " "Bookmark"))) + (let ((header (copy-sequence "%% Bookmark"))) (when bookmark-bmenu-toggle-filenames (setq header (concat header (make-string (- bookmark-bmenu-file-column @@ -1746,6 +1785,7 @@ Letters do not insert themselves; instead, they are commands. Bookmark names preceded by a \"*\" have annotations. \\<bookmark-bmenu-mode-map> \\[bookmark-bmenu-mark] -- mark bookmark to be displayed. +\\[bookmark-bmenu-mark-all] -- mark all listed bookmarks to be displayed. \\[bookmark-bmenu-select] -- select bookmark of line point is on. Also show bookmarks marked using m in other windows. \\[bookmark-bmenu-toggle-filenames] -- toggle displaying of filenames (they may obscure long bookmark names). @@ -1762,13 +1802,15 @@ Bookmark names preceded by a \"*\" have annotations. \\[bookmark-bmenu-relocate] -- relocate this bookmark's file (prompts for new file). \\[bookmark-bmenu-delete] -- mark this bookmark to be deleted, and move down. \\[bookmark-bmenu-delete-backwards] -- mark this bookmark to be deleted, and move up. -\\[bookmark-bmenu-execute-deletions] -- delete bookmarks marked with `\\[bookmark-bmenu-delete]'. +\\[bookmark-bmenu-delete-all] -- mark all listed bookmarks as to be deleted. +\\[bookmark-bmenu-execute-deletions] -- delete bookmarks marked with `\\[bookmark-bmenu-delete]' or `\\[bookmark-bmenu-delete-all]'. \\[bookmark-bmenu-save] -- save the current bookmark list in the default file. With a prefix arg, prompts for a file to save in. \\[bookmark-bmenu-load] -- load in a file of bookmarks (prompts for file.) \\[bookmark-bmenu-unmark] -- remove all kinds of marks from current line. With prefix argument, also move up one line. \\[bookmark-bmenu-backup-unmark] -- back up a line and remove marks. +\\[bookmark-bmenu-unmark-all] -- remove all kinds of marks from all listed bookmarks. \\[bookmark-bmenu-show-annotation] -- show the annotation, if it exists, for the current bookmark in another buffer. \\[bookmark-bmenu-show-all-annotations] -- show the annotations of all bookmarks in another buffer. @@ -1935,9 +1977,23 @@ If the annotation does not exist, do nothing." (bookmark-bmenu-ensure-position)))) +(defun bookmark-bmenu-mark-all () + "Mark all listed bookmarks to be displayed by \\<bookmark-bmenu-mode-map>\\[bookmark-bmenu-select]." + (interactive) + (save-excursion + (goto-char (point-min)) + (bookmark-bmenu-ensure-position) + (with-buffer-modified-unmodified + (let ((inhibit-read-only t)) + (while (not (eobp)) + (delete-char 1) + (insert ?>) + (forward-line 1)))))) + + (defun bookmark-bmenu-select () "Select this line's bookmark; also display bookmarks marked with `>'. -You can mark bookmarks with the \\<bookmark-bmenu-mode-map>\\[bookmark-bmenu-mark] command." +You can mark bookmarks with the \\<bookmark-bmenu-mode-map>\\[bookmark-bmenu-mark] or \\<bookmark-bmenu-mode-map>\\[bookmark-bmenu-mark-all] commands." (interactive) (let ((bmrk (bookmark-bmenu-bookmark)) (menu (current-buffer)) @@ -2106,6 +2162,20 @@ Optional BACKUP means move up." (bookmark-bmenu-ensure-position)) +(defun bookmark-bmenu-unmark-all () + "Cancel all requested operations on all listed bookmarks." + (interactive) + (save-excursion + (goto-char (point-min)) + (bookmark-bmenu-ensure-position) + (with-buffer-modified-unmodified + (let ((inhibit-read-only t)) + (while (not (eobp)) + (delete-char 1) + (insert " ") + (forward-line 1)))))) + + (defun bookmark-bmenu-delete () "Mark bookmark on this line to be deleted. To carry out the deletions that you've marked, use \\<bookmark-bmenu-mode-map>\\[bookmark-bmenu-execute-deletions]." @@ -2131,6 +2201,22 @@ To carry out the deletions that you've marked, use \\<bookmark-bmenu-mode-map>\\ (bookmark-bmenu-ensure-position)) +(defun bookmark-bmenu-delete-all () + "Mark all listed bookmarks as to be deleted. +To remove all deletion marks, use \\<bookmark-bmenu-mode-map>\\[bookmark-bmenu-unmark-all]. +To carry out the deletions that you've marked, use \\<bookmark-bmenu-mode-map>\\[bookmark-bmenu-execute-deletions]." + (interactive) + (save-excursion + (goto-char (point-min)) + (bookmark-bmenu-ensure-position) + (with-buffer-modified-unmodified + (let ((inhibit-read-only t)) + (while (not (eobp)) + (delete-char 1) + (insert ?D) + (forward-line 1)))))) + + (defun bookmark-bmenu-execute-deletions () "Delete bookmarks flagged `D'." (interactive) @@ -2290,6 +2376,9 @@ strings returned are not." (bindings--define-key map [delete] '(menu-item "Delete Bookmark..." bookmark-delete :help "Delete a bookmark from the bookmark list")) + (bindings--define-key map [delete-all] + '(menu-item "Delete all Bookmarks..." bookmark-delete-all + :help "Delete all bookmarks from the bookmark list")) (bindings--define-key map [rename] '(menu-item "Rename Bookmark..." bookmark-rename :help "Change the name of a bookmark")) @@ -2322,6 +2411,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/bs.el b/lisp/bs.el index f5cb93b5169..337d22ecf83 100644 --- a/lisp/bs.el +++ b/lisp/bs.el @@ -173,7 +173,12 @@ return a string representing the column's value." (defun bs--make-header-match-string () "Return a regexp matching the first line of a Buffer Selection Menu buffer." - (concat "^\\(" (mapconcat #'car bs-attributes-list " *") " *$\\)")) + (concat "^\\(" + (apply #'concat (mapcan (lambda (e) + (and (not (equal (car e) "")) + (list " *" (car e)))) + bs-attributes-list)) + " *$\\)")) ;; Font-Lock-Settings (defvar bs-mode-font-lock-keywords diff --git a/lisp/buff-menu.el b/lisp/buff-menu.el index 655a76a713c..aa5c47ca7f4 100644 --- a/lisp/buff-menu.el +++ b/lisp/buff-menu.el @@ -69,11 +69,26 @@ minus `Buffer-menu-size-width'. This use is deprecated." "use `Buffer-menu-name-width' and `Buffer-menu-size-width' instead." "24.3") -(defcustom Buffer-menu-name-width 19 - "Width of buffer name column in the Buffer Menu." - :type 'number +(defun Buffer-menu--dynamic-name-width (buffers) + "Return a name column width based on the current window width. +The width will never exceed the actual width of the buffer names, +but will never be narrower than 19 characters." + (max 19 + ;; This gives 19 on an 80 column window, and take up + ;; proportionally more space as the window widens. + (min (truncate (/ (window-width) 4.2)) + (apply #'max 0 (mapcar (lambda (b) + (length (buffer-name b))) + buffers))))) + +(defcustom Buffer-menu-name-width #'Buffer-menu--dynamic-name-width + "Width of buffer name column in the Buffer Menu. +This can either be a number (used directly) or a function that +will be called with the list of buffers and should return a +number." + :type '(choice function number) :group 'Buffer-menu - :version "24.3") + :version "28.1") (defcustom Buffer-menu-size-width 7 "Width of buffer size column in the Buffer Menu." @@ -488,8 +503,9 @@ Buffers marked with \\<Buffer-menu-mode-map>`\\[Buffer-menu-delete]' are deleted (defun Buffer-menu-select () "Select this line's buffer; also, display buffers marked with `>'. You can mark buffers with the \\<Buffer-menu-mode-map>`\\[Buffer-menu-mark]' command. + This command deletes and replaces all the previously existing windows -in the selected frame." +in the selected frame, and will remove any marks." (interactive) (let* ((this-buffer (Buffer-menu-buffer t)) (menu-buffer (current-buffer)) @@ -645,25 +661,11 @@ means list those buffers and no others." (defun list-buffers--refresh (&optional buffer-list old-buffer) ;; Set up `tabulated-list-format'. - (let ((name-width Buffer-menu-name-width) - (size-width Buffer-menu-size-width) + (let ((size-width Buffer-menu-size-width) (marked-buffers (Buffer-menu-marked-buffers)) (buffer-menu-buffer (current-buffer)) (show-non-file (not Buffer-menu-files-only)) - entries) - ;; Handle obsolete variable: - (if Buffer-menu-buffer+size-width - (setq name-width (- Buffer-menu-buffer+size-width size-width))) - (setq tabulated-list-format - (vector '("C" 1 t :pad-right 0) - '("R" 1 t :pad-right 0) - '("M" 1 t) - `("Buffer" ,name-width t) - `("Size" ,size-width tabulated-list-entry-size-> - :right-align t) - `("Mode" ,Buffer-menu-mode-width t) - '("File" 1 t))) - (setq tabulated-list-use-header-line Buffer-menu-use-header-line) + entries name-width) ;; Collect info for each buffer we're interested in. (dolist (buffer (or buffer-list (buffer-list (if Buffer-menu-use-frame-buffer-list @@ -693,6 +695,22 @@ means list those buffers and no others." nil nil buffer))) (Buffer-menu--pretty-file-name file))) entries))))) + (setq name-width (if (functionp Buffer-menu-name-width) + (funcall Buffer-menu-name-width (mapcar #'car entries)) + Buffer-menu-name-width)) + ;; Handle obsolete variable: + (if Buffer-menu-buffer+size-width + (setq name-width (- Buffer-menu-buffer+size-width size-width))) + (setq tabulated-list-format + (vector '("C" 1 t :pad-right 0) + '("R" 1 t :pad-right 0) + '("M" 1 t) + `("Buffer" ,name-width t) + `("Size" ,size-width tabulated-list-entry-size-> + :right-align t) + `("Mode" ,Buffer-menu-mode-width t) + '("File" 1 t))) + (setq tabulated-list-use-header-line Buffer-menu-use-header-line) (setq tabulated-list-entries (nreverse entries))) (tabulated-list-init-header)) diff --git a/lisp/button.el b/lisp/button.el index b3afc4eca25..03ab59b109c 100644 --- a/lisp/button.el +++ b/lisp/button.el @@ -341,15 +341,14 @@ If the property `button-data' is present, it will later be used as the argument for the `action' callback function instead of the default argument, which is the button itself. -BEG can also be a string, in which case it is made into a button. +BEG can also be a string, in which case a copy of it is made into +a button and returned. Also see `insert-text-button'." (let ((object nil) (type-entry (or (plist-member properties 'type) (plist-member properties :type)))) - (when (stringp beg) - (setq object beg beg 0 end (length object))) ;; Disallow setting the `category' property directly. (when (plist-get properties 'category) (error "Button `category' property may not be set directly")) @@ -362,6 +361,10 @@ Also see `insert-text-button'." (setcar type-entry 'category) (setcar (cdr type-entry) (button-category-symbol (cadr type-entry)))) + (when (stringp beg) + (setq object (copy-sequence beg)) + (setq beg 0) + (setq end (length object))) ;; Now add all the text properties at once. (add-text-properties beg end ;; Each button should have a non-eq `button' @@ -461,18 +464,24 @@ see). POS defaults to point, except when `push-button' is invoked interactively as the result of a mouse-event, in which case, the mouse event is used. + If there's no button at POS, do nothing and return nil, otherwise -return t." +return t. + +To get a description of what function will called when pushing a +butting, use the `button-describe' command." (interactive (list (if (integerp last-command-event) (point) last-command-event))) (if (and (not (integerp pos)) (eventp pos)) ;; POS is a mouse event; switch to the proper window/buffer (let ((posn (event-start pos))) (with-current-buffer (window-buffer (posn-window posn)) - (if (posn-string posn) - ;; mode-line, header-line, or display string event. - (button-activate (posn-string posn) t) - (push-button (posn-point posn) t)))) + (let* ((str (posn-string posn)) + (str-button (and str (get-text-property (cdr str) 'button (car str))))) + (if str-button + ;; mode-line, header-line, or display string event. + (button-activate str t) + (push-button (posn-point posn) t))))) ;; POS is just normal position (let ((button (button-at (or pos (point))))) (when button @@ -550,6 +559,51 @@ Returns the button found." (interactive "p\nd\nd") (forward-button (- n) wrap display-message no-error)) +(defun button--describe (properties) + "Describe a button's PROPERTIES (an alist) in a *Help* buffer. +This is a helper function for `button-describe', in order to be possible to +use `help-setup-xref'. + +Each element of PROPERTIES should be of the form (PROPERTY . VALUE)." + (help-setup-xref (list #'button--describe properties) + (called-interactively-p 'interactive)) + (with-help-window (help-buffer) + (with-current-buffer (help-buffer) + (insert (format-message "This button's type is `%s'." + (alist-get 'type properties))) + (dolist (prop '(action mouse-action)) + (let ((name (symbol-name prop)) + (val (alist-get prop properties))) + (when (functionp val) + (insert "\n\n" + (propertize (capitalize name) 'face 'bold) + "\nThe " name " of this button is") + (if (symbolp val) + (progn + (insert (format-message " `%s',\nwhich is " val)) + (describe-function-1 val)) + (insert "\n") + (princ val)))))))) + +(defun button-describe (&optional button-or-pos) + "Display a buffer with information about the button at point. + +When called from Lisp, pass BUTTON-OR-POS as the button to describe, or a +buffer position where a button is present. If BUTTON-OR-POS is nil, the +button at point is the button to describe." + (interactive "d") + (let* ((button (cond ((integer-or-marker-p button-or-pos) + (button-at button-or-pos)) + ((null button-or-pos) (button-at (point))) + ((overlayp button-or-pos) button-or-pos))) + (props (and button + (mapcar (lambda (prop) + (cons prop (button-get button prop))) + '(type action mouse-action))))) + (when props + (button--describe props) + t))) + (provide 'button) ;;; button.el ends here diff --git a/lisp/calc/calc-comb.el b/lisp/calc/calc-comb.el index d4562a0cc86..c5d4d0837e7 100644 --- a/lisp/calc/calc-comb.el +++ b/lisp/calc/calc-comb.el @@ -241,8 +241,8 @@ (calcFunc-gcd (math-neg a) b)) ((Math-looks-negp b) (calcFunc-gcd a (math-neg b))) - ((Math-zerop a) b) - ((Math-zerop b) a) + ((Math-zerop a) (math-abs b)) + ((Math-zerop b) (math-abs a)) ((and (Math-ratp a) (Math-ratp b)) (math-make-frac (math-gcd (if (eq (car-safe a) 'frac) (nth 1 a) a) diff --git a/lisp/calc/calc-mtx.el b/lisp/calc/calc-mtx.el index fe241b57c60..2850b33721b 100644 --- a/lisp/calc/calc-mtx.el +++ b/lisp/calc/calc-mtx.el @@ -275,7 +275,7 @@ in LUD decomposition." k (1+ k))) (setcar (nthcdr j (nth i lu)) sum) (let ((dum (math-lud-pivot-check sum))) - (if (Math-lessp big dum) + (if (or (math-zerop big) (Math-lessp big dum)) (setq big dum imax i))) (setq i (1+ i))) diff --git a/lisp/calc/calc-yank.el b/lisp/calc/calc-yank.el index f5150ca552c..690aaf2687f 100644 --- a/lisp/calc/calc-yank.el +++ b/lisp/calc/calc-yank.el @@ -150,34 +150,16 @@ ;; otherwise it just parses the yanked string. ;; Modified to use Emacs 19 extended concept of kill-ring. -- daveg 12/15/96 ;;;###autoload -(defun calc-yank (radix) - "Yank a value into the Calculator buffer. - -Valid numeric prefixes for RADIX: 0, 2, 6, 8 -No radix notation is prepended for any other numeric prefix. - -If RADIX is 2, prepend \"2#\" - Binary. -If RADIX is 8, prepend \"8#\" - Octal. -If RADIX is 0, prepend \"10#\" - Decimal. -If RADIX is 6, prepend \"16#\" - Hexadecimal. +(defun calc-yank-internal (radix thing-raw) + "Internal common implementation for yank functions. -If RADIX is a non-nil list (created using \\[universal-argument]), the user -will be prompted to enter the radix in the minibuffer. - -If RADIX is nil or if the yanked string already has a calc radix prefix, the -yanked string will be passed on directly to the Calculator buffer without any -alteration." - (interactive "P") +This function is used by both `calc-yank' and `calc-yank-mouse-primary'." (calc-wrapper (calc-pop-push-record-list 0 "yank" (let* (radix-num radix-notation valid-num-regexp - (thing-raw - (if (fboundp 'current-kill) - (current-kill 0 t) - (car kill-ring-yank-pointer))) (thing (if (or (null radix) ;; Match examples: -2#10, 10\n(10#10,01) @@ -232,6 +214,38 @@ alteration." val)) val)))))))) +;;;###autoload +(defun calc-yank-mouse-primary (radix) + "Yank the current primary selection into the Calculator buffer. +See `calc-yank' for details about RADIX." + (interactive "P") + (if (or select-enable-primary + select-enable-clipboard) + (calc-yank-internal radix (gui-get-primary-selection)) + ;; Yank from the kill ring. + (calc-yank radix))) + +;;;###autoload +(defun calc-yank (radix) + "Yank a value into the Calculator buffer. + +Valid numeric prefixes for RADIX: 0, 2, 6, 8 +No radix notation is prepended for any other numeric prefix. + +If RADIX is 2, prepend \"2#\" - Binary. +If RADIX is 8, prepend \"8#\" - Octal. +If RADIX is 0, prepend \"10#\" - Decimal. +If RADIX is 6, prepend \"16#\" - Hexadecimal. + +If RADIX is a non-nil list (created using \\[universal-argument]), the user +will be prompted to enter the radix in the minibuffer. + +If RADIX is nil or if the yanked string already has a calc radix prefix, the +yanked string will be passed on directly to the Calculator buffer without any +alteration." + (interactive "P") + (calc-yank-internal radix (current-kill 0 t))) + ;;; The Calc set- and get-register commands are modified versions of functions ;;; in register.el diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el index 648cb7bb807..fb1287baaa6 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.") @@ -1085,8 +1087,26 @@ Used by `calc-user-invocation'.") (append (where-is-internal 'delete-backward-char global-map) (where-is-internal 'backward-delete-char global-map) (where-is-internal 'backward-delete-char-untabify global-map) - '("\C-d")) - '("\177" "\C-d"))) + '("\177")) + '("\177"))) + +(mapc (lambda (x) + (ignore-errors + (define-key calc-digit-map x 'calcDigit-delchar) + (define-key calc-mode-map x 'calc-pop) + (define-key calc-mode-map + (if (and (vectorp x) (featurep 'xemacs)) + (if (= (length x) 1) + (vector (if (consp (aref x 0)) + (cons 'meta (aref x 0)) + (list 'meta (aref x 0)))) + "\e\C-d") + (vconcat "\e" x)) + 'calc-pop-above))) + (if calc-scan-for-dels + (append (where-is-internal 'delete-forward-char global-map) + '("\C-d")) + '("\C-d"))) (defvar calc-dispatch-map (let ((map (make-keymap))) @@ -2341,7 +2361,6 @@ the United States." (defun calcDigit-key () (interactive) - (goto-char (point-max)) (if (or (and (memq last-command-event '(?+ ?-)) (> (buffer-size) 0) (/= (preceding-char) ?e)) @@ -2384,8 +2403,7 @@ the United States." (delete-char 1)) (if (looking-at "-") (delete-char 1) - (insert "-"))) - (goto-char (point-max))) + (insert "-")))) ((eq last-command-event ?p) (if (or (calc-minibuffer-contains ".*\\+/-.*") (calc-minibuffer-contains ".*mod.*") @@ -2427,7 +2445,7 @@ the United States." (if (and (memq last-command-event '(?@ ?o ?h ?\' ?m)) (string-match " " calc-hms-format)) (insert " ")) - (if (and (eq this-command last-command) + (if (and (memq last-command '(calcDigit-start calcDigit-key)) (eq last-command-event ?.)) (progn (require 'calc-ext) @@ -2438,17 +2456,9 @@ the United States." (setq calc-prev-prev-char calc-prev-char calc-prev-char last-command-event)) - (defun calcDigit-backspace () (interactive) - (goto-char (point-max)) - (cond ((calc-minibuffer-contains ".* \\+/- \\'") - (backward-delete-char 5)) - ((calc-minibuffer-contains ".* mod \\'") - (backward-delete-char 5)) - ((calc-minibuffer-contains ".* \\'") - (backward-delete-char 2)) - ((eq last-command 'calcDigit-start) + (cond ((eq last-command 'calcDigit-start) (erase-buffer)) (t (backward-delete-char 1))) (if (= (calc-minibuffer-size) 0) @@ -2923,6 +2933,20 @@ the United States." (- (- (nth 2 a) (nth 2 b)) ldiff)))) +(defun calcDigit-delchar () + (interactive) + (cond ((looking-at-p " \\+/- \\'") + (delete-char 5)) + ((looking-at-p " mod \\'") + (delete-char 5)) + ((looking-at-p " \\'") + (delete-char 2)) + ((eq last-command 'calcDigit-start) + (erase-buffer)) + (t (unless (eobp) (delete-char 1)))) + (when (= (calc-minibuffer-size) 0) + (setq last-command-event 13) + (calcDigit-nondigit))) (defvar math-comp-selected) diff --git a/lisp/calculator.el b/lisp/calculator.el index 6996990814d..cd92f992689 100644 --- a/lisp/calculator.el +++ b/lisp/calculator.el @@ -858,13 +858,11 @@ The result should not exceed the screen width." "Convert the given STR to a number, according to the value of `calculator-input-radix'." (if calculator-input-radix - (string-to-number str (cadr (assq calculator-input-radix - '((bin 2) (oct 8) (hex 16))))) - (let* ((str (replace-regexp-in-string - "\\.\\([^0-9].*\\)?$" ".0\\1" str)) - (str (replace-regexp-in-string - "[eE][+-]?\\([^0-9].*\\)?$" "e0\\1" str))) - (string-to-number str)))) + (string-to-number str (cadr (assq calculator-input-radix + '((bin 2) (oct 8) (hex 16))))) + ;; Allow entry of "1.e3". + (let ((str (replace-regexp-in-string (rx "." (any "eE")) "e" str))) + (float (string-to-number str))))) (defun calculator-push-curnum () "Push the numeric value of the displayed number to the stack." diff --git a/lisp/calendar/cal-bahai.el b/lisp/calendar/cal-bahai.el index b6bb040dd54..4bfdf3a6cf6 100644 --- a/lisp/calendar/cal-bahai.el +++ b/lisp/calendar/cal-bahai.el @@ -57,8 +57,8 @@ (defconst calendar-bahai-month-name-array ["Bahá" "Jalál" "Jamál" "‘Aẓamat" "Núr" "Raḥmat" "Kalimát" "Kamál" - "Asmá’" "‘Izzat" "MashÃyyat" "‘Ilm" "Qudrat" "Qawl" "Masá’il" - "Sharaf" "Sulá¹Ã¡n" "Mulk" "‘Alá’"] + "Asmá’" "‘Izzat" "MasÍŸhÃyyat" "‘Ilm" "Qudrat" "Qawl" "Masá’il" + "SÍŸharaf" "Sulá¹Ã¡n" "Mulk" "‘Alá’"] "Array of the month names in the Bahá’à calendar.") (defconst calendar-bahai-epoch (calendar-absolute-from-gregorian '(3 21 1844)) diff --git a/lisp/calendar/cal-dst.el b/lisp/calendar/cal-dst.el index 3db12e668ab..05768e10c01 100644 --- a/lisp/calendar/cal-dst.el +++ b/lisp/calendar/cal-dst.el @@ -350,17 +350,31 @@ If the locale never uses daylight saving time, set this to 0." :group 'calendar-dst) (defcustom calendar-standard-time-zone-name - (or (nth 2 calendar-current-time-zone-cache) "EST") + (if (eq calendar-time-zone-style 'numeric) + (if calendar-current-time-zone-cache + (format-time-string + "%z" 0 (* 60 (car calendar-current-time-zone-cache))) + "+0000") + (or (nth 2 calendar-current-time-zone-cache) "EST")) "Abbreviated name of standard time zone at `calendar-location-name'. For example, \"EST\" in New York City, \"PST\" for Los Angeles." :type 'string + :version "28.1" + :set-after '(calendar-time-zone-style) :group 'calendar-dst) (defcustom calendar-daylight-time-zone-name - (or (nth 3 calendar-current-time-zone-cache) "EDT") + (if (eq calendar-time-zone-style 'numeric) + (if calendar-current-time-zone-cache + (format-time-string + "%z" 0 (* 60 (cadr calendar-current-time-zone-cache))) + "+0000") + (or (nth 3 calendar-current-time-zone-cache) "EDT")) "Abbreviated name of daylight saving time zone at `calendar-location-name'. For example, \"EDT\" in New York City, \"PDT\" for Los Angeles." :type 'string + :version "28.1" + :set-after '(calendar-time-zone-style) :group 'calendar-dst) (defcustom calendar-daylight-savings-starts-time diff --git a/lisp/calendar/cal-julian.el b/lisp/calendar/cal-julian.el index 1c741317803..918995d0f9b 100644 --- a/lisp/calendar/cal-julian.el +++ b/lisp/calendar/cal-julian.el @@ -1,4 +1,4 @@ -;;; cal-julian.el --- calendar functions for the Julian calendar +;;; cal-julian.el --- calendar functions for the Julian calendar -*- lexical-binding:t -*- ;; Copyright (C) 1995, 1997, 2001-2020 Free Software Foundation, Inc. @@ -182,23 +182,27 @@ Echo astronomical (Julian) day number unless NOECHO is non-nil." (calendar-astro-to-absolute daynumber)))) (or noecho (calendar-astro-print-day-number))) - -;; The function below is designed to be used in sexp diary entries, -;; and may be present in users' diary files, so suppress the warning -;; about this prefix-less dynamic variable. It's called from -;; `diary-list-sexp-entries', which binds the variable. -(with-suppressed-warnings ((lexical date)) - (defvar date)) - ;;;###diary-autoload (defun diary-julian-date () "Julian calendar equivalent of date diary entry." + ;; This function is designed to be used in sexp diary entries, and + ;; may be present in users' diary files, so suppress the warning + ;; about this prefix-less dynamic variable. It's called from + ;; `diary-list-sexp-entries', which binds the variable. + (with-suppressed-warnings ((lexical date)) + (defvar date)) (format "Julian date: %s" (calendar-julian-date-string date))) ;; To be called from diary-list-sexp-entries, where DATE is bound. ;;;###diary-autoload (defun diary-astro-day-number () "Astronomical (Julian) day number diary entry." + ;; This function is designed to be used in sexp diary entries, and + ;; may be present in users' diary files, so suppress the warning + ;; about this prefix-less dynamic variable. It's called from + ;; `diary-list-sexp-entries', which binds the variable. + (with-suppressed-warnings ((lexical date)) + (defvar date)) (format "Astronomical (Julian) day number at noon UTC: %s.0" (calendar-astro-date-string date))) diff --git a/lisp/calendar/calendar.el b/lisp/calendar/calendar.el index 1ae39445680..574261456fc 100644 --- a/lisp/calendar/calendar.el +++ b/lisp/calendar/calendar.el @@ -136,14 +136,13 @@ ;; - whatever is passed to diary-remind (defmacro calendar-dlet* (binders &rest body) - "Like `let*' but using dynamic scoping." + "Like `dlet' but without warnings about non-prefixed var names." (declare (indent 1) (debug let)) - `(progn - (with-no-warnings ;Silence "lacks a prefix" warnings! - ,@(mapcar (lambda (binder) - `(defvar ,(if (consp binder) (car binder) binder))) - binders)) - (let* ,binders ,@body))) + (let ((vars (mapcar (lambda (binder) + (if (consp binder) (car binder) binder)) + binders))) + `(with-suppressed-warnings ((lexical ,@vars)) + (dlet ,binders ,@body)))) ;; Avoid recursive load of calendar when loading cal-menu. Yuck. (provide 'calendar) @@ -1062,6 +1061,15 @@ calendar." :type 'boolean :group 'holidays) +;; fixme should have a :set that changes calendar-standard-time-zone-name etc. +(defcustom calendar-time-zone-style 'symbolic + "Your preferred style for time zones. +If 'numeric, use numeric time zones like \"+0100\". +Otherwise, use symbolic time zones like \"CET\"." + :type '(choice (const numeric) (other symbolic)) + :version "28.1" + :group 'calendar) + ;;; End of user options. (calendar-recompute-layout-variables) 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/icalendar.el b/lisp/calendar/icalendar.el index 6847ba97496..d76c1105031 100644 --- a/lisp/calendar/icalendar.el +++ b/lisp/calendar/icalendar.el @@ -6,7 +6,7 @@ ;; Created: August 2002 ;; Keywords: calendar ;; Human-Keywords: calendar, diary, iCalendar, vCalendar -;; Version: 0.19 +;; Old-Version: 0.19 ;; This file is part of GNU Emacs. @@ -107,6 +107,7 @@ (defconst icalendar-version "0.19" "Version number of icalendar.el.") +(make-obsolete-variable 'icalendar-version nil "28.1") ;; ====================================================================== ;; Customizables 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..1c0f4da0f4b 100644 --- a/lisp/calendar/lunar.el +++ b/lisp/calendar/lunar.el @@ -1,4 +1,4 @@ -;;; lunar.el --- calendar functions for phases of the moon +;;; lunar.el --- calendar functions for phases of the moon -*- lexical-binding:t -*- ;; Copyright (C) 1992-1993, 1995, 1997, 2001-2020 Free Software ;; Foundation, Inc. @@ -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")))) @@ -234,6 +255,8 @@ use instead of point." If called with an optional prefix argument ARG, prompts for month and year. This function is suitable for execution in an init file." (interactive "P") + (with-suppressed-warnings ((lexical date)) + (defvar date)) (save-excursion (let* ((date (if arg (calendar-read-date t) (calendar-current-date))) @@ -241,18 +264,17 @@ This function is suitable for execution in an init file." (displayed-year (calendar-extract-year date))) (calendar-lunar-phases)))) -;; The function below is designed to be used in sexp diary entries, -;; and may be present in users' diary files, so suppress the warning -;; about this prefix-less dynamic variable. It's called from -;; `diary-list-sexp-entries', which binds the variable. -(with-suppressed-warnings ((lexical date)) - (defvar date)) - ;;;###diary-autoload (defun diary-lunar-phases (&optional mark) "Moon phases diary entry. An optional parameter MARK specifies a face or single-character string to use when highlighting the day in the calendar." + ;; This function is designed to be used in sexp diary entries, and + ;; may be present in users' diary files, so suppress the warning + ;; about this prefix-less dynamic variable. It's called from + ;; `diary-list-sexp-entries', which binds the variable. + (with-suppressed-warnings ((lexical date)) + (defvar date)) (let* ((index (lunar-index date)) (phase (lunar-phase index))) (while (calendar-date-compare phase (list date)) 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/solar.el b/lisp/calendar/solar.el index 6a813e9ee82..05bb3164e12 100644 --- a/lisp/calendar/solar.el +++ b/lisp/calendar/solar.el @@ -209,7 +209,6 @@ Returns nil if nothing was entered." (defun solar-setup () "Prompt for `calendar-longitude', `calendar-latitude', `calendar-time-zone'." - (beep) (or calendar-longitude (setq calendar-longitude (solar-get-number @@ -840,7 +839,9 @@ This function is suitable for execution in an init file." "E" "W")))))) (calendar-standard-time-zone-name (if (< arg 16) calendar-standard-time-zone-name - (cond ((zerop calendar-time-zone) "UTC") + (cond ((zerop calendar-time-zone) + (if (eq calendar-time-zone-style 'numeric) + "+0000" "UTC")) ((< calendar-time-zone 0) (format "UTC%dmin" calendar-time-zone)) (t (format "UTC+%dmin" calendar-time-zone))))) @@ -1013,7 +1014,10 @@ Requires floating point." (let* ((m displayed-month) (y displayed-year) (calendar-standard-time-zone-name - (if calendar-time-zone calendar-standard-time-zone-name "UTC")) + (cond + (calendar-time-zone calendar-standard-time-zone-name) + ((eq calendar-time-zone-style 'numeric) "+0000") + (t "UTC"))) (calendar-daylight-savings-starts (if calendar-time-zone calendar-daylight-savings-starts)) (calendar-daylight-savings-ends diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el index 1e589ece29d..125f9acc705 100644 --- a/lisp/calendar/time-date.el +++ b/lisp/calendar/time-date.el @@ -355,6 +355,8 @@ is output until the first non-zero unit is encountered." (defun date-days-in-month (year month) "The number of days in MONTH in YEAR." + (unless (and (numberp month) (<= 1 month 12)) + (error "Month %s is invalid" month)) (if (= month 2) (if (date-leap-year-p year) 29 @@ -515,17 +517,31 @@ 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 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))) - (when (and (not (decoded-time-zone time)) - default-zone) - (setf (decoded-time-zone time) 0)) time) +(defun decoded-time-period (time) + "Interpret DECODED as a period and return its length in seconds. +For computational purposes, years are 365 days long and months +are 30 days long." + (+ (if (consp (decoded-time-second time)) + ;; Fractional second. + (/ (float (car (decoded-time-second time))) + (cdr (decoded-time-second time))) + (or (decoded-time-second time) 0)) + (* (or (decoded-time-minute time) 0) 60) + (* (or (decoded-time-hour time) 0) 60 60) + (* (or (decoded-time-day time) 0) 60 60 24) + (* (or (decoded-time-month time) 0) 60 60 24 30) + (* (or (decoded-time-year time) 0) 60 60 24 365))) + (provide 'time-date) ;;; time-date.el ends here diff --git a/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/cdl.el b/lisp/cdl.el index adc05f1bb52..c8025a9f530 100644 --- a/lisp/cdl.el +++ b/lisp/cdl.el @@ -1,4 +1,4 @@ -;;; cdl.el --- Common Data Language (CDL) utility functions for GNU Emacs +;;; cdl.el --- Common Data Language (CDL) utility functions for GNU Emacs -*- lexical-binding: t -*- ;; Copyright (C) 1993, 2001-2020 Free Software Foundation, Inc. diff --git a/lisp/cedet/data-debug.el b/lisp/cedet/data-debug.el index 78a72dd889c..604fc40926c 100644 --- a/lisp/cedet/data-debug.el +++ b/lisp/cedet/data-debug.el @@ -49,9 +49,9 @@ ;;; Compatibility ;; -(defalias 'data-debug-overlay-properties 'overlay-properties) -(defalias 'data-debug-overlay-p 'overlayp) -(defalias 'dd-propertize 'propertize) +(define-obsolete-function-alias 'data-debug-overlay-properties 'overlay-properties "28.1") +(define-obsolete-function-alias 'data-debug-overlay-p 'overlayp "28.1") +(define-obsolete-function-alias 'dd-propertize 'propertize "28.1") ;;; GENERIC STUFF ;; @@ -73,7 +73,7 @@ The attributes belong to the tag PARENT." "Insert all the parts of OVERLAY. PREFIX specifies what to insert at the start of each line." (let ((attrprefix (concat (make-string (length prefix) ? ) "# ")) - (proplist (data-debug-overlay-properties overlay))) + (proplist (overlay-properties overlay))) (data-debug-insert-property-list proplist attrprefix) ) @@ -393,10 +393,10 @@ PREBUTTONTEXT is some text between prefix and the stuff list button." (lambda (key value) (data-debug-insert-thing key prefix - (dd-propertize "key " 'face font-lock-comment-face)) + (propertize "key " 'face font-lock-comment-face)) (data-debug-insert-thing value prefix - (dd-propertize "val " 'face font-lock-comment-face))) + (propertize "val " 'face font-lock-comment-face))) hash-table)) (defun data-debug-insert-hash-table-from-point (point) @@ -415,9 +415,9 @@ PREBUTTONTEXT is some text between prefix and the stuff list button." (defun data-debug-insert-hash-table-button (hash-table prefix prebuttontext) "Insert HASH-TABLE as expandable button with recursive prefix PREFIX and PREBUTTONTEXT in front of the button text." - (let ((string (dd-propertize (format "%s" hash-table) + (let ((string (propertize (format "%s" hash-table) 'face 'font-lock-keyword-face))) - (insert (dd-propertize + (insert (propertize (concat prefix prebuttontext string) 'ddebug hash-table 'ddebug-indent (length prefix) @@ -444,7 +444,7 @@ PREBUTTONTEXT is some text between prefix and the stuff list button." (data-debug-insert-thing (car (cdr rest)) prefix (concat - (dd-propertize (format "%s" (car rest)) + (propertize (format "%s" (car rest)) 'face font-lock-comment-face) " : ")) (setq rest (cdr (cdr rest)))) @@ -468,9 +468,9 @@ PREBUTTONTEXT is some text between prefix and the stuff list button." A Symbol is a simple thing, but this provides some face and prefix rules. PREFIX is the text that precedes the button. PREBUTTONTEXT is some text between prefix and the thing." - (let ((string (dd-propertize (format "#<WIDGET %s>" (car widget)) + (let ((string (propertize (format "#<WIDGET %s>" (car widget)) 'face 'font-lock-keyword-face))) - (insert (dd-propertize + (insert (propertize (concat prefix prebuttontext string) 'ddebug widget 'ddebug-indent (length prefix) @@ -613,7 +613,7 @@ PREBUTTONTEXT is some text between prefix and the stuff vector button." (symbol-value symbol) (concat (make-string indent ? ) "> ") (concat - (dd-propertize "value" + (propertize "value" 'face 'font-lock-comment-face) " "))) (data-debug-insert-property-list @@ -628,13 +628,13 @@ PREFIX is the text that precedes the button. PREBUTTONTEXT is some text between prefix and the symbol button." (let ((string (cond ((fboundp symbol) - (dd-propertize (concat "#'" (symbol-name symbol)) + (propertize (concat "#'" (symbol-name symbol)) 'face 'font-lock-function-name-face)) ((boundp symbol) - (dd-propertize (concat "'" (symbol-name symbol)) + (propertize (concat "'" (symbol-name symbol)) 'face 'font-lock-variable-name-face)) (t (format "'%s" symbol))))) - (insert (dd-propertize + (insert (propertize (concat prefix prebuttontext string) 'ddebug symbol 'ddebug-indent (length prefix) @@ -657,7 +657,7 @@ PREBUTTONTEXT is some text between prefix and the thing." (while (string-match "\t" newstr) (setq newstr (replace-match "\\t" t t newstr))) (insert prefix prebuttontext - (dd-propertize (format "\"%s\"" newstr) + (propertize (format "\"%s\"" newstr) 'face font-lock-string-face) "\n" ))) @@ -668,7 +668,7 @@ A Symbol is a simple thing, but this provides some face and prefix rules. PREFIX is the text that precedes the button. PREBUTTONTEXT is some text between prefix and the thing." (insert prefix prebuttontext - (dd-propertize (format "%S" thing) + (propertize (format "%S" thing) 'face font-lock-string-face) "\n")) @@ -737,10 +737,10 @@ FACE is the face to use." (null . data-debug-insert-nil) ;; Overlay - (data-debug-overlay-p . data-debug-insert-overlay-button) + (overlayp . data-debug-insert-overlay-button) ;; Overlay list - ((lambda (thing) (and (consp thing) (data-debug-overlay-p (car thing)))) . + ((lambda (thing) (and (consp thing) (overlayp (car thing)))) . data-debug-insert-overlay-list-button) ;; Buffer @@ -880,7 +880,7 @@ If PARENT is non-nil, it is somehow related as a parent to thing." comment-end "" buffer-read-only t) (setq-local comment-start-skip - "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *") + "\\(\\(^\\|[^\\\n]\\)\\(\\\\\\\\\\)*\\);+ *") (buffer-disable-undo) (set (make-local-variable 'font-lock-global-modes) nil) (font-lock-mode -1) diff --git a/lisp/cedet/ede.el b/lisp/cedet/ede.el index 1418ad9539d..41252815734 100644 --- a/lisp/cedet/ede.el +++ b/lisp/cedet/ede.el @@ -470,7 +470,7 @@ To be used in hook functions." ;; Emacs 21 has no buffer file name for directory edits. ;; so we need to add these hacks in. (eq major-mode 'dired-mode) - (eq major-mode 'vc-dired-mode)) + (eq major-mode 'vc-dir-mode)) (ede-minor-mode 1))) (define-minor-mode ede-minor-mode @@ -481,7 +481,7 @@ controlled project, then this mode is activated automatically provided `global-ede-mode' is enabled." :group 'ede (cond ((or (eq major-mode 'dired-mode) - (eq major-mode 'vc-dired-mode)) + (eq major-mode 'vc-dir-mode)) (ede-dired-minor-mode (if ede-minor-mode 1 -1))) (ede-minor-mode (if (not ede-constructing) @@ -1515,8 +1515,11 @@ It does not apply the value to buffers." (when project-dir (ede-directory-get-open-project project-dir 'ROOT)))) -(cl-defmethod project-roots ((project ede-project)) - (list (ede-project-root-directory project))) +(cl-defmethod project-root ((project ede-project)) + (ede-project-root-directory project)) + +;;; FIXME: Could someone look into implementing `project-ignores' for +;;; EDE and/or a faster `project-files'? (add-hook 'project-find-functions #'project-try-ede) @@ -1527,8 +1530,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/complete.el b/lisp/cedet/semantic/complete.el index 7abc4360f64..b262ab710f6 100644 --- a/lisp/cedet/semantic/complete.el +++ b/lisp/cedet/semantic/complete.el @@ -1635,10 +1635,10 @@ This will not happen if you directly set this variable via `setq'." :group 'semantic :version "24.3" :type 'integer - :set '(lambda (sym var) - (set-default sym var) - (when (boundp 'x-max-tooltip-size) - (setcdr x-max-tooltip-size (max (1+ var) (cdr x-max-tooltip-size)))))) + :set (lambda (sym var) + (set-default sym var) + (when (boundp 'x-max-tooltip-size) + (setcdr x-max-tooltip-size (max (1+ var) (cdr x-max-tooltip-size)))))) (defclass semantic-displayer-tooltip (semantic-displayer-traditional) diff --git a/lisp/cedet/semantic/db-ebrowse.el b/lisp/cedet/semantic/db-ebrowse.el index a3219af7d3e..d63e5bc4869 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: @@ -181,7 +181,8 @@ is specified by `semanticdb-default-save-directory'." "Load all semanticdb controlled EBROWSE caches." (interactive) (let ((f (directory-files semanticdb-default-save-directory - t (concat semanticdb-ebrowse-default-file-name + t (concat (regexp-quote + semanticdb-ebrowse-default-file-name) "-load\\.el\\'") t))) (while f diff --git a/lisp/cedet/semantic/fw.el b/lisp/cedet/semantic/fw.el index 7a1273d6534..e347c99f191 100644 --- a/lisp/cedet/semantic/fw.el +++ b/lisp/cedet/semantic/fw.el @@ -68,13 +68,11 @@ ;; Since Emacs 22 major mode functions should use `run-mode-hooks' to ;; run major mode hooks. -(defalias 'semantic-run-mode-hooks - (if (fboundp 'run-mode-hooks) - 'run-mode-hooks - 'run-hooks)) +(define-obsolete-function-alias 'semantic-run-mode-hooks 'run-mode-hooks "28.1") - ;; Fancy compat usage now handled in cedet-compat -(defalias 'semantic-subst-char-in-string 'subst-char-in-string) +;; Fancy compat usage now handled in cedet-compat +(define-obsolete-function-alias 'semantic-subst-char-in-string + 'subst-char-in-string "28.1") (defun semantic-delete-overlay-maybe (overlay) "Delete OVERLAY if it is a semantic token overlay." diff --git a/lisp/cedet/semantic/grammar.el b/lisp/cedet/semantic/grammar.el index 62c86f9d12d..6cd4832165c 100644 --- a/lisp/cedet/semantic/grammar.el +++ b/lisp/cedet/semantic/grammar.el @@ -1251,6 +1251,7 @@ common grammar menu." "Setup an XEmacs grammar menu in variable SYMBOL. MODE-MENU is an optional specific menu whose items are appended to the common grammar menu." + (declare (obsolete nil "28.1")) (let ((items (make-symbol "items")) (path (make-symbol "path"))) `(progn @@ -1306,7 +1307,7 @@ the change bounds to encompass the whole nonterminal tag." ;; Look within the line for a ; following an even number of backslashes ;; after either a non-backslash or the line beginning. (set (make-local-variable 'comment-start-skip) - "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *") + "\\(\\(^\\|[^\\\n]\\)\\(\\\\\\\\\\)*\\);+ *") (set (make-local-variable 'indent-line-function) 'semantic-grammar-indent) (set (make-local-variable 'fill-paragraph-function) @@ -1663,6 +1664,42 @@ Select the buffer containing the tag's definition, and move point there." (defvar semantic-grammar-eldoc-last-data (cons nil nil)) +(defun semantic--docstring-format-sym-doc (prefix doc &optional face) + "Combine PREFIX and DOC, and shorten the result to fit in the echo area. + +When PREFIX is a symbol, propertize its symbol name with FACE +before combining it with DOC. If FACE is not provided, just +apply the nil face. + +See also: `eldoc-echo-area-use-multiline-p'." + ;; Hoisted from old `eldoc-docstring-format-sym-doc'. + ;; If the entire line cannot fit in the echo area, the symbol name may be + ;; truncated or eliminated entirely from the output to make room for the + ;; description. + (when (symbolp prefix) + (setq prefix (concat (propertize (symbol-name prefix) 'face face) ": "))) + (let* ((ea-multi eldoc-echo-area-use-multiline-p) + ;; Subtract 1 from window width since emacs will not write + ;; any chars to the last column, or in later versions, will + ;; cause a wraparound and resize of the echo area. + (ea-width (1- (window-width (minibuffer-window)))) + (strip (- (+ (length prefix) + (length doc)) + ea-width))) + (cond ((or (<= strip 0) + (eq ea-multi t) + (and ea-multi (> (length doc) ea-width))) + (concat prefix doc)) + ((> (length doc) ea-width) + (substring (format "%s" doc) 0 ea-width)) + ((>= strip (string-match-p ":? *\\'" prefix)) + doc) + (t + ;; Show the end of the partial symbol name, rather + ;; than the beginning, since the former is more likely + ;; to be unique given package namespace conventions. + (concat (substring prefix strip) doc))))) + (defun semantic-grammar-eldoc-get-macro-docstring (macro expander) "Return a one-line docstring for the given grammar MACRO. EXPANDER is the name of the function that expands MACRO." @@ -1681,19 +1718,18 @@ EXPANDER is the name of the function that expands MACRO." (setq doc (eldoc-function-argstring expander)))) (when doc (setq doc - (eldoc-docstring-format-sym-doc + (semantic--docstring-format-sym-doc macro (format "==> %s %s" expander doc) 'default)) (setq semantic-grammar-eldoc-last-data (cons expander doc))) doc)) ((fboundp 'elisp-get-fnsym-args-string) ;; Emacs≥25 - (elisp-get-fnsym-args-string - expander nil - (concat (propertize (symbol-name macro) + (concat (propertize (symbol-name macro) 'face 'font-lock-keyword-face) " ==> " (propertize (symbol-name macro) 'face 'font-lock-function-name-face) - ": "))))) + ": " + (elisp-get-fnsym-args-string expander nil ))))) (define-mode-local-override semantic-idle-summary-current-symbol-info semantic-grammar-mode () 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/semantic/wisent/comp.el b/lisp/cedet/semantic/wisent/comp.el index 4e9927f23f1..42c5756b987 100644 --- a/lisp/cedet/semantic/wisent/comp.el +++ b/lisp/cedet/semantic/wisent/comp.el @@ -3053,7 +3053,7 @@ one.") (defsubst wisent-ISVALID-TOKEN (x) "Return non-nil if X is a character or an allowed symbol." - (or (wisent-char-p x) + (or (characterp x) (wisent-ISVALID-VAR x))) (defun wisent-push-token (symbol &optional nocheck) @@ -3143,7 +3143,7 @@ the rule." (cond ((or (memq item token-list) (memq item var-list))) ;; Create new literal character token - ((wisent-char-p item) (wisent-push-token item t)) + ((characterp item) (wisent-push-token item t)) ((error "Symbol `%s' is used, but is not defined as a token and has no rules" item)))) (setq rhl (1+ rhl) diff --git a/lisp/cedet/semantic/wisent/wisent.el b/lisp/cedet/semantic/wisent/wisent.el index d8a35d3e7d3..a0a8bed1eaf 100644 --- a/lisp/cedet/semantic/wisent/wisent.el +++ b/lisp/cedet/semantic/wisent/wisent.el @@ -55,11 +55,8 @@ ;;;; Runtime stuff ;;;; ------------- -;;; Compatibility -(eval-and-compile - (if (fboundp 'char-valid-p) - (defalias 'wisent-char-p 'char-valid-p) - (defalias 'wisent-char-p 'char-or-char-int-p))) +(define-obsolete-function-alias 'wisent-char-p + #'characterp "28.1") ;;; Printed representation of terminals and nonterminals (defconst wisent-escape-sequence-strings @@ -80,7 +77,7 @@ (defsubst wisent-item-to-string (item) "Return a printed representation of ITEM. ITEM can be a nonterminal or terminal symbol, or a character literal." - (if (wisent-char-p item) + (if (characterp item) (or (cdr (assq item wisent-escape-sequence-strings)) (format "'%c'" item)) (symbol-name item))) 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/cedet/srecode/srt-mode.el b/lisp/cedet/srecode/srt-mode.el index 6b8c3034a4c..4c1e030fceb 100644 --- a/lisp/cedet/srecode/srt-mode.el +++ b/lisp/cedet/srecode/srt-mode.el @@ -195,7 +195,7 @@ we can tell font lock about them.") (set (make-local-variable 'comment-end) "") (set (make-local-variable 'parse-sexp-ignore-comments) t) (set (make-local-variable 'comment-start-skip) - "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *") + "\\(\\(^\\|[^\\\n]\\)\\(\\\\\\\\\\)*\\);+ *") (set (make-local-variable 'font-lock-defaults) '(srecode-font-lock-keywords nil ;; perform string/comment fontification diff --git a/lisp/char-fold.el b/lisp/char-fold.el index f8a303956e3..5a3c20c7832 100644 --- a/lisp/char-fold.el +++ b/lisp/char-fold.el @@ -370,11 +370,7 @@ from which to start." (setq i (1+ i))) (when (> spaces 0) (push (char-fold--make-space-string spaces) out)) - (let ((regexp (apply #'concat (nreverse out)))) - ;; Limited by `MAX_BUF_SIZE' in `regex-emacs.c'. - (if (> (length regexp) 5000) - (regexp-quote string) - regexp)))) + (apply #'concat (nreverse out)))) ;;; Commands provided for completeness. 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/comint.el b/lisp/comint.el index bf376a0b81c..c3cb439d8b8 100644 --- a/lisp/comint.el +++ b/lisp/comint.el @@ -249,6 +249,10 @@ to set this in a mode hook, rather than customize the default value." file) :group 'comint) +(defvar comint-input-ring-file-prefix nil + "The prefix to skip when parsing the input ring file. +This is useful in Zsh when the extended_history option is on.") + (defcustom comint-scroll-to-bottom-on-input nil "Controls whether input to interpreter causes window to scroll. If nil, then do not scroll. If t or `all', scroll all windows showing buffer. @@ -731,7 +735,7 @@ contents are sent to the process as its initial input. If PROGRAM is a string, any more args are arguments to PROGRAM. Return the (possibly newly created) process buffer." - (or (fboundp 'start-file-process) + (or (fboundp 'make-process) (error "Multi-processing is not supported for this system")) (setq buffer (get-buffer-create (or buffer (concat "*" name "*")))) ;; If no process, or nuked process, crank up a new one and put buffer in @@ -987,8 +991,20 @@ See also `comint-input-ignoredups' and `comint-write-input-ring'." (setq end (match-beginning 0))) (setq start (if (re-search-backward ring-separator nil t) - (match-end 0) - (point-min))) + (progn + (when (and comint-input-ring-file-prefix + (looking-at + comint-input-ring-file-prefix)) + ;; Skip zsh extended_history stamps + (goto-char (match-end 0))) + (match-end 0)) + (progn + (goto-char (point-min)) + (when (and comint-input-ring-file-prefix + (looking-at + comint-input-ring-file-prefix)) + (goto-char (match-end 0))) + (point)))) (setq history (buffer-substring start end)) (goto-char start) (when (and (not (string-match history-ignore history)) @@ -2350,6 +2366,7 @@ a buffer local variable." ;; For compatibility. (defun comint-read-noecho (prompt &optional _ignore) + (declare (obsolete read-passwd "28.1")) (read-passwd prompt)) ;; These three functions are for entering text you don't want echoed or @@ -3124,7 +3141,7 @@ See `comint-word'." "\\$\\(?:\\([[:alpha:]][[:alnum:]]*\\)" "\\|{\\(?1:[^{}]+\\)}\\)" (when (memq system-type '(ms-dos windows-nt)) - "\\|%\\(?1:[^\\\\/]*\\)%") + "\\|%\\(?1:[^\\/]*\\)%") (when comint-file-name-quote-list "\\|\\\\\\(.\\)"))) (qupos nil) @@ -3641,7 +3658,7 @@ and does not normally need to be invoked by the end user or programmer." (setq-local comint-redirect-previous-input-string "") (setq mode-line-process - (if mode-line-process + (if (and mode-line-process (stringp (elt mode-line-process 0))) (list (concat (elt mode-line-process 0) " Redirection")) (list ":%s Redirection"))))) diff --git a/lisp/cus-dep.el b/lisp/cus-dep.el index fd307a5c04e..f1061a8621b 100644 --- a/lisp/cus-dep.el +++ b/lisp/cus-dep.el @@ -70,7 +70,7 @@ Usage: emacs -batch -l ./cus-dep.el -f custom-make-dependencies DIRS" (directory-files subdir nil "\\`[^=.].*\\.el\\'")))) (progress (make-progress-reporter - (byte-compile-info-string "Scanning files for custom") + (byte-compile-info "Scanning files for custom") 0 (length files) nil 10))) (with-temp-buffer (dolist (elem files) @@ -127,8 +127,8 @@ Usage: emacs -batch -l ./cus-dep.el -f custom-make-dependencies DIRS" type))))))))))) (error nil))))))) (progress-reporter-done progress)) - (byte-compile-info-message "Generating %s..." - generated-custom-dependencies-file) + (byte-compile-info + (format "Generating %s..." generated-custom-dependencies-file) t) (set-buffer (find-file-noselect generated-custom-dependencies-file)) (setq buffer-undo-list t) (erase-buffer) @@ -217,8 +217,8 @@ elements the files that have variables or faces that contain that version. These files should be loaded before showing the customization buffer that `customize-changed-options' generates.\")\n\n")) (save-buffer) - (byte-compile-info-message "Generating %s...done" - generated-custom-dependencies-file)) + (byte-compile-info + (format "Generating %s...done" generated-custom-dependencies-file) t)) (provide 'cus-dep) diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index 490d9055ecf..16695967dfa 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -3825,7 +3825,17 @@ Optional EVENT is the location for the menu." (defun custom-face-save (widget) "Save the face edited by WIDGET." - (custom-face-mark-to-save widget) + (let ((form (widget-get widget :custom-form))) + (if (memq form '(all lisp)) + (custom-face-mark-to-save widget) + ;; The user is working on only a selected terminal type; + ;; make sure we save the entire spec to `custom-file'. (Bug #40866) + (custom-face-edit-all widget) + (custom-face-mark-to-save widget) + (if (eq form 'selected) + (custom-face-edit-selected widget) + ;; `form' is edit or mismatch; can't happen. + (widget-put widget :custom-form form)))) (custom-save-all) (custom-face-state-set-and-redraw widget)) @@ -4831,7 +4841,10 @@ The format is suitable for use with `easy-menu-define'." (error "You can't edit this part of the Custom buffer")) (defun Custom-newline (pos &optional event) - "Invoke button at POS, or refuse to allow editing of Custom buffer." + "Invoke button at POS, or refuse to allow editing of Custom buffer. + +To see what function the widget will call, use the +`widget-describe' command." (interactive "@d") (let ((button (get-char-property pos 'button))) ;; If there is no button at point, then use the one at the start diff --git a/lisp/cus-face.el b/lisp/cus-face.el index ed4cf046fcf..cc766aa4509 100644 --- a/lisp/cus-face.el +++ b/lisp/cus-face.el @@ -166,9 +166,11 @@ :help-echo "Control box around text." (const :tag "Off" nil) (list :tag "Box" - :value (:line-width 2 :color "grey75" :style released-button) - (const :format "" :value :line-width) - (integer :tag "Width") + :value (:line-width (2 . 2) :color "grey75" :style released-button) + (const :format "" :value :line-width) + (cons :tag "Width" :extra-offset 2 + (integer :tag "Vertical") + (integer :tag "Horizontal")) (const :format "" :value :color) (choice :tag "Color" (const :tag "*" nil) color) (const :format "" :value :style) @@ -181,15 +183,19 @@ (and real-value (let ((lwidth (or (and (consp real-value) - (plist-get real-value :line-width)) + (if (listp (cdr real-value)) + (plist-get real-value :line-width) + real-value)) (and (integerp real-value) real-value) - 1)) + '(1 . 1))) (color (or (and (consp real-value) (plist-get real-value :color)) (and (stringp real-value) real-value) nil)) (style (and (consp real-value) (plist-get real-value :style)))) + (if (integerp lwidth) + (setq lwidth (cons (abs lwidth) lwidth))) (list :line-width lwidth :color color :style style)))) ;; filter to make customized-value suitable for storing (lambda (cus-value) diff --git a/lisp/custom.el b/lisp/custom.el index 885c486c5e4..db7f6a056d4 100644 --- a/lisp/custom.el +++ b/lisp/custom.el @@ -1541,6 +1541,20 @@ Each of the arguments ARGS has this form: This means reset VARIABLE. (The argument IGNORED is ignored)." (apply #'custom-theme-reset-variables 'user args)) +(defun custom-add-choice (variable choice) + "Add CHOICE to the custom type of VARIABLE. +If a choice with the same tag already exists, no action is taken." + (let ((choices (get variable 'custom-type))) + (unless (eq (car choices) 'choice) + (error "Not a choice type: %s" choices)) + (unless (seq-find (lambda (elem) + (equal (caddr (member :tag elem)) + (caddr (member :tag choice)))) + (cdr choices)) + ;; Put the new choice at the end. + (put variable 'custom-type + (append choices (list choice)))))) + ;;; The End. (provide 'custom) diff --git a/lisp/descr-text.el b/lisp/descr-text.el index 1dbbd421489..55f0b7dcb40 100644 --- a/lisp/descr-text.el +++ b/lisp/descr-text.el @@ -763,6 +763,8 @@ The character information includes: (to (nth 4 composition)) glyph) (if (fontp font) + ;; GUI frame: show composition in terms of + ;; font glyphs and characters. (progn (insert " using this font:\n " (symbol-name (font-get font :type)) @@ -772,12 +774,25 @@ The character information includes: (while (and (<= from to) (setq glyph (lgstring-glyph gstring from))) (insert (format " %S\n" glyph)) - (setq from (1+ from)))) + (setq from (1+ from))) + (when (and (stringp (car composition)) + (string-match "\"\\([^\"]+\\)\"" (car composition))) + (insert "with these character(s):\n") + (let ((chars (match-string 1 (car composition)))) + (dotimes (i (length chars)) + (let ((char (aref chars i))) + (insert (format " %s (#x%x) %s\n" + (describe-char-padded-string char) char + (get-char-code-property + char 'name)))))))) + ;; TTY frame: show composition in terms of characters. (insert " by these characters:\n") (while (and (<= from to) (setq glyph (lgstring-glyph gstring from))) - (insert (format " %c (#x%x)\n" - (lglyph-char glyph) (lglyph-char glyph))) + (insert (format " %c (#x%x) %s\n" + (lglyph-char glyph) (lglyph-char glyph) + (get-char-code-property + (lglyph-char glyph) 'name))) (setq from (1+ from))))) (insert " by the rule:\n\t(") (let ((first t)) @@ -919,7 +934,7 @@ condition, the function may return string longer than WIDTH, see (t name))))))) ;;;###autoload -(defun describe-char-eldoc () +(defun describe-char-eldoc (_callback &rest _) "Return a description of character at point for use by ElDoc mode. Return nil if character at point is a printable ASCII @@ -929,10 +944,17 @@ Otherwise return a description formatted by of `eldoc-echo-area-use-multiline-p' variable and width of minibuffer window for width limit. -This function is meant to be used as a value of -`eldoc-documentation-function' variable." +This function can be used as a value of +`eldoc-documentation-functions' variable." (let ((ch (following-char))) (when (and (not (zerop ch)) (or (< ch 32) (> ch 127))) + ;; TODO: investigate if the new `eldoc-documentation-functions' + ;; API could significantly improve this. JT@2020-07-07: Indeed, + ;; instead of returning a string tailored here for the echo area + ;; exclusively, we could call the (now unused) argument + ;; _CALLBACK with hints on how to shorten the string if needed, + ;; or with multiple usable strings which ElDoc picks according + ;; to its space contraints. (describe-char-eldoc--format ch (unless (eq eldoc-echo-area-use-multiline-p t) diff --git a/lisp/desktop.el b/lisp/desktop.el index b15ebc9b031..7fe5f73b879 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 @@ -534,7 +534,7 @@ can guess how to load the mode's definition.") '((defining-kbd-macro nil) (isearch-mode nil) (vc-mode nil) - (vc-dired-mode nil) + (vc-dir-mode nil) (erc-track-minor-mode nil) (savehist-mode nil)) "Table mapping minor mode variables to minor mode functions. diff --git a/lisp/dframe.el b/lisp/dframe.el index 2c421470a54..efe2bc57d93 100644 --- a/lisp/dframe.el +++ b/lisp/dframe.el @@ -7,6 +7,7 @@ (defvar dframe-version "1.3" "The current version of the dedicated frame library.") +(make-obsolete-variable 'dframe-version nil "28.1") ;; This file is part of GNU Emacs. diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index 7f988540c2c..c197ed04fe2 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -205,7 +205,10 @@ Examples of PREDICATE: (not (and (= (file-attribute-user-id fa1) - mark files with different UID (file-attribute-user-id fa2)) (= (file-attribute-group-id fa1) - and GID. - (file-attribute-group-id fa2))))" + (file-attribute-group-id fa2)))) + +If the region is active in Transient Mark mode, mark files +only in the active region if `dired-mark-region' is non-nil." (interactive (list (let* ((target-dir (dired-dwim-target-directory)) @@ -409,7 +412,8 @@ has no effect on MS-Windows." (set-file-modes file (if num-modes num-modes - (file-modes-symbolic-to-number modes (file-modes file))))) + (file-modes-symbolic-to-number modes (file-modes file 'nofollow))) + 'nofollow)) (dired-do-redisplay arg))) ;;;###autoload @@ -684,7 +688,7 @@ are executed in the background on each file sequentially waiting for each command to terminate before running the next command. In shell syntax this means separating the individual commands with `;'. -The output appears in the buffer `*Async Shell Command*'." +The output appears in the buffer named by `shell-command-buffer-name-async'." (interactive (let ((files (dired-get-marked-files t current-prefix-arg nil nil t))) (list @@ -722,16 +726,16 @@ it, write `*\"\"' in place of just `*'. This is equivalent to just `*' in the shell, but avoids Dired's special handling. If COMMAND ends in `&', `;', or `;&', it is executed in the -background asynchronously, and the output appears in the buffer -`*Async Shell Command*'. When operating on multiple files and COMMAND -ends in `&', the shell command is executed on each file in parallel. -However, when COMMAND ends in `;' or `;&' then commands are executed -in the background on each file sequentially waiting for each command -to terminate before running the next command. You can also use -`dired-do-async-shell-command' that automatically adds `&'. +background asynchronously, and the output appears in the buffer named +by `shell-command-buffer-name-async'. When operating on multiple files +and COMMAND ends in `&', the shell command is executed on each file +in parallel. However, when COMMAND ends in `;' or `;&', then commands +are executed in the background on each file sequentially waiting for +each command to terminate before running the next command. You can +also use `dired-do-async-shell-command' that automatically adds `&'. Otherwise, COMMAND is executed synchronously, and the output -appears in the buffer `*Shell Command Output*'. +appears in the buffer named by `shell-command-buffer-name'. This feature does not try to redisplay Dired buffers afterward, as there's no telling what files COMMAND may have changed. @@ -948,13 +952,17 @@ With a prefix argument, kill that many lines starting with the current line. "Kill all marked lines (not the files). With a prefix argument, kill that many lines starting with the current line. \(A negative argument kills backward.) + If you use this command with a prefix argument to kill the line for a file that is a directory, which you have inserted in the Dired buffer as a subdirectory, then it deletes that subdirectory from the buffer as well. + To kill an entire subdirectory \(without killing its line in the parent directory), go to its directory header line and use this -command with a prefix argument (the value does not matter)." +command with a prefix argument (the value does not matter). + +To undo the killing, the undo command can be used as normally." ;; Returns count of killed lines. FMT="" suppresses message. (interactive "P") (if arg @@ -1006,8 +1014,8 @@ command with a prefix argument (the value does not matter)." (defvar dired-compress-file-suffixes '( ;; "tar -zxf" isn't used because it's not available on the - ;; Solaris10 version of tar. Solaris10 becomes obsolete in 2021. - ;; Same thing on AIX 7.1. + ;; Solaris 10 version of tar (obsolete in 2024?). + ;; Same thing on AIX 7.1 (obsolete 2023?) and 7.2 (obsolete 2022?). ("\\.tar\\.gz\\'" "" "gzip -dc %i | tar -xf -") ("\\.tgz\\'" "" "gzip -dc %i | tar -xf -") ("\\.gz\\'" "" "gunzip") @@ -1060,8 +1068,6 @@ corresponding command. Within CMD, %i denotes the input file(s), and %o denotes the output file. %i path(s) are relative, while %o is absolute.") -(declare-function format-spec "format-spec.el" (format specification)) - ;;;###autoload (defun dired-do-compress-to () "Compress selected files and directories to an archive. @@ -1069,7 +1075,6 @@ Prompt for the archive file name. Choose the archiving command based on the archive file-name extension and `dired-compress-files-alist'." (interactive) - (require 'format-spec) (let* ((in-files (dired-get-marked-files nil nil nil nil t)) (out-file (expand-file-name (read-file-name "Compress to: "))) (rule (cl-find-if @@ -1089,12 +1094,12 @@ and `dired-compress-files-alist'." (when (zerop (dired-shell-command (format-spec (cdr rule) - `((?\o . ,(shell-quote-argument out-file)) - (?\i . ,(mapconcat - (lambda (file-desc) - (shell-quote-argument (file-name-nondirectory - file-desc))) - in-files " ")))))) + `((?o . ,(shell-quote-argument out-file)) + (?i . ,(mapconcat + (lambda (in-file) + (shell-quote-argument + (file-name-nondirectory in-file))) + in-files " ")))))) (message (ngettext "Compressed %d file to %s" "Compressed %d files to %s" (length in-files)) @@ -1599,7 +1604,7 @@ Special value `always' suppresses confirmation." (defun dired-copy-file (from to ok-flag) (dired-handle-overwrite to) (dired-copy-file-recursive from to ok-flag dired-copy-preserve-time t - dired-recursive-copies)) + dired-recursive-copies dired-copy-dereference)) (declare-function make-symbolic-link "fileio.c") @@ -1622,7 +1627,8 @@ If `ask', ask for user confirmation." (dired-create-directory dir)))) (defun dired-copy-file-recursive (from to ok-flag &optional - preserve-time top recursive) + preserve-time top recursive + dereference) (when (and (eq t (file-attribute-type (file-attributes from))) (file-in-directory-p to from)) (error "Cannot copy `%s' into its subdirectory `%s'" from to)) @@ -1634,7 +1640,8 @@ If `ask', ask for user confirmation." (copy-directory from to preserve-time) (or top (dired-handle-overwrite to)) (condition-case err - (if (stringp (file-attribute-type attrs)) + (if (and (not dereference) + (stringp (file-attribute-type attrs))) ;; It is a symlink (make-symbolic-link (file-attribute-type attrs) to ok-flag) (dired-maybe-create-dirs (file-name-directory to)) @@ -1973,6 +1980,10 @@ Optional arg HOW-TO determines how to treat the target. (apply (car into-dir) operation rfn-list fn-list target (cdr into-dir)) (if (not (or dired-one-file into-dir)) (error "Marked %s: target must be a directory: %s" operation target)) + (if (and (not (file-directory-p (car fn-list))) + (not (file-directory-p target)) + (directory-name-p target)) + (error "%s: Target directory does not exist: %s" operation target)) ;; rename-file bombs when moving directories unless we do this: (or into-dir (setq target (directory-file-name target))) (dired-create-files @@ -2156,6 +2167,9 @@ See HOW-TO argument for `dired-do-create-files'.") ;;;###autoload (defun dired-do-copy (&optional arg) "Copy all marked (or next ARG) files, or copy the current file. +ARG has to be numeric for above functionality. See +`dired-get-marked-files' for more details. + When operating on just the current file, prompt for the new name. When operating on multiple or marked files, prompt for a target @@ -2169,10 +2183,18 @@ If `dired-copy-preserve-time' is non-nil, this command preserves the modification time of each old file in the copy, similar to the \"-p\" option for the \"cp\" shell command. -This command copies symbolic links by creating new ones, similar -to the \"-d\" option for the \"cp\" shell command." +This command copies symbolic links by creating new ones, +similar to the \"-d\" option for the \"cp\" shell command. +But if `dired-copy-dereference' is non-nil, the symbolic +links are dereferenced and then copied, similar to the \"-L\" +option for the \"cp\" shell command. If ARG is a cons with +element 4 (`\\[universal-argument]'), the inverted value of +`dired-copy-dereference' will be used." (interactive "P") - (let ((dired-recursive-copies dired-recursive-copies)) + (let ((dired-recursive-copies dired-recursive-copies) + (dired-copy-dereference (if (equal arg '(4)) + (not dired-copy-dereference) + dired-copy-dereference))) (dired-do-create-files 'copy #'dired-copy-file "Copy" arg dired-keep-marker-copy @@ -3045,6 +3067,69 @@ instead." (backward-delete-char 1)) (message "%s" (buffer-string))))) + +;;; Version control from dired + +(declare-function vc-dir-unmark-all-files "vc-dir") +(declare-function vc-dir-mark-files "vc-dir") + +;;;###autoload +(defun dired-vc-next-action (verbose) + "Do the next version control operation on marked files/directories. +When only files are marked then call `vc-next-action' with the +same value of the VERBOSE argument. +When also directories are marked then call `vc-dir' and mark +the same files/directories in the VC-Dir buffer that were marked +in the Dired buffer." + (interactive "P") + (let* ((marked-files + (dired-get-marked-files nil nil nil nil t)) + (mark-files + (when (cl-some #'file-directory-p marked-files) + ;; Fix deficiency of Dired by adding slash to dirs + (mapcar (lambda (file) + (if (file-directory-p file) + (file-name-as-directory file) + file)) + marked-files)))) + (if mark-files + (let ((transient-hook (make-symbol "vc-dir-mark-files"))) + (fset transient-hook + (lambda () + (remove-hook 'vc-dir-refresh-hook transient-hook t) + (vc-dir-unmark-all-files t) + (vc-dir-mark-files mark-files))) + (vc-dir-root) + (add-hook 'vc-dir-refresh-hook transient-hook nil t)) + (vc-next-action verbose)))) + +(declare-function vc-compatible-state "vc") + +;;;###autoload +(defun dired-vc-deduce-fileset (&optional state-model-only-files not-state-changing) + (let ((backend (vc-responsible-backend default-directory)) + (files (dired-get-marked-files nil nil nil nil t)) + only-files-list + state + model) + (when (and (not not-state-changing) (cl-some #'file-directory-p files)) + (user-error "State changing VC operations on directories supported only in `vc-dir'")) + + (when state-model-only-files + (setq only-files-list (mapcar (lambda (file) (cons file (vc-state file))) files)) + (setq state (cdar only-files-list)) + ;; Check that all files are in a consistent state, since we use that + ;; state to decide which operation to perform. + (dolist (crt (cdr only-files-list)) + (unless (vc-compatible-state (cdr crt) state) + (error "When applying VC operations to multiple files, the files are required\nto be in similar VC states.\n%s in state %s clashes with %s in state %s" + (car crt) (cdr crt) (caar only-files-list) state))) + (setq only-files-list (mapcar 'car only-files-list)) + (when (and state (not (eq state 'unregistered))) + (setq model (vc-checkout-model backend only-files-list)))) + (list backend files only-files-list state model))) + + (provide 'dired-aux) ;; Local Variables: diff --git a/lisp/dired-x.el b/lisp/dired-x.el index 623a1dd3255..873d586ca1b 100644 --- a/lisp/dired-x.el +++ b/lisp/dired-x.el @@ -623,7 +623,9 @@ interactively, prompt for REGEXP. With prefix argument, unflag all those files. Optional fourth argument LOCALP is as in `dired-get-filename'. Optional fifth argument CASE-FOLD-P specifies the value of -`case-fold-search' used for matching REGEXP." +`case-fold-search' used for matching REGEXP. +If the region is active in Transient Mark mode, operate only on +files in the active region if `dired-mark-region' is non-nil." (interactive (list (read-regexp "Mark unmarked files matching regexp (default all): " @@ -1386,7 +1388,9 @@ present for some values of `ls-lisp-emulation'. This function operates only on the buffer content and does not refer at all to the underlying file system. Contrast this with -`find-dired', which might be preferable for the task at hand." +`find-dired', which might be preferable for the task at hand. +If the region is active in Transient Mark mode, mark files +only in the active region if `dired-mark-region' is non-nil." ;; Using sym="" instead of nil avoids the trap of ;; (string-match "foo" sym) into which a user would soon fall. ;; Give `equal' instead of `=' in the example, as this works on diff --git a/lisp/dired.el b/lisp/dired.el index 4d0c2abdf55..77bb6cfa9ca 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -125,7 +125,7 @@ For more details, see Info node `(emacs)ls in Lisp'." "Informs Dired about how `ls -lF' marks symbolic links. Set this to t if `ls' (or whatever program is specified by `insert-directory-program') with `-lF' marks the symbolic link -itself with a trailing @ (usually the case under Ultrix). +itself with a trailing @ (usually the case under Ultrix and macOS). Example: if `ln -s foo bar; ls -F bar' gives `bar -> foo', set it to nil (the default), if it gives `bar@ -> foo', set it to t. @@ -216,6 +216,12 @@ The target is used in the prompt for file copy, rename etc." :type 'boolean :group 'dired) +(defcustom dired-copy-dereference nil + "If non-nil, Dired dereferences symlinks when copying them. +This is similar to the \"-L\" option for the \"cp\" shell command." + :type 'boolean + :group 'dired) + ; ; These variables were deleted and the replacements are on files.el. ; We leave aliases behind for back-compatibility. (define-obsolete-variable-alias 'dired-free-space-program @@ -230,6 +236,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'." @@ -294,6 +302,36 @@ new Dired buffers." :version "26.1" :group 'dired) +(defcustom dired-mark-region 'file + "Defines what commands that mark files do with the active region. + +When nil, marking commands don't operate on all files in the +active region. They process their prefix arguments as usual. + +When the value of this option is non-nil, then all Dired commands +that mark or unmark files will operate on all files in the region +if the region is active in Transient Mark mode. + +When `file', the region marking is based on the file name. +This means don't mark the file if the end of the region is +before the file name displayed on the Dired line, so the file name +is visually outside the region. This behavior is consistent with +marking files without the region using the key `m' that advances +point to the next line after marking the file. Thus the number +of keys used to mark files is the same as the number of keys +used to select the region, e.g. `M-2 m' marks 2 files, and +`C-SPC M-2 n m' marks 2 files, and `M-2 S-down m' marks 2 files. + +When `line', the region marking is based on Dired lines, +so include the file into marking if the end of the region +is anywhere on its Dired line, except the beginning of the line." + :type '(choice + (const :tag "Don't mark files in active region" nil) + (const :tag "Exclude file name outside of region" file) + (const :tag "Include the file at region end line" line)) + :group 'dired + :version "28.1") + ;; Internal variables (defvar dired-marker-char ?* ; the answer is 42 @@ -610,12 +648,20 @@ Subexpression 2 must end right before the \\n.") PREDICATE is evaluated on each line, with point at beginning of line. MSG is a noun phrase for the type of files being marked. It should end with a noun that can be pluralized by adding `s'. + +In Transient Mark mode, if the mark is active, operate on the contents +of the region if `dired-mark-region' is non-nil. Otherwise, operate +on the whole buffer. + Return value is the number of files marked, or nil if none were marked." - `(let ((inhibit-read-only t) count) + `(let ((inhibit-read-only t) count + (use-region-p (dired-mark--region-use-p)) + (beg (dired-mark--region-beginning)) + (end (dired-mark--region-end))) (save-excursion (setq count 0) (when ,msg - (message "%s %ss%s..." + (message "%s %ss%s%s..." (cond ((eq dired-marker-char ?\s) "Unmarking") ((eq dired-del-marker dired-marker-char) "Flagging") @@ -623,22 +669,28 @@ Return value is the number of files marked, or nil if none were marked." ,msg (if (eq dired-del-marker dired-marker-char) " for deletion" - ""))) - (goto-char (point-min)) - (while (not (eobp)) + "") + (if use-region-p + " in region" + ""))) + (goto-char beg) + (while (< (point) end) (when ,predicate (unless (= (following-char) dired-marker-char) (delete-char 1) (insert dired-marker-char) (setq count (1+ count)))) (forward-line 1)) - (when ,msg (message "%s %s%s %s%s" + (when ,msg (message "%s %s%s %s%s%s" count ,msg (dired-plural-s count) (if (eq dired-marker-char ?\s) "un" "") (if (eq dired-marker-char dired-del-marker) - "flagged" "marked")))) + "flagged" "marked") + (if use-region-p + " in region" + "")))) (and (> count 0) count))) (defmacro dired-map-over-marks (body arg &optional show-progress @@ -757,6 +809,32 @@ ERROR can be a string with the error message." (user-error (if (stringp error) error "No files specified"))) result)) +(defun dired-mark--region-use-p () + "Whether Dired marking commands should act on region." + (and dired-mark-region + (region-active-p) + (> (region-end) (region-beginning)))) + +(defun dired-mark--region-beginning () + "Return the value of the region beginning aligned to Dired file lines." + (if (dired-mark--region-use-p) + (save-excursion + (goto-char (region-beginning)) + (line-beginning-position)) + (point-min))) + +(defun dired-mark--region-end () + "Return the value of the region end aligned to Dired file lines." + (if (dired-mark--region-use-p) + (save-excursion + (goto-char (region-end)) + (if (if (eq dired-mark-region 'line) + (not (bolp)) + (get-text-property (1- (point)) 'dired-filename)) + (line-end-position) + (line-beginning-position))) + (point-max))) + ;; The dired command @@ -849,7 +927,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 @@ -1149,15 +1226,11 @@ wildcards, erases the buffer, and builds the subdir-alist anew ;; default-directory and dired-actual-switches must be buffer-local ;; and initialized by now. - (let (dirname - ;; This makes read-in much faster. - ;; In particular, it prevents the font lock hook from running - ;; until the directory is all read in. - (inhibit-modification-hooks t)) - (if (consp dired-directory) - (setq dirname (car dired-directory)) - (setq dirname dired-directory)) - (setq dirname (expand-file-name dirname)) + (let ((dirname + (expand-file-name + (if (consp dired-directory) + (car dired-directory) + dired-directory)))) (save-excursion ;; This hook which may want to modify dired-actual-switches ;; based on dired-directory, e.g. with ange-ftp to a SysV host @@ -1167,17 +1240,25 @@ wildcards, erases the buffer, and builds the subdir-alist anew (setq buffer-undo-list nil)) (setq-local file-name-coding-system (or coding-system-for-read file-name-coding-system)) - (let ((inhibit-read-only t) - ;; Don't make undo entries for readin. - (buffer-undo-list t)) - (widen) - (erase-buffer) - (dired-readin-insert)) - (goto-char (point-min)) - ;; Must first make alist buffer local and set it to nil because - ;; dired-build-subdir-alist will call dired-clear-alist first - (setq-local dired-subdir-alist nil) - (dired-build-subdir-alist) + (widen) + ;; We used to bind `inhibit-modification-hooks' to try and speed up + ;; execution, in particular, to prevent the font-lock hook from running + ;; until the directory is all read in. + ;; It's not clear why font-lock would be a significant issue + ;; here, but I used `combine-change-calls' which should provide the + ;; same performance advantages without the problem of breaking + ;; users of after/before-change-functions. + (combine-change-calls (point-min) (point-max) + (let ((inhibit-read-only t) + ;; Don't make undo entries for readin. + (buffer-undo-list t)) + (erase-buffer) + (dired-readin-insert)) + (goto-char (point-min)) + ;; Must first make alist buffer local and set it to nil because + ;; dired-build-subdir-alist will call dired-clear-alist first + (setq-local dired-subdir-alist nil) + (dired-build-subdir-alist)) (let ((attributes (file-attributes dirname))) (if (eq (car attributes) t) (set-visited-file-modtime (file-attribute-modification-time @@ -1811,6 +1892,7 @@ Do so according to the former subdir alist OLD-SUBDIR-ALIST." (define-key map "\177" 'dired-unmark-backward) (define-key map [remap undo] 'dired-undo) (define-key map [remap advertised-undo] 'dired-undo) + (define-key map [remap vc-next-action] 'dired-vc-next-action) ;; thumbnail manipulation (image-dired) (define-key map "\C-td" 'image-dired-display-thumbs) (define-key map "\C-tt" 'image-dired-tag-files) @@ -2149,6 +2231,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 +2293,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 +2325,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) @@ -3170,8 +3253,8 @@ Any other value means to ask for each directory." (const :tag "Confirm for each top directory only" top)) :group 'dired) -;; Match anything but `.' and `..'. -(defvar dired-re-no-dot (rx (or (not ".") "..."))) +(define-obsolete-variable-alias 'dired-re-no-dot + 'directory-files-no-dot-files-regexp "28.1") ;; Delete file, possibly delete a directory and all its files. ;; This function is useful outside of dired. One could change its name @@ -3193,7 +3276,9 @@ TRASH non-nil means to trash the file instead of deleting, provided ;; but more efficient (if (not (eq t (car (file-attributes file)))) (delete-file file trash) - (let* ((empty-dir-p (null (directory-files file t dired-re-no-dot)))) + (let* ((empty-dir-p (null (directory-files + file t + directory-files-no-dot-files-regexp)))) (if (and recursive (not empty-dir-p)) (unless (eq recursive 'always) (let ((prompt @@ -3460,26 +3545,27 @@ argument or confirmation)." ;; Mark *Marked Files* window as softly-dedicated, to prevent ;; other buffers e.g. *Completions* from reusing it (bug#17554). (display-buffer-mark-dedicated 'soft)) - (with-displayed-buffer-window + (with-current-buffer-window buffer - (cons 'display-buffer-below-selected - '((window-height . fit-window-to-buffer) - (preserve-size . (nil . t)))) + `(display-buffer-below-selected + (window-height . fit-window-to-buffer) + (preserve-size . (nil . t)) + (body-function + . ,#'(lambda (_window) + ;; Handle (t FILE) just like (FILE), here. That value is + ;; used (only in some cases), to mean just one file that was + ;; marked, rather than the current line file. + (dired-format-columns-of-files + (if (eq (car files) t) (cdr files) files)) + (remove-text-properties (point-min) (point-max) + '(mouse-face nil help-echo nil)) + (setq tab-line-exclude nil)))) #'(lambda (window _value) (with-selected-window window (unwind-protect (apply function args) (when (window-live-p window) - (quit-restore-window window 'kill))))) - ;; Handle (t FILE) just like (FILE), here. That value is - ;; used (only in some cases), to mean just one file that was - ;; marked, rather than the current line file. - (with-current-buffer buffer - (dired-format-columns-of-files - (if (eq (car files) t) (cdr files) files)) - (remove-text-properties (point-min) (point-max) - '(mouse-face nil help-echo nil)) - (setq tab-line-exclude nil)))))) + (quit-restore-window window 'kill))))))))) (defun dired-format-columns-of-files (files) (let ((beg (point))) @@ -3578,7 +3664,8 @@ no ARGth marked file is found before this line." (defun dired-mark (arg &optional interactive) "Mark the file at point in the Dired buffer. -If the region is active, mark all files in the region. +If the region is active in Transient Mark mode, mark all files +in the region if `dired-mark-region' is non-nil. Otherwise, with a prefix arg, mark files on the next ARG lines. If on a subdir headerline, mark all its files except `.' and `..'. @@ -3589,13 +3676,20 @@ this subdir." (interactive (list current-prefix-arg t)) (cond ;; Mark files in the active region. - ((and interactive (use-region-p)) + ((and interactive dired-mark-region + (region-active-p) + (> (region-end) (region-beginning))) (save-excursion (let ((beg (region-beginning)) (end (region-end))) (dired-mark-files-in-region (progn (goto-char beg) (line-beginning-position)) - (progn (goto-char end) (line-beginning-position)))))) + (progn (goto-char end) + (if (if (eq dired-mark-region 'line) + (not (bolp)) + (get-text-property (1- (point)) 'dired-filename)) + (line-end-position) + (line-beginning-position))))))) ;; Mark subdir files from the subdir headerline. ((dired-get-subdir) (save-excursion (dired-mark-subdir-files))) @@ -3643,12 +3737,18 @@ in the active region." "Toggle marks: marked files become unmarked, and vice versa. Flagged files (indicated with flags such as `C' and `D', not with `*') are not affected, and `.' and `..' are never toggled. -As always, hidden subdirs are not affected." +As always, hidden subdirs are not affected. + +In Transient Mark mode, if the mark is active, operate on the contents +of the region if `dired-mark-region' is non-nil. Otherwise, operate +on the whole buffer." (interactive) (save-excursion - (goto-char (point-min)) - (let ((inhibit-read-only t)) - (while (not (eobp)) + (let ((inhibit-read-only t) + (beg (dired-mark--region-beginning)) + (end (dired-mark--region-end))) + (goto-char beg) + (while (< (point) end) (or (dired-between-files) (looking-at-p dired-re-dot) ;; use subst instead of insdel because it does not move @@ -3676,6 +3776,9 @@ As always, hidden subdirs are not affected." A prefix argument means to unmark them instead. `.' and `..' are never marked. +If the region is active in Transient Mark mode, mark files +only in the active region if `dired-mark-region' is non-nil. + REGEXP is an Emacs regexp, not a shell wildcard. Thus, use `\\.o$' for object files--just `.o' will mark more than you might think." (interactive @@ -3727,6 +3830,9 @@ object files--just `.o' will mark more than you might think." A prefix argument means to unmark them instead. `.' and `..' are never marked. +If the region is active in Transient Mark mode, mark files +only in the active region if `dired-mark-region' is non-nil. + Note that if a file is visited in an Emacs buffer, and `dired-always-read-filesystem' is nil, this command will look in the buffer without revisiting the file, so the results might @@ -3771,14 +3877,18 @@ The match is against the non-directory part of the filename. Use `^' (defun dired-mark-symlinks (unflag-p) "Mark all symbolic links. -With prefix argument, unmark or unflag all those files." +With prefix argument, unmark or unflag all those files. +If the region is active in Transient Mark mode, mark files +only in the active region if `dired-mark-region' is non-nil." (interactive "P") (let ((dired-marker-char (if unflag-p ?\s dired-marker-char))) (dired-mark-if (looking-at-p dired-re-sym) "symbolic link"))) (defun dired-mark-directories (unflag-p) "Mark all directory file lines except `.' and `..'. -With prefix argument, unmark or unflag all those files." +With prefix argument, unmark or unflag all those files. +If the region is active in Transient Mark mode, mark files +only in the active region if `dired-mark-region' is non-nil." (interactive "P") (let ((dired-marker-char (if unflag-p ?\s dired-marker-char))) (dired-mark-if (and (looking-at-p dired-re-dir) @@ -3787,7 +3897,9 @@ With prefix argument, unmark or unflag all those files." (defun dired-mark-executables (unflag-p) "Mark all executable files. -With prefix argument, unmark or unflag all those files." +With prefix argument, unmark or unflag all those files. +If the region is active in Transient Mark mode, mark files +only in the active region if `dired-mark-region' is non-nil." (interactive "P") (let ((dired-marker-char (if unflag-p ?\s dired-marker-char))) (dired-mark-if (looking-at-p dired-re-exe) "executable file"))) @@ -3797,7 +3909,9 @@ With prefix argument, unmark or unflag all those files." (defun dired-flag-auto-save-files (&optional unflag-p) "Flag for deletion files whose names suggest they are auto save files. -A prefix argument says to unmark or unflag those files instead." +A prefix argument says to unmark or unflag those files instead. +If the region is active in Transient Mark mode, flag files +only in the active region if `dired-mark-region' is non-nil." (interactive "P") (let ((dired-marker-char (if unflag-p ?\s dired-del-marker))) (dired-mark-if @@ -3837,7 +3951,9 @@ A prefix argument says to unmark or unflag those files instead." (defun dired-flag-backup-files (&optional unflag-p) "Flag all backup files (names ending with `~') for deletion. -With prefix argument, unmark or unflag these files." +With prefix argument, unmark or unflag these files. +If the region is active in Transient Mark mode, flag files +only in the active region if `dired-mark-region' is non-nil." (interactive "P") (let ((dired-marker-char (if unflag-p ?\s dired-del-marker))) (dired-mark-if @@ -3857,28 +3973,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/dnd.el b/lisp/dnd.el index 905659e817b..1d0e26cb013 100644 --- a/lisp/dnd.el +++ b/lisp/dnd.el @@ -87,13 +87,11 @@ and is the default except for MS-Windows." (defun dnd-handle-one-url (window action url) "Handle one dropped url by calling the appropriate handler. The handler is first located by looking at `dnd-protocol-alist'. -If no match is found here, and the value of `browse-url-browser-function' -is a pair of (REGEXP . FUNCTION), those regexps are tried for a match. -If no match is found, just call `dnd-insert-text'. -WINDOW is where the drop happened, ACTION is the action for the drop, -URL is what has been dropped. -Returns ACTION." - (require 'browse-url) +If no match is found here, `browse-url-handlers' and +`browse-url-default-handlers' are searched for a match. +If no match is found, just call `dnd-insert-text'. WINDOW is +where the drop happened, ACTION is the action for the drop, URL +is what has been dropped. Returns ACTION." (let (ret) (or (catch 'done @@ -102,14 +100,13 @@ Returns ACTION." (setq ret (funcall (cdr bf) url action)) (throw 'done t))) nil) - (when (not (functionp browse-url-browser-function)) - (catch 'done - (dolist (bf browse-url-browser-function) - (when (string-match (car bf) url) - (setq ret 'private) - (funcall (cdr bf) url action) - (throw 'done t))) - nil)) + (catch 'done + (let ((browser (browse-url-select-handler url 'internal))) + (when browser + (setq ret 'private) + (funcall browser url action) + (throw 'done t))) + nil) (progn (dnd-insert-text window action url) (setq ret 'private))) diff --git a/lisp/doc-view.el b/lisp/doc-view.el index 171a939d4ec..de342f1519e 100644 --- a/lisp/doc-view.el +++ b/lisp/doc-view.el @@ -693,8 +693,6 @@ at the top edge of the page moves to the previous page." ;; time-window of loose permissions otherwise. (with-file-modes #o0700 (make-directory dir)) (file-already-exists - (when (file-symlink-p dir) - (error "Danger: %s points to a symbolic link" dir)) ;; In case it was created earlier with looser rights. ;; We could check the mode info returned by file-attributes, but it's ;; a pain to parse and it may not tell you what we want under @@ -704,7 +702,7 @@ at the top edge of the page moves to the previous page." ;; sure we have write-access to the directory and that we own it, thus ;; closing a bunch of security holes. (condition-case error - (set-file-modes dir #o0700) + (set-file-modes dir #o0700 'nofollow) (file-error (error (format "Unable to use temporary directory %s: %s" @@ -2052,8 +2050,8 @@ See the command `doc-view-mode' for more information on this mode." (when (memq (selected-frame) (alist-get 'frames attrs)) (let ((geom (alist-get 'geometry attrs))) (when geom - (setq monitor-top (nth 0 geom)) - (setq monitor-left (nth 1 geom)) + (setq monitor-left (nth 0 geom)) + (setq monitor-top (nth 1 geom)) (setq monitor-width (nth 2 geom)) (setq monitor-height (nth 3 geom)))))) (let ((frame (make-frame diff --git a/lisp/dom.el b/lisp/dom.el index 34df0e9af4c..7ff9e07b729 100644 --- a/lisp/dom.el +++ b/lisp/dom.el @@ -67,6 +67,12 @@ (setcdr old value) (setcar (cdr node) (nconc (cadr node) (list (cons attribute value))))))) +(defun dom-remove-attribute (node attribute) + "Remove ATTRIBUTE from NODE." + (setq node (dom-ensure-node node)) + (when-let ((old (assoc attribute (cadr node)))) + (setcar (cdr node) (delq old (cadr node))))) + (defmacro dom-attr (node attr) "Return the attribute ATTR from NODE. A typical attribute is `href'." diff --git a/lisp/dos-vars.el b/lisp/dos-vars.el index 0f58277fe51..47d1f83de9e 100644 --- a/lisp/dos-vars.el +++ b/lisp/dos-vars.el @@ -1,4 +1,4 @@ -;;; dos-vars.el --- MS-Dos specific user options +;;; dos-vars.el --- MS-Dos specific user options -*- lexical-binding:t -*- ;; Copyright (C) 1998, 2001-2020 Free Software Foundation, Inc. @@ -31,15 +31,13 @@ (defcustom msdos-shells '("command.com" "4dos.com" "ndos.com") "List of shells that use `/c' instead of `-c' and a backslashed command." - :type '(repeat string) - :group 'dos-fns) + :type '(repeat string)) (defcustom dos-codepage-setup-hook nil "List of functions to be called after the DOS terminal and coding systems are set up. This is the place, e.g., to set specific entries in `standard-display-table' as appropriate for your codepage, if `IT-display-table-setup' doesn't do a perfect job." - :group 'dos-fns :type '(hook) :version "20.3.3") diff --git a/lisp/elide-head.el b/lisp/elide-head.el index 57940456660..a892754d723 100644 --- a/lisp/elide-head.el +++ b/lisp/elide-head.el @@ -1,4 +1,4 @@ -;;; elide-head.el --- hide headers in files +;;; elide-head.el --- hide headers in files -*- lexical-binding: t; -*- ;; Copyright (C) 1999, 2001-2020 Free Software Foundation, Inc. @@ -63,12 +63,10 @@ The cars of elements of the list are searched for in order. Text is 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) +(defvar-local elide-head-overlay nil) ;;;###autoload (defun elide-head (&optional arg) @@ -108,7 +106,7 @@ This is suitable as an entry on `find-file-hook' or appropriate mode hooks." (overlay-put elide-head-overlay 'after-string "..."))))))) (defun elide-head-show () - "Show a header elided current buffer by \\[elide-head]." + "Show a header in the current buffer elided by \\[elide-head]." (interactive) (if (and (overlayp elide-head-overlay) (overlay-buffer elide-head-overlay)) diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index dc7461d93ee..2eef4512009 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -1,4 +1,4 @@ -;; autoload.el --- maintain autoloads in loaddefs.el -*- lexical-binding: t -*- +;;; autoload.el --- maintain autoloads in loaddefs.el -*- lexical-binding: t -*- ;; Copyright (C) 1991-1997, 2001-2020 Free Software Foundation, Inc. @@ -604,9 +604,8 @@ Don't try to split prefixes that are already longer than that.") prefix file dropped) nil)))) prefixes))) - `(if (fboundp 'register-definition-prefixes) - (register-definition-prefixes ,file ',(sort (delq nil strings) - 'string<))))))) + `(register-definition-prefixes ,file ',(sort (delq nil strings) + 'string<)))))) (defun autoload--setup-output (otherbuf outbuf absfile load-name) (let ((outbuf @@ -895,7 +894,7 @@ FILE's modification time." (cons (lambda () (ignore-errors (delete-file tempfile))) kill-emacs-hook))) (unless (= temp-modes desired-modes) - (set-file-modes tempfile desired-modes)) + (set-file-modes tempfile desired-modes 'nofollow)) (write-region (point-min) (point-max) tempfile nil 1) (backup-buffer) (rename-file tempfile buffer-file-name t)) @@ -1124,7 +1123,7 @@ write its autoloads into the specified file instead." ;; Elements remaining in FILES have no existing autoload sections yet. (let ((no-autoloads-time (or last-time '(0 0 0 0))) (progress (make-progress-reporter - (byte-compile-info-string + (byte-compile-info (concat "Scraping files for " (file-relative-name generated-autoload-file))) @@ -1167,6 +1166,19 @@ write its autoloads into the specified file instead." ;; file-local autoload-generated-file settings. (autoload-save-buffers)))) +(defun batch-update-autoloads--summary (strings) + (let ((message "")) + (while strings + (when (> (length (concat message " " (car strings))) 64) + (byte-compile-info (concat message " ...") t "SCRAPE") + (setq message "")) + (setq message (if (zerop (length message)) + (car strings) + (concat message " " (car strings)))) + (setq strings (cdr strings))) + (when (> (length message) 0) + (byte-compile-info message t "SCRAPE")))) + ;;;###autoload (defun batch-update-autoloads () "Update loaddefs.el autoloads in batch mode. @@ -1190,6 +1202,7 @@ should be non-nil)." (or (string-match "\\`site-" file) (push (expand-file-name file) autoload-excludes))))))) (let ((args command-line-args-left)) + (batch-update-autoloads--summary args) (setq command-line-args-left nil) (apply #'update-directory-autoloads args))) diff --git a/lisp/emacs-lisp/benchmark.el b/lisp/emacs-lisp/benchmark.el index a7fcc5cb8f2..2fa5a878801 100644 --- a/lisp/emacs-lisp/benchmark.el +++ b/lisp/emacs-lisp/benchmark.el @@ -81,7 +81,7 @@ result. The overhead of the `lambda's is accounted for." (gcs (make-symbol "gcs")) (gc (make-symbol "gc")) (code (byte-compile `(lambda () ,@forms))) - (lambda-code (byte-compile '(lambda ())))) + (lambda-code (byte-compile '(lambda ())))) `(let ((,gc gc-elapsed) (,gcs gcs-done)) (list ,(if (or (symbolp repetitions) (> repetitions 1)) diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el index 850af93571f..d168c255121 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). @@ -635,7 +632,7 @@ If optional second arg SEP is a string, use that as separator." (bindat-format-vector vect "%d" (if (stringp sep) sep "."))) (defun bindat-vector-to-hex (vect &optional sep) - "Format vector VECT in hex format separated by dots. + "Format vector VECT in hex format separated by colons. If optional second arg SEP is a string, use that as separator." (bindat-format-vector vect "%02x" (if (stringp sep) sep ":"))) diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 90ab8911c39..4987596bf95 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -227,7 +227,7 @@ ;;; byte-compile optimizers to support inlining -(put 'inline 'byte-optimizer 'byte-optimize-inline-handler) +(put 'inline 'byte-optimizer #'byte-optimize-inline-handler) (defun byte-optimize-inline-handler (form) "byte-optimize-handler for the `inline' special-form." @@ -391,13 +391,6 @@ (and (nth 1 form) (not for-effect) form)) - ((eq (car-safe fn) 'lambda) - (let ((newform (byte-compile-unfold-lambda form))) - (if (eq newform form) - ;; Some error occurred, avoid infinite recursion - form - (byte-optimize-form-code-walker newform for-effect)))) - ((eq (car-safe fn) 'closure) form) ((memq fn '(let let*)) ;; recursively enter the optimizer for the bindings and body ;; of a let or let*. This for depth-firstness: forms that @@ -444,13 +437,6 @@ ;; will be optimized away in the lap-optimize pass. (cons fn (byte-optimize-body (cdr form) for-effect))) - ((eq fn 'with-output-to-temp-buffer) - ;; this is just like the above, except for the first argument. - (cons fn - (cons - (byte-optimize-form (nth 1 form) nil) - (byte-optimize-body (cdr (cdr form)) for-effect)))) - ((eq fn 'if) (when (< (length form) 3) (byte-compile-warn "too few arguments for `if'")) @@ -480,6 +466,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 +484,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 +504,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 @@ -531,6 +516,15 @@ ;; Needed as long as we run byte-optimize-form after cconv. ((eq fn 'internal-make-closure) form) + ((eq (car-safe fn) 'lambda) + (let ((newform (byte-compile-unfold-lambda form))) + (if (eq newform form) + ;; Some error occurred, avoid infinite recursion + form + (byte-optimize-form newform for-effect)))) + + ((eq (car-safe fn) 'closure) form) + ((byte-code-function-p fn) (cons fn (mapcar #'byte-optimize-form (cdr form)))) @@ -555,20 +549,10 @@ ;; Otherwise, no args can be considered to be for-effect, ;; even if the called function is for-effect, because we ;; don't know anything about that function. - (let ((args (mapcar #'byte-optimize-form (cdr form)))) - (if (and (get fn 'pure) - (byte-optimize-all-constp args)) - (list 'quote (apply fn (mapcar #'eval args))) - (cons fn args))))))) - -(defun byte-optimize-all-constp (list) - "Non-nil if all elements of LIST satisfy `macroexp-const-p'." - (let ((constant t)) - (while (and list constant) - (unless (macroexp-const-p (car list)) - (setq constant nil)) - (setq list (cdr list))) - constant)) + (let ((form (cons fn (mapcar #'byte-optimize-form (cdr form))))) + (if (get fn 'pure) + (byte-optimize-constant-args form) + form)))))) (defun byte-optimize-form (form &optional for-effect) "The source-level pass of the optimizer." @@ -664,45 +648,36 @@ (setq args (cons (car rest) args))) (setq rest (cdr rest))) (if (cdr constants) - (if args - (list (car form) - (apply (car form) constants) - (if (cdr args) - (cons (car form) (nreverse args)) - (car args))) - (apply (car form) constants)) - form))) + (let ((const (apply (car form) (nreverse constants)))) + (if args + (append (list (car form) const) + (nreverse args)) + const)) + form))) -;; Portable Emacs integers fall in this range. -(defconst byte-opt--portable-max #x1fffffff) -(defconst byte-opt--portable-min (- -1 byte-opt--portable-max)) - -;; True if N is a number that works the same on all Emacs platforms. -;; Portable Emacs fixnums are exactly representable as floats on all -;; Emacs platforms, and (except for -0.0) any floating-point number -;; that equals one of these integers must be the same on all -;; platforms. Although other floating-point numbers such as 0.5 are -;; also portable, it can be tricky to characterize them portably so -;; they are not optimized. -(defun byte-opt--portable-numberp (n) - (and (numberp n) - (<= byte-opt--portable-min n byte-opt--portable-max) - (= n (floor n)) - (not (and (floatp n) (zerop n) - (condition-case () (< (/ n) 0) (error)))))) - -;; Use OP to reduce any leading prefix of portable numbers in the list -;; (cons ACCUM ARGS) down to a single portable number, and return the +(defun byte-optimize-min-max (form) + "Optimize `min' and `max'." + (let ((opt (byte-optimize-associative-math form))) + (if (and (consp opt) (memq (car opt) '(min max)) + (= (length opt) 4)) + ;; (OP x y z) -> (OP (OP x y) z), in order to use binary byte ops. + (list (car opt) + (list (car opt) (nth 1 opt) (nth 2 opt)) + (nth 3 opt)) + opt))) + +;; Use OP to reduce any leading prefix of constant numbers in the list +;; (cons ACCUM ARGS) down to a single number, and return the ;; resulting list A of arguments. The idea is that applying OP to A ;; is equivalent to (but likely more efficient than) applying OP to ;; (cons ACCUM ARGS), on any Emacs platform. Do not make any special ;; provision for (- X) or (/ X); for example, it is the caller’s ;; responsibility that (- 1 0) should not be "optimized" to (- 1). (defun byte-opt--arith-reduce (op accum args) - (when (byte-opt--portable-numberp accum) + (when (numberp accum) (let (accum1) - (while (and (byte-opt--portable-numberp (car args)) - (byte-opt--portable-numberp + (while (and (numberp (car args)) + (numberp (setq accum1 (condition-case () (funcall op accum (car args)) (error)))) @@ -725,6 +700,9 @@ (integer (if integer-is-first arg1 arg2)) (other (if integer-is-first arg2 arg1))) (list (if (eq integer 1) '1+ '1-) other))) + ;; (+ x y z) -> (+ (+ x y) z) + ((= (length args) 3) + `(+ ,(byte-optimize-plus `(+ ,(car args) ,(cadr args))) ,@(cddr args))) ;; not further optimized ((equal args (cdr form)) form) (t (cons '+ args))))) @@ -747,35 +725,19 @@ ;; (- x -1) --> (1+ x) ((equal (cdr args) '(-1)) (list '1+ (car args))) - ;; (- n) -> -n, where n and -n are portable numbers. + ;; (- n) -> -n, where n and -n are constant numbers. ;; This must be done separately since byte-opt--arith-reduce ;; is not applied to (- n). ((and (null (cdr args)) - (byte-opt--portable-numberp (car args)) - (byte-opt--portable-numberp (- (car args)))) + (numberp (car args))) (- (car args))) + ;; (- x y z) -> (- (- x y) z) + ((= (length args) 3) + `(- ,(byte-optimize-minus `(- ,(car args) ,(cadr args))) ,@(cddr args))) ;; not further optimized ((equal args (cdr form)) form) (t (cons '- args)))))) -(defun byte-optimize-1+ (form) - (let ((args (cdr form))) - (when (null (cdr args)) - (let ((n (car args))) - (when (and (byte-opt--portable-numberp n) - (byte-opt--portable-numberp (1+ n))) - (setq form (1+ n)))))) - form) - -(defun byte-optimize-1- (form) - (let ((args (cdr form))) - (when (null (cdr args)) - (let ((n (car args))) - (when (and (byte-opt--portable-numberp n) - (byte-opt--portable-numberp (1- n))) - (setq form (1- n)))))) - form) - (defun byte-optimize-multiply (form) (let* ((args (remq 1 (byte-opt--arith-reduce #'* 1 (cdr form))))) (cond @@ -783,6 +745,10 @@ ((null args) 1) ;; (* n) -> n, where n is a number ((and (null (cdr args)) (numberp (car args))) (car args)) + ;; (* x y z) -> (* (* x y) z) + ((= (length args) 3) + `(* ,(byte-optimize-multiply `(* ,(car args) ,(cadr args))) + ,@(cddr args))) ;; not further optimized ((equal args (cdr form)) form) (t (cons '* args))))) @@ -811,10 +777,10 @@ (condition-case () (list 'quote (eval form)) (error form))) - (t ;; This can enable some lapcode optimizations. + (t ;; Moving the constant to the end can enable some lapcode optimizations. (list (car form) (nth 2 form) (nth 1 form))))) -(defun byte-optimize-predicate (form) +(defun byte-optimize-constant-args (form) (let ((ok t) (rest (cdr form))) (while (and rest ok) @@ -829,9 +795,6 @@ (defun byte-optimize-identity (form) (if (and (cdr form) (null (cdr (cdr form)))) (nth 1 form) - (byte-compile-warn "identity called with %d arg%s, but requires 1" - (length (cdr form)) - (if (= 1 (length (cdr form))) "" "s")) form)) (defun byte-optimize--constant-symbol-p (expr) @@ -864,21 +827,27 @@ ;; Arity errors reported elsewhere. form)) +(defun byte-optimize-assoc (form) + ;; Replace 2-argument `assoc' with `assq', `rassoc' with `rassq', + ;; if the first arg is a symbol. + (if (and (= (length form) 3) + (byte-optimize--constant-symbol-p (nth 1 form))) + (cons (if (eq (car form) 'assoc) 'assq 'rassq) + (cdr form)) + form)) + (defun byte-optimize-memq (form) ;; (memq foo '(bar)) => (and (eq foo 'bar) '(bar)) - (if (/= (length (cdr form)) 2) - (byte-compile-warn "memq called with %d arg%s, but requires 2" - (length (cdr form)) - (if (= 1 (length (cdr form))) "" "s")) - (let ((list (nth 2 form))) - (when (and (eq (car-safe list) 'quote) + (if (= (length (cdr form)) 2) + (let ((list (nth 2 form))) + (if (and (eq (car-safe list) 'quote) (listp (setq list (cadr list))) (= (length list) 1)) - (setq form (byte-optimize-and - `(and ,(byte-optimize-predicate - `(eq ,(nth 1 form) ',(nth 0 list))) - ',list))))) - (byte-optimize-predicate form))) + `(and (eq ,(nth 1 form) ',(nth 0 list)) + ',list) + form)) + ;; Arity errors reported elsewhere. + form)) (defun byte-optimize-concat (form) "Merge adjacent constant arguments to `concat'." @@ -907,58 +876,34 @@ form ; No improvement. (cons 'concat (nreverse newargs))))) -(put 'identity 'byte-optimizer 'byte-optimize-identity) -(put 'memq 'byte-optimizer 'byte-optimize-memq) -(put 'memql 'byte-optimizer 'byte-optimize-member) -(put 'member 'byte-optimizer 'byte-optimize-member) - -(put '+ 'byte-optimizer 'byte-optimize-plus) -(put '* 'byte-optimizer 'byte-optimize-multiply) -(put '- 'byte-optimizer 'byte-optimize-minus) -(put '/ 'byte-optimizer 'byte-optimize-divide) -(put 'max 'byte-optimizer 'byte-optimize-associative-math) -(put 'min 'byte-optimizer 'byte-optimize-associative-math) - -(put '= 'byte-optimizer 'byte-optimize-binary-predicate) -(put 'eq 'byte-optimizer 'byte-optimize-binary-predicate) -(put 'eql 'byte-optimizer 'byte-optimize-equal) -(put 'equal 'byte-optimizer 'byte-optimize-equal) -(put 'string= 'byte-optimizer 'byte-optimize-binary-predicate) -(put 'string-equal 'byte-optimizer 'byte-optimize-binary-predicate) - -(put '< 'byte-optimizer 'byte-optimize-predicate) -(put '> 'byte-optimizer 'byte-optimize-predicate) -(put '<= 'byte-optimizer 'byte-optimize-predicate) -(put '>= 'byte-optimizer 'byte-optimize-predicate) -(put '1+ 'byte-optimizer 'byte-optimize-1+) -(put '1- 'byte-optimizer 'byte-optimize-1-) -(put 'not 'byte-optimizer 'byte-optimize-predicate) -(put 'null 'byte-optimizer 'byte-optimize-predicate) -(put 'consp 'byte-optimizer 'byte-optimize-predicate) -(put 'listp 'byte-optimizer 'byte-optimize-predicate) -(put 'symbolp 'byte-optimizer 'byte-optimize-predicate) -(put 'stringp 'byte-optimizer 'byte-optimize-predicate) -(put 'string< 'byte-optimizer 'byte-optimize-predicate) -(put 'string-lessp 'byte-optimizer 'byte-optimize-predicate) -(put 'proper-list-p 'byte-optimizer 'byte-optimize-predicate) - -(put 'logand 'byte-optimizer 'byte-optimize-predicate) -(put 'logior 'byte-optimizer 'byte-optimize-predicate) -(put 'logxor 'byte-optimizer 'byte-optimize-predicate) -(put 'lognot 'byte-optimizer 'byte-optimize-predicate) - -(put 'car 'byte-optimizer 'byte-optimize-predicate) -(put 'cdr 'byte-optimizer 'byte-optimize-predicate) -(put 'car-safe 'byte-optimizer 'byte-optimize-predicate) -(put 'cdr-safe 'byte-optimizer 'byte-optimize-predicate) - -(put 'concat 'byte-optimizer 'byte-optimize-concat) +(put 'identity 'byte-optimizer #'byte-optimize-identity) +(put 'memq 'byte-optimizer #'byte-optimize-memq) +(put 'memql 'byte-optimizer #'byte-optimize-member) +(put 'member 'byte-optimizer #'byte-optimize-member) +(put 'assoc 'byte-optimizer #'byte-optimize-assoc) +(put 'rassoc 'byte-optimizer #'byte-optimize-assoc) + +(put '+ 'byte-optimizer #'byte-optimize-plus) +(put '* 'byte-optimizer #'byte-optimize-multiply) +(put '- 'byte-optimizer #'byte-optimize-minus) +(put '/ 'byte-optimizer #'byte-optimize-divide) +(put 'max 'byte-optimizer #'byte-optimize-min-max) +(put 'min 'byte-optimizer #'byte-optimize-min-max) + +(put '= 'byte-optimizer #'byte-optimize-binary-predicate) +(put 'eq 'byte-optimizer #'byte-optimize-binary-predicate) +(put 'eql 'byte-optimizer #'byte-optimize-equal) +(put 'equal 'byte-optimizer #'byte-optimize-equal) +(put 'string= 'byte-optimizer #'byte-optimize-binary-predicate) +(put 'string-equal 'byte-optimizer #'byte-optimize-binary-predicate) + +(put 'concat 'byte-optimizer #'byte-optimize-concat) ;; I'm not convinced that this is necessary. Doesn't the optimizer loop ;; take care of this? - Jamie ;; I think this may some times be necessary to reduce ie (quote 5) to 5, ;; so arithmetic optimizers recognize the numeric constant. - Hallvard -(put 'quote 'byte-optimizer 'byte-optimize-quote) +(put 'quote 'byte-optimizer #'byte-optimize-quote) (defun byte-optimize-quote (form) (if (or (consp (nth 1 form)) (and (symbolp (nth 1 form)) @@ -981,7 +926,7 @@ nil)) ((null (cdr (cdr form))) (nth 1 form)) - ((byte-optimize-predicate form)))) + ((byte-optimize-constant-args form)))) (defun byte-optimize-or (form) ;; Throw away nil's, and simplify if less than 2 args. @@ -994,7 +939,7 @@ (setq form (copy-sequence form) rest (setcdr (memq (car rest) form) nil)))) (if (cdr (cdr form)) - (byte-optimize-predicate form) + (byte-optimize-constant-args form) (nth 1 form)))) (defun byte-optimize-cond (form) @@ -1076,16 +1021,16 @@ (if (nth 1 form) form)) -(put 'and 'byte-optimizer 'byte-optimize-and) -(put 'or 'byte-optimizer 'byte-optimize-or) -(put 'cond 'byte-optimizer 'byte-optimize-cond) -(put 'if 'byte-optimizer 'byte-optimize-if) -(put 'while 'byte-optimizer 'byte-optimize-while) +(put 'and 'byte-optimizer #'byte-optimize-and) +(put 'or 'byte-optimizer #'byte-optimize-or) +(put 'cond 'byte-optimizer #'byte-optimize-cond) +(put 'if 'byte-optimizer #'byte-optimize-if) +(put 'while 'byte-optimizer #'byte-optimize-while) ;; byte-compile-negation-optimizer lives in bytecomp.el -(put '/= 'byte-optimizer 'byte-compile-negation-optimizer) -(put 'atom 'byte-optimizer 'byte-compile-negation-optimizer) -(put 'nlistp 'byte-optimizer 'byte-compile-negation-optimizer) +(put '/= 'byte-optimizer #'byte-compile-negation-optimizer) +(put 'atom 'byte-optimizer #'byte-compile-negation-optimizer) +(put 'nlistp 'byte-optimizer #'byte-compile-negation-optimizer) (defun byte-optimize-funcall (form) @@ -1113,12 +1058,12 @@ nil)) form))) -(put 'funcall 'byte-optimizer 'byte-optimize-funcall) -(put 'apply 'byte-optimizer 'byte-optimize-apply) +(put 'funcall 'byte-optimizer #'byte-optimize-funcall) +(put 'apply 'byte-optimizer #'byte-optimize-apply) -(put 'let 'byte-optimizer 'byte-optimize-letX) -(put 'let* 'byte-optimizer 'byte-optimize-letX) +(put 'let 'byte-optimizer #'byte-optimize-letX) +(put 'let* 'byte-optimizer #'byte-optimize-letX) (defun byte-optimize-letX (form) (cond ((null (nth 1 form)) ;; No bindings @@ -1134,17 +1079,17 @@ (list 'let* (reverse (cdr binds)) (nth 1 (car binds)) nil))))) -(put 'nth 'byte-optimizer 'byte-optimize-nth) +(put 'nth 'byte-optimizer #'byte-optimize-nth) (defun byte-optimize-nth (form) (if (= (safe-length form) 3) (if (memq (nth 1 form) '(0 1)) (list 'car (if (zerop (nth 1 form)) (nth 2 form) (list 'cdr (nth 2 form)))) - (byte-optimize-predicate form)) + form) form)) -(put 'nthcdr 'byte-optimizer 'byte-optimize-nthcdr) +(put 'nthcdr 'byte-optimizer #'byte-optimize-nthcdr) (defun byte-optimize-nthcdr (form) (if (= (safe-length form) 3) (if (memq (nth 1 form) '(0 1 2)) @@ -1153,14 +1098,14 @@ (while (>= (setq count (1- count)) 0) (setq form (list 'cdr form))) form) - (byte-optimize-predicate form)) + form) form)) ;; Fixme: delete-char -> delete-region (byte-coded) ;; optimize string-as-unibyte, string-as-multibyte, string-make-unibyte, ;; string-make-multibyte for constant args. -(put 'set 'byte-optimizer 'byte-optimize-set) +(put 'set 'byte-optimizer #'byte-optimize-set) (defun byte-optimize-set (form) (let ((var (car-safe (cdr-safe form)))) (cond @@ -1220,8 +1165,8 @@ length line-beginning-position line-end-position local-variable-if-set-p local-variable-p locale-info log log10 logand logb logcount logior lognot logxor lsh - make-list make-string make-symbol marker-buffer max member memq min - minibuffer-selected-window minibuffer-window + make-byte-code make-list make-string make-symbol marker-buffer max + member memq min minibuffer-selected-window minibuffer-window mod multibyte-char-to-unibyte next-window nth nthcdr number-to-string parse-colon-path plist-get plist-member prefix-numeric-value previous-window prin1-to-string propertize @@ -1296,9 +1241,9 @@ ;; Pure functions are side-effect free functions whose values depend ;; only on their arguments, not on the platform. For these functions, ;; calls with constant arguments can be evaluated at compile time. -;; This may shift runtime errors to compile time. For example, logand -;; is pure since its results are machine-independent, whereas ash is -;; not pure because (ash 1 29)'s value depends on machine word size. +;; For example, ash is pure since its results are machine-independent, +;; whereas lsh is not pure because (lsh -1 -1)'s value depends on the +;; fixnum range. ;; ;; When deciding whether a function is pure, do not worry about ;; mutable strings or markers, as they are so unlikely in real code @@ -1308,9 +1253,41 @@ ;; values if a marker is moved. (let ((pure-fns - '(% concat logand logcount logior lognot logxor - regexp-opt regexp-quote - string-to-char string-to-syntax symbol-name))) + '(concat regexp-opt regexp-quote + string-to-char string-to-syntax symbol-name + eq eql + = /= < <= => > min max + + - * / % mod abs ash 1+ 1- sqrt + logand logior lognot logxor logcount + copysign isnan ldexp float logb + floor ceiling round truncate + ffloor fceiling fround ftruncate + string= string-equal string< string-lessp + consp atom listp nlistp propert-list-p + sequencep arrayp vectorp stringp bool-vector-p hash-table-p + null not + numberp integerp floatp natnump characterp + integer-or-marker-p number-or-marker-p char-or-string-p + symbolp keywordp + type-of + identity ignore + + ;; The following functions are pure up to mutation of their + ;; arguments. This is pure enough for the purposes of + ;; constant folding, but not necessarily for all kinds of + ;; code motion. + car cdr car-safe cdr-safe nth nthcdr last + equal + length safe-length + memq memql member + ;; `assoc' and `assoc-default' are excluded since they are + ;; impure if the test function is (consider `string-match'). + assq rassq rassoc + plist-get lax-plist-get plist-member + aref elt + bool-vector-subsetp + bool-vector-count-population bool-vector-count-consecutive + ))) (while pure-fns (put (car pure-fns) 'pure t) (setq pure-fns (cdr pure-fns))) @@ -1510,13 +1487,13 @@ byte-current-buffer byte-stack-ref)) (defconst byte-compile-side-effect-free-ops - (nconc + (append '(byte-varref byte-nth byte-memq byte-car byte-cdr byte-length byte-aref byte-symbol-value byte-get byte-concat2 byte-concat3 byte-sub1 byte-add1 byte-eqlsign byte-gtr byte-lss byte-leq byte-geq byte-diff byte-negate byte-plus byte-max byte-min byte-mult byte-char-after byte-char-syntax byte-buffer-substring byte-string= byte-string< byte-nthcdr byte-elt - byte-member byte-assq byte-quo byte-rem) + byte-member byte-assq byte-quo byte-rem byte-substring) byte-compile-side-effect-and-error-free-ops)) ;; This crock is because of the way DEFVAR_BOOL variables work. @@ -2195,7 +2172,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (or noninteractive (message "compiling %s...done" x))) '(byte-optimize-form byte-optimize-body - byte-optimize-predicate + byte-optimize-constant-args byte-optimize-binary-predicate ;; Inserted some more than necessary, to speed it up. byte-optimize-form-code-walker diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 70fe06085dc..5279a57cd0c 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -82,65 +82,84 @@ The return value of this function is not used." ;; We define macro-declaration-alist here because it is needed to ;; handle declarations in macro definitions and this is the first file -;; loaded by loadup.el that uses declarations in macros. +;; loaded by loadup.el that uses declarations in macros. We specify +;; the values as named aliases so that `describe-variable' prints +;; something useful; cf. Bug#40491. We can only use backquotes inside +;; the lambdas and not for those properties that are used by functions +;; loaded before backquote.el. + +(defalias 'byte-run--set-advertised-calling-convention + #'(lambda (f _args arglist when) + (list 'set-advertised-calling-convention + (list 'quote f) (list 'quote arglist) (list 'quote when)))) + +(defalias 'byte-run--set-obsolete + #'(lambda (f _args new-name when) + (list 'make-obsolete + (list 'quote f) (list 'quote new-name) (list 'quote when)))) + +(defalias 'byte-run--set-interactive-only + #'(lambda (f _args instead) + (list 'function-put (list 'quote f) + ''interactive-only (list 'quote instead)))) + +(defalias 'byte-run--set-pure + #'(lambda (f _args val) + (list 'function-put (list 'quote f) + ''pure (list 'quote val)))) + +(defalias 'byte-run--set-side-effect-free + #'(lambda (f _args val) + (list 'function-put (list 'quote f) + ''side-effect-free (list 'quote val)))) + +(defalias 'byte-run--set-compiler-macro + #'(lambda (f args compiler-function) + (if (not (eq (car-safe compiler-function) 'lambda)) + `(eval-and-compile + (function-put ',f 'compiler-macro #',compiler-function)) + (let ((cfname (intern (concat (symbol-name f) "--anon-cmacro"))) + ;; Avoid cadr/cddr so we can use `compiler-macro' before + ;; defining cadr/cddr. + (data (cdr compiler-function))) + `(progn + (eval-and-compile + (function-put ',f 'compiler-macro #',cfname)) + ;; Don't autoload the compiler-macro itself, since the + ;; macroexpander will find this file via `f's autoload, + ;; if needed. + :autoload-end + (eval-and-compile + (defun ,cfname (,@(car data) ,@args) + ,@(cdr data)))))))) + +(defalias 'byte-run--set-doc-string + #'(lambda (f _args pos) + (list 'function-put (list 'quote f) + ''doc-string-elt (list 'quote pos)))) + +(defalias 'byte-run--set-indent + #'(lambda (f _args val) + (list 'function-put (list 'quote f) + ''lisp-indent-function (list 'quote val)))) ;; Add any new entries to info node `(elisp)Declare Form'. (defvar defun-declarations-alist (list - ;; We can only use backquotes inside the lambdas and not for those - ;; properties that are used by functions loaded before backquote.el. (list 'advertised-calling-convention - #'(lambda (f _args arglist when) - (list 'set-advertised-calling-convention - (list 'quote f) (list 'quote arglist) (list 'quote when)))) - (list 'obsolete - #'(lambda (f _args new-name when) - (list 'make-obsolete - (list 'quote f) (list 'quote new-name) (list 'quote when)))) - (list 'interactive-only - #'(lambda (f _args instead) - (list 'function-put (list 'quote f) - ''interactive-only (list 'quote instead)))) + #'byte-run--set-advertised-calling-convention) + (list 'obsolete #'byte-run--set-obsolete) + (list 'interactive-only #'byte-run--set-interactive-only) ;; FIXME: Merge `pure' and `side-effect-free'. - (list 'pure - #'(lambda (f _args val) - (list 'function-put (list 'quote f) - ''pure (list 'quote val))) + (list 'pure #'byte-run--set-pure "If non-nil, the compiler can replace calls with their return value. This may shift errors from run-time to compile-time.") - (list 'side-effect-free - #'(lambda (f _args val) - (list 'function-put (list 'quote f) - ''side-effect-free (list 'quote val))) + (list 'side-effect-free #'byte-run--set-side-effect-free "If non-nil, calls can be ignored if their value is unused. If `error-free', drop calls even if `byte-compile-delete-errors' is nil.") - (list 'compiler-macro - #'(lambda (f args compiler-function) - (if (not (eq (car-safe compiler-function) 'lambda)) - `(eval-and-compile - (function-put ',f 'compiler-macro #',compiler-function)) - (let ((cfname (intern (concat (symbol-name f) "--anon-cmacro"))) - ;; Avoid cadr/cddr so we can use `compiler-macro' before - ;; defining cadr/cddr. - (data (cdr compiler-function))) - `(progn - (eval-and-compile - (function-put ',f 'compiler-macro #',cfname)) - ;; Don't autoload the compiler-macro itself, since the - ;; macroexpander will find this file via `f's autoload, - ;; if needed. - :autoload-end - (eval-and-compile - (defun ,cfname (,@(car data) ,@args) - ,@(cdr data)))))))) - (list 'doc-string - #'(lambda (f _args pos) - (list 'function-put (list 'quote f) - ''doc-string-elt (list 'quote pos)))) - (list 'indent - #'(lambda (f _args val) - (list 'function-put (list 'quote f) - ''lisp-indent-function (list 'quote val))))) + (list 'compiler-macro #'byte-run--set-compiler-macro) + (list 'doc-string #'byte-run--set-doc-string) + (list 'indent #'byte-run--set-indent)) "List associating function properties to their macro expansion. Each element of the list takes the form (PROP FUN) where FUN is a function. For each (PROP . VALUES) in a function's declaration, @@ -150,18 +169,22 @@ to set this property. This is used by `declare'.") +(defalias 'byte-run--set-debug + #'(lambda (name _args spec) + (list 'progn :autoload-end + (list 'put (list 'quote name) + ''edebug-form-spec (list 'quote spec))))) + +(defalias 'byte-run--set-no-font-lock-keyword + #'(lambda (name _args val) + (list 'function-put (list 'quote name) + ''no-font-lock-keyword (list 'quote val)))) + (defvar macro-declarations-alist (cons - (list 'debug - #'(lambda (name _args spec) - (list 'progn :autoload-end - (list 'put (list 'quote name) - ''edebug-form-spec (list 'quote spec))))) + (list 'debug #'byte-run--set-debug) (cons - (list 'no-font-lock-keyword - #'(lambda (name _args val) - (list 'function-put (list 'quote name) - ''no-font-lock-keyword (list 'quote val)))) + (list 'no-font-lock-keyword #'byte-run--set-no-font-lock-keyword) defun-declarations-alist)) "List associating properties of macros to their macro expansion. Each element of the list takes the form (PROP FUN) where FUN is a function. @@ -553,13 +576,26 @@ Otherwise, return nil. For internal use only." (mapconcat (lambda (char) (format "`?\\%c'" char)) sorted ", "))))) +(defun byte-compile-info (string &optional message type) + "Format STRING in a way that looks pleasing in the compilation output. +If MESSAGE, output the message, too. + +If TYPE, it should be a string that says what the information +type is. This defaults to \"INFO\"." + (let ((string (format " %-9s%s" (or type "INFO") string))) + (when message + (message "%s" string)) + string)) + (defun byte-compile-info-string (&rest args) "Format ARGS in a way that looks pleasing in the compilation output." - (format " %-9s%s" "INFO" (apply #'format args))) + (declare (obsolete byte-compile-info "28.1")) + (byte-compile-info (apply #'format args))) (defun byte-compile-info-message (&rest args) "Message format ARGS in a way that looks pleasing in the compilation output." - (message "%s" (apply #'byte-compile-info-string args))) + (declare (obsolete byte-compile-info "28.1")) + (byte-compile-info (apply #'format args) t)) ;; I nuked this because it's not a good idea for users to think of using it. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 5479e6536a3..7ae8749ab40 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) @@ -2007,7 +2008,7 @@ The value is non-nil if there were no errors, nil if errors." (delete-file tempfile))) kill-emacs-hook))) (unless (= temp-modes desired-modes) - (set-file-modes tempfile desired-modes)) + (set-file-modes tempfile desired-modes 'nofollow)) (write-region (point-min) (point-max) tempfile nil 1) ;; This has the intentional side effect that any ;; hard-links to target-file continue to @@ -2139,55 +2140,13 @@ With argument ARG, insert value in current buffer after the form." ;; Make warnings about unresolved functions ;; give the end of the file as their position. (setq byte-compile-last-position (point-max)) - (byte-compile-warn-about-unresolved-functions)) - ;; Fix up the header at the front of the output - ;; if the buffer contains multibyte characters. - (and byte-compile-current-file - (with-current-buffer byte-compile--outbuffer - (byte-compile-fix-header byte-compile-current-file)))) + (byte-compile-warn-about-unresolved-functions))) byte-compile--outbuffer))) -(defun byte-compile-fix-header (_filename) - "If the current buffer has any multibyte characters, insert a version test." - (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)))) - (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)) @@ -2201,7 +2160,19 @@ Call from the source buffer." ;; 0 string ;ELC GNU Emacs Lisp compiled file, ;; >4 byte x version %d (insert - ";ELC" 23 "\000\000\000\n" + ";ELC" + (let ((version + (if (zerop emacs-minor-version) + ;; Let's allow silently loading into Emacs-27 + ;; files compiled with Emacs-28.0.NN since the two can + ;; be almost identical (e.g. right after cutting the + ;; release branch) and people running the development + ;; branch can be presumed to know that it's risky anyway. + (1- emacs-major-version) emacs-major-version))) + ;; Make sure the version is a plain byte that doesn't end the comment! + (cl-assert (and (> version 13) (< version 128))) + version) + "\000\000\000\n" ";;; Compiled\n" ";;; in Emacs version " emacs-version "\n" ";;; with" @@ -2213,19 +2184,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" - ;; 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" - ;; Insert semicolons as ballast, so that byte-compile-fix-header - ;; can delete them so as to keep the buffer positions - ;; constant for the actual compiled code. - ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n" - ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n\n")))) + "\n\n")))) (defun byte-compile-output-file-form (form) ;; Write the given form to the output buffer, being careful of docstrings @@ -3463,7 +3422,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))))) @@ -3491,7 +3450,7 @@ the opcode to be used. If function is a list, the first element is the function and the second element is the bytecode-symbol. The second element may be nil, meaning there is no opcode. COMPILE-HANDLER is the function to use to compile this byte-op, or -may be the abbreviations 0, 1, 2, 3, 0-1, or 1-2. +may be the abbreviations 0, 1, 2, 2-and, 3, 0-1, 1-2, 1-3, or 2-3. If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (let (opcode) (if (symbolp function) @@ -3510,6 +3469,7 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (0-1 . byte-compile-zero-or-one-arg) (1-2 . byte-compile-one-or-two-args) (2-3 . byte-compile-two-or-three-args) + (1-3 . byte-compile-one-to-three-args) ))) compile-handler (intern (concat "byte-compile-" @@ -3620,10 +3580,10 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (byte-defop-compiler (% byte-rem) 2) (byte-defop-compiler aset 3) -(byte-defop-compiler max byte-compile-associative) -(byte-defop-compiler min byte-compile-associative) -(byte-defop-compiler (+ byte-plus) byte-compile-associative) -(byte-defop-compiler (* byte-mult) byte-compile-associative) +(byte-defop-compiler max byte-compile-min-max) +(byte-defop-compiler min byte-compile-min-max) +(byte-defop-compiler (+ byte-plus) byte-compile-variadic-numeric) +(byte-defop-compiler (* byte-mult) byte-compile-variadic-numeric) ;;####(byte-defop-compiler move-to-column 1) (byte-defop-compiler-1 interactive byte-compile-noop) @@ -3694,6 +3654,13 @@ These implicitly `and' together a bunch of two-arg bytecodes." ((= len 4) (byte-compile-three-args form)) (t (byte-compile-subr-wrong-args form "2-3"))))) +(defun byte-compile-one-to-three-args (form) + (let ((len (length form))) + (cond ((= len 2) (byte-compile-three-args (append form '(nil nil)))) + ((= len 3) (byte-compile-three-args (append form '(nil)))) + ((= len 4) (byte-compile-three-args form)) + (t (byte-compile-subr-wrong-args form "1-3"))))) + (defun byte-compile-noop (_form) (byte-compile-constant nil)) @@ -3763,30 +3730,36 @@ discarding." (if byte-compile--for-effect (setq byte-compile--for-effect nil) (byte-compile-out 'byte-constant (nth 1 form)))) -;; Compile a function that accepts one or more args and is right-associative. -;; We do it by left-associativity so that the operations -;; are done in the same order as in interpreted code. -;; We treat the one-arg case, as in (+ x), like (+ x 0). -;; in order to convert markers to numbers, and trigger expected errors. -(defun byte-compile-associative (form) +;; Compile a pure function that accepts zero or more numeric arguments +;; and has an opcode for the binary case. +;; Single-argument calls are assumed to be numeric identity and are +;; compiled as (* x 1) in order to convert markers to numbers and +;; trigger type errors. +(defun byte-compile-variadic-numeric (form) + (pcase (length form) + (1 + ;; No args: use the identity value for the operation. + (byte-compile-constant (eval form))) + (2 + ;; One arg: compile (OP x) as (* x 1). This is identity for + ;; all numerical values including -0.0, infinities and NaNs. + (byte-compile-form (nth 1 form)) + (byte-compile-constant 1) + (byte-compile-out (get '* 'byte-opcode) 0)) + (3 + (byte-compile-form (nth 1 form)) + (byte-compile-form (nth 2 form)) + (byte-compile-out (get (car form) 'byte-opcode) 0)) + (_ + ;; >2 args: compile as a single function call. + (byte-compile-normal-call form)))) + +(defun byte-compile-min-max (form) + "Byte-compile calls to `min' or `max'." (if (cdr form) - (let ((opcode (get (car form) 'byte-opcode)) - args) - (if (and (< 3 (length form)) - (memq opcode (list (get '+ 'byte-opcode) - (get '* 'byte-opcode)))) - ;; Don't use binary operations for > 2 operands, as that - ;; may cause overflow/truncation in float operations. - (byte-compile-normal-call form) - (setq args (copy-sequence (cdr form))) - (byte-compile-form (car args)) - (setq args (cdr args)) - (or args (setq args '(0) - opcode (get '+ 'byte-opcode))) - (dolist (arg args) - (byte-compile-form arg) - (byte-compile-out opcode 0)))) - (byte-compile-constant (eval form)))) + (byte-compile-variadic-numeric form) + ;; No args: warn and emit code that raises an error when executed. + (byte-compile-normal-call form))) ;; more complicated compiler macros @@ -3801,7 +3774,7 @@ discarding." (byte-defop-compiler indent-to) (byte-defop-compiler insert) (byte-defop-compiler-1 function byte-compile-function-form) -(byte-defop-compiler-1 - byte-compile-minus) +(byte-defop-compiler (- byte-diff) byte-compile-minus) (byte-defop-compiler (/ byte-quo) byte-compile-quo) (byte-defop-compiler nconc) @@ -3868,30 +3841,17 @@ discarding." ((byte-compile-normal-call form))))) (defun byte-compile-minus (form) - (let ((len (length form))) - (cond - ((= 1 len) (byte-compile-constant 0)) - ((= 2 len) - (byte-compile-form (cadr form)) - (byte-compile-out 'byte-negate 0)) - ((= 3 len) - (byte-compile-form (nth 1 form)) - (byte-compile-form (nth 2 form)) - (byte-compile-out 'byte-diff 0)) - ;; Don't use binary operations for > 2 operands, as that may - ;; cause overflow/truncation in float operations. - (t (byte-compile-normal-call form))))) + (if (/= (length form) 2) + (byte-compile-variadic-numeric form) + (byte-compile-form (cadr form)) + (byte-compile-out 'byte-negate 0))) (defun byte-compile-quo (form) - (let ((len (length form))) - (cond ((< len 2) - (byte-compile-subr-wrong-args form "1 or more")) - ((= len 3) - (byte-compile-two-args form)) - (t - ;; Don't use binary operations for > 2 operands, as that - ;; may cause overflow/truncation in float operations. - (byte-compile-normal-call form))))) + (if (= (length form) 3) + (byte-compile-two-args form) + ;; N-ary `/' is not the left-reduction of binary `/' because if any + ;; argument is a float, then everything is done in floating-point. + (byte-compile-normal-call form))) (defun byte-compile-nconc (form) (let ((len (length form))) @@ -4530,96 +4490,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) @@ -4857,6 +4746,14 @@ binding slots have been popped." (defun byte-compile-form-make-variable-buffer-local (form) (byte-compile-keep-pending form 'byte-compile-normal-call)) +;; Make `make-local-variable' declare the variable locally +;; dynamic - this suppresses some unnecessary warnings +(byte-defop-compiler-1 make-local-variable + byte-compile-make-local-variable) +(defun byte-compile-make-local-variable (form) + (pcase form (`(,_ ',var) (byte-compile--declare-var var))) + (byte-compile-normal-call form)) + (put 'function-put 'byte-hunk-handler 'byte-compile-define-symbol-prop) (put 'define-symbol-prop 'byte-hunk-handler 'byte-compile-define-symbol-prop) (defun byte-compile-define-symbol-prop (form) 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/check-declare.el b/lisp/emacs-lisp/check-declare.el index 144385ea27c..208214f2e6e 100644 --- a/lisp/emacs-lisp/check-declare.el +++ b/lisp/emacs-lisp/check-declare.el @@ -1,8 +1,9 @@ -;;; check-declare.el --- Check declare-function statements +;;; check-declare.el --- Check declare-function statements -*- lexical-binding: t; -*- ;; Copyright (C) 2007-2020 Free Software Foundation, Inc. ;; Author: Glenn Morris <rgm@gnu.org> +;; Maintainer: emacs-devel@gnu.org ;; Keywords: lisp, tools, maint ;; This file is part of GNU Emacs. @@ -248,7 +249,7 @@ TYPE is a string giving the nature of the error. Optional LINE is the claim's line number; otherwise, search for the claim. Display warning in `check-declare-warning-buffer'." (let ((warning-prefix-function - (lambda (level entry) + (lambda (_level entry) (insert (format "%s:%d:" (file-relative-name file) (or line 0))) entry)) (warning-fill-prefix " ")) diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index 797493743c0..1029b52220d 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -3,7 +3,7 @@ ;; Copyright (C) 1997-1998, 2001-2020 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> -;; Version: 0.6.2 +;; Old-Version: 0.6.2 ;; Keywords: docs, maint, lisp ;; This file is part of GNU Emacs. @@ -170,6 +170,7 @@ ;;; Code: (defvar checkdoc-version "0.6.2" "Release version of checkdoc you are currently running.") +(make-obsolete-variable 'checkdoc-version nil "28.1") (require 'cl-lib) (require 'help-mode) ;; for help-xref-info-regexp @@ -1248,13 +1249,8 @@ checking of documentation strings. ;;; Subst utils ;; -(defsubst checkdoc-run-hooks (hookvar &rest args) - "Run hooks in HOOKVAR with ARGS." - (if (fboundp 'run-hook-with-args-until-success) - (apply #'run-hook-with-args-until-success hookvar args) - ;; This method was similar to above. We ignore the warning - ;; since we will use the above for future Emacs versions - (apply #'run-hook-with-args hookvar args))) +(define-obsolete-function-alias 'checkdoc-run-hooks + #'run-hook-with-args-until-success "28.1") (defsubst checkdoc-create-common-verbs-regexp () "Rebuild the contents of `checkdoc-common-verbs-regexp'." @@ -1872,7 +1868,7 @@ Replace with \"%s\"? " original replace) ;; and reliance on the Ispell program. (checkdoc-ispell-docstring-engine e take-notes) ;; User supplied checks - (save-excursion (checkdoc-run-hooks 'checkdoc-style-functions fp e)) + (save-excursion (run-hook-with-args-until-success 'checkdoc-style-functions fp e)) ;; Done! ))) @@ -2383,7 +2379,7 @@ Code:, and others referenced in the style guide." err (or ;; Generic Full-file checks (should be comment related) - (checkdoc-run-hooks 'checkdoc-comment-style-functions) + (run-hook-with-args-until-success 'checkdoc-comment-style-functions) err)) ;; Done with full file comment checks err))) @@ -2642,7 +2638,7 @@ function called to create the messages." (goto-char (point-max)) (let ((inhibit-read-only t)) (insert "\n\n\C-l\n*** " label ": " - check-type " V " checkdoc-version))))) + check-type))))) (defun checkdoc-error (point msg) "Store POINT and MSG as errors in the checkdoc diagnostic buffer." diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index ce6fb625bc0..5bf74792c08 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -72,8 +72,7 @@ strings case-insensitively." (cond ((eq x y) t) ((stringp x) (and (stringp y) (= (length x) (length y)) - (or (string-equal x y) - (string-equal (downcase x) (downcase y))))) ;Lazy but simple! + (eq (compare-strings x nil nil y nil nil t) t))) ((numberp x) (and (numberp y) (= x y))) ((consp x) @@ -553,10 +552,9 @@ too large if positive or too small if negative)." (seq-subseq seq start end)) ;;;###autoload -(defun cl-concatenate (type &rest sequences) +(defalias 'cl-concatenate #'seq-concatenate "Concatenate, into a sequence of type TYPE, the argument SEQUENCEs. -\n(fn TYPE SEQUENCE...)" - (apply #'seq-concatenate type sequences)) +\n(fn TYPE SEQUENCE...)") ;;; List functions. diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 4e8423eb5b1..02da07daaf4 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -211,7 +211,16 @@ DEFAULT-BODY, if present, is used as the body of a default method. [&rest [&or ("declare" &rest sexp) (":argument-precedence-order" &rest sexp) - (&define ":method" [&rest atom] + (&define ":method" + ;; FIXME: The `:unique' + ;; construct works around + ;; Bug#42672. We'd rather want + ;; names like those generated by + ;; `cl-defmethod', but that + ;; requires larger changes to + ;; Edebug. + :unique "cl-generic-:method@" + [&rest cl-generic-method-qualifier] cl-generic-method-args lambda-doc def-body)]] def-body))) @@ -432,9 +441,8 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (&define ; this means we are defining something [&or name ("setf" name :name setf)] ;; ^^ This is the methods symbol - [ &rest atom ] ; Multiple qualifiers are allowed. - ; Like in CLOS spec, we support - ; any non-list values. + [ &rest cl-generic-method-qualifier ] + ;; Multiple qualifiers are allowed. cl-generic-method-args ; arguments lambda-doc ; documentation string def-body))) ; part to be debugged diff --git a/lisp/emacs-lisp/cl-indent.el b/lisp/emacs-lisp/cl-indent.el index fd8715962a3..66502da668a 100644 --- a/lisp/emacs-lisp/cl-indent.el +++ b/lisp/emacs-lisp/cl-indent.el @@ -46,14 +46,12 @@ "Maximum depth to backtrack out from a sublist for structured indentation. If this variable is 0, no backtracking will occur and forms such as `flet' may not be correctly indented." - :type 'integer - :group 'lisp-indent) + :type 'integer) (defcustom lisp-tag-indentation 1 "Indentation of tags relative to containing list. This variable is used by the function `lisp-indent-tagbody'." - :type 'integer - :group 'lisp-indent) + :type 'integer) (defcustom lisp-tag-body-indentation 3 "Indentation of non-tagged lines relative to containing list. @@ -64,32 +62,30 @@ the special form. If the value is t, the body of tags will be indented as a block at the same indentation as the first s-expression following the tag. In this case, any forms before the first tag are indented by `lisp-body-indent'." - :type 'integer - :group 'lisp-indent) + :type 'integer) (defcustom lisp-backquote-indentation t "Whether or not to indent backquoted lists as code. If nil, indent backquoted lists as data, i.e., like quoted lists." - :type 'boolean - :group 'lisp-indent) + :type 'boolean) -(defcustom lisp-loop-keyword-indentation 3 +(defcustom lisp-loop-keyword-indentation 6 "Indentation of loop keywords in extended loop forms." :type 'integer - :group 'lisp-indent) + :version "28.1") -(defcustom lisp-loop-forms-indentation 5 +(defcustom lisp-loop-forms-indentation 6 "Indentation of forms in extended loop forms." :type 'integer - :group 'lisp-indent) + :version "28.1") -(defcustom lisp-simple-loop-indentation 3 +(defcustom lisp-simple-loop-indentation 1 "Indentation of forms in simple loop forms." :type 'integer - :group 'lisp-indent) + :version "28.1") (defcustom lisp-lambda-list-keyword-alignment nil "Whether to vertically align lambda-list keywords together. @@ -107,16 +103,14 @@ If non-nil, alignment is done with the first keyword &key key1 key2) #|...|#)" :version "24.1" - :type 'boolean - :group 'lisp-indent) + :type 'boolean) (defcustom lisp-lambda-list-keyword-parameter-indentation 2 "Indentation of lambda list keyword parameters. See `lisp-lambda-list-keyword-parameter-alignment' for more information." :version "24.1" - :type 'integer - :group 'lisp-indent) + :type 'integer) (defcustom lisp-lambda-list-keyword-parameter-alignment nil "Whether to vertically align lambda-list keyword parameters together. @@ -135,8 +129,7 @@ If non-nil, alignment is done with the first parameter key3 key4) #|...|#)" :version "24.1" - :type 'boolean - :group 'lisp-indent) + :type 'boolean) (defcustom lisp-indent-backquote-substitution-mode t "How to indent substitutions in backquotes. @@ -148,8 +141,7 @@ In any case, do not backtrack beyond a backquote substitution. Until Emacs 25.1, the nil behavior was hard-wired." :version "25.1" - :type '(choice (const corrected) (const nil) (const t)) - :group 'lisp-indent) + :type '(choice (const corrected) (const nil) (const t))) (defvar lisp-indent-defun-method '(4 &lambda &body) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 78d083fcc63..c38019d4a73 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -75,7 +75,7 @@ ;; one, you may want to amend the other, too. ;;;###autoload (define-obsolete-function-alias 'cl--compiler-macro-cXXr - 'internal--compiler-macro-cXXr "25.1") + #'internal--compiler-macro-cXXr "25.1") ;;; Some predicates for analyzing Lisp forms. ;; These are used by various @@ -199,7 +199,7 @@ The name is made by appending a number to PREFIX, default \"T\"." [&optional ["&key" [cl-&key-arg &rest cl-&key-arg] &optional "&allow-other-keys"]] [&optional ["&aux" &rest - &or (symbolp &optional def-form) symbolp]] + &or (cl-lambda-arg &optional def-form) arg]] . [&or arg nil]))) (def-edebug-spec cl-&optional-arg @@ -219,7 +219,7 @@ The name is made by appending a number to PREFIX, default \"T\"." [&optional ["&key" cl-&key-arg &rest cl-&key-arg &optional "&allow-other-keys"]] [&optional ["&aux" &rest - &or (symbolp &optional def-form) symbolp]] + &or (cl-lambda-arg &optional def-form) arg]] . [&or arg nil]))) (def-edebug-spec cl-type-spec sexp) @@ -328,8 +328,7 @@ FORM is of the form (ARGS . BODY)." (setq cl--bind-lets (nreverse cl--bind-lets)) ;; (cl-assert (eq :dummy (nth 1 (car cl--bind-lets)))) (list '&rest (car (pop cl--bind-lets)))))))) - `(nil - (,@(nreverse simple-args) ,@rest-args) + `((,@(nreverse simple-args) ,@rest-args) ,@header ,(macroexp-let* cl--bind-lets (macroexp-progn @@ -366,9 +365,7 @@ more details. def-body)) (doc-string 3) (indent 2)) - (let* ((res (cl--transform-lambda (cons args body) name)) - (form `(defun ,name ,@(cdr res)))) - (if (car res) `(progn ,(car res) ,form) form))) + `(defun ,name ,@(cl--transform-lambda (cons args body) name))) ;;;###autoload (defmacro cl-iter-defun (name args &rest body) @@ -387,9 +384,7 @@ and BODY is implicitly surrounded by (cl-block NAME ...). (doc-string 3) (indent 2)) (require 'generator) - (let* ((res (cl--transform-lambda (cons args body) name)) - (form `(iter-defun ,name ,@(cdr res)))) - (if (car res) `(progn ,(car res) ,form) form))) + `(iter-defun ,name ,@(cl--transform-lambda (cons args body) name))) ;; The lambda list for macros is different from that of normal lambdas. ;; Note that &environment is only allowed as first or last items in the @@ -407,7 +402,7 @@ and BODY is implicitly surrounded by (cl-block NAME ...). arg]] &optional "&allow-other-keys"]] [&optional ["&aux" &rest - &or (symbolp &optional def-form) symbolp]] + &or (cl-macro-arg &optional def-form) arg]] [&optional "&environment" arg] ))) @@ -426,7 +421,7 @@ and BODY is implicitly surrounded by (cl-block NAME ...). arg]] &optional "&allow-other-keys"]] [&optional ["&aux" &rest - &or (symbolp &optional def-form) symbolp]] + &or (cl-macro-arg &optional def-form) arg]] . [&or arg nil]))) ;;;###autoload @@ -455,9 +450,7 @@ more details. (&define name cl-macro-list cl-declarations-or-string def-body)) (doc-string 3) (indent 2)) - (let* ((res (cl--transform-lambda (cons args body) name)) - (form `(defmacro ,name ,@(cdr res)))) - (if (car res) `(progn ,(car res) ,form) form))) + `(defmacro ,name ,@(cl--transform-lambda (cons args body) name))) (def-edebug-spec cl-lambda-expr (&define ("lambda" cl-lambda-list @@ -480,9 +473,7 @@ Like normal `function', except that if argument is a lambda form, its argument list allows full Common Lisp conventions." (declare (debug (&or symbolp cl-lambda-expr))) (if (eq (car-safe func) 'lambda) - (let* ((res (cl--transform-lambda (cdr func) 'cl-none)) - (form `(function (lambda . ,(cdr res))))) - (if (car res) `(progn ,(car res) ,form) form)) + `(function (lambda . ,(cl--transform-lambda (cdr func) 'cl-none))) `(function ,func))) (defun cl--make-usage-var (x) @@ -723,9 +714,9 @@ If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level. (let ((comp (or (memq 'compile when) (memq :compile-toplevel when))) (cl--not-toplevel t)) (if (or (memq 'load when) (memq :load-toplevel when)) - (if comp (cons 'progn (mapcar 'cl--compile-time-too body)) + (if comp (cons 'progn (mapcar #'cl--compile-time-too body)) `(if nil nil ,@body)) - (progn (if comp (eval (cons 'progn body))) nil))) + (progn (if comp (eval (cons 'progn body) lexical-binding)) nil))) (and (or (memq 'eval when) (memq :execute when)) (cons 'progn body)))) @@ -734,13 +725,13 @@ If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level. (setq form (macroexpand form (cons '(cl-eval-when) byte-compile-macro-environment)))) (cond ((eq (car-safe form) 'progn) - (cons 'progn (mapcar 'cl--compile-time-too (cdr form)))) + (cons 'progn (mapcar #'cl--compile-time-too (cdr form)))) ((eq (car-safe form) 'cl-eval-when) (let ((when (nth 1 form))) (if (or (memq 'eval when) (memq :execute when)) `(cl-eval-when (compile ,@when) ,@(cddr form)) form))) - (t (eval form) form))) + (t (eval form lexical-binding) form))) ;;;###autoload (defmacro cl-load-time-value (form &optional _read-only) @@ -766,7 +757,7 @@ The result of the body appears to the compiler as a quoted constant." ;; temp is set before we use it. (print set byte-compile--outbuffer)) temp) - `',(eval form))) + `',(eval form lexical-binding))) ;;; Conditional control structures. @@ -889,7 +880,7 @@ This is compatible with Common Lisp, but note that `defun' and ;;; The "cl-loop" macro. (defvar cl--loop-args) (defvar cl--loop-accum-var) (defvar cl--loop-accum-vars) -(defvar cl--loop-bindings) (defvar cl--loop-body) +(defvar cl--loop-bindings) (defvar cl--loop-body) (defvar cl--loop-conditions) (defvar cl--loop-finally) (defvar cl--loop-finish-flag) ;Symbol set to nil to exit the loop? (defvar cl--loop-first-flag) @@ -966,7 +957,8 @@ For more details, see Info node `(cl)Loop Facility'. (cl--loop-accum-var nil) (cl--loop-accum-vars nil) (cl--loop-initially nil) (cl--loop-finally nil) (cl--loop-iterator-function nil) (cl--loop-first-flag nil) - (cl--loop-symbol-macs nil)) + (cl--loop-symbol-macs nil) + (cl--loop-conditions nil)) ;; Here is more or less how those dynbind vars are used after looping ;; over cl--parse-loop-clause: ;; @@ -1034,6 +1026,13 @@ For more details, see Info node `(cl)Loop Facility'. (list `(cl-symbol-macrolet ,cl--loop-symbol-macs ,@body)))) `(cl-block ,cl--loop-name ,@body))))) +(defmacro cl--push-clause-loop-body (clause) + "Apply CLAUSE to both `cl--loop-conditions' and `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 ;; the forms are; it also specifies, as much as Edebug allows, all the @@ -1184,8 +1183,6 @@ For more details, see Info node `(cl)Loop Facility'. ;; (def-edebug-spec loop-d-type-spec ;; (&or (loop-d-type-spec . [&or nil loop-d-type-spec]) cl-type-spec)) - - (defun cl--parse-loop-clause () ; uses loop-* (let ((word (pop cl--loop-args)) (hash-types '(hash-key hash-keys hash-value hash-values)) @@ -1264,11 +1261,11 @@ For more details, see Info node `(cl)Loop Facility'. (if end-var (push (list end-var end) loop-for-bindings)) (if step-var (push (list step-var step) loop-for-bindings)) - (if end - (push (list - (if down (if excl '> '>=) (if excl '< '<=)) - var (or end-var end)) - cl--loop-body)) + (when end + (cl--push-clause-loop-body + (list + (if down (if excl '> '>=) (if excl '< '<=)) + var (or end-var end)))) (push (list var (list (if down '- '+) var (or step-var step 1))) loop-for-steps))) @@ -1278,7 +1275,7 @@ For more details, see Info node `(cl)Loop Facility'. (temp (if (and on (symbolp var)) var (make-symbol "--cl-var--")))) (push (list temp (pop cl--loop-args)) loop-for-bindings) - (push `(consp ,temp) cl--loop-body) + (cl--push-clause-loop-body `(consp ,temp)) (if (eq word 'in-ref) (push (list var `(car ,temp)) cl--loop-symbol-macs) (or (eq temp var) @@ -1301,33 +1298,31 @@ For more details, see Info node `(cl)Loop Facility'. ((eq word '=) (let* ((start (pop cl--loop-args)) (then (if (eq (car cl--loop-args) 'then) - (cl--pop2 cl--loop-args) start))) + (cl--pop2 cl--loop-args) start)) + (first-assign (or cl--loop-first-flag + (setq cl--loop-first-flag + (make-symbol "--cl-var--"))))) (push (list var nil) loop-for-bindings) (if (or ands (eq (car cl--loop-args) 'and)) (progn - (push `(,var - (if ,(or cl--loop-first-flag - (setq cl--loop-first-flag - (make-symbol "--cl-var--"))) - ,start ,var)) - loop-for-sets) - (push (list var then) loop-for-steps)) - (push (list var - (if (eq start then) start - `(if ,(or cl--loop-first-flag - (setq cl--loop-first-flag - (make-symbol "--cl-var--"))) - ,start ,then))) - loop-for-sets)))) + (push `(,var (if ,first-assign ,start ,var)) loop-for-sets) + (push `(,var (if ,(car (cl--loop-build-ands + (nreverse cl--loop-conditions))) + ,then ,var)) + loop-for-steps)) + (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--")) (temp-idx (make-symbol "--cl-idx--"))) (push (list temp-vec (pop cl--loop-args)) loop-for-bindings) (push (list temp-idx -1) loop-for-bindings) - (push `(< (setq ,temp-idx (1+ ,temp-idx)) - (length ,temp-vec)) - cl--loop-body) + (push `(setq ,temp-idx (1+ ,temp-idx)) cl--loop-body) + (cl--push-clause-loop-body + `(< ,temp-idx (length ,temp-vec))) (if (eq word 'across-ref) (push (list var `(aref ,temp-vec ,temp-idx)) cl--loop-symbol-macs) @@ -1351,17 +1346,16 @@ For more details, see Info node `(cl)Loop Facility'. (push (list temp-seq seq) loop-for-bindings) (push (list temp-idx 0) loop-for-bindings) (if ref - (let ((temp-len (make-symbol "--cl-len--"))) + (let ((temp-len (make-symbol "--cl-len--"))) (push (list temp-len `(length ,temp-seq)) loop-for-bindings) (push (list var `(elt ,temp-seq ,temp-idx)) cl--loop-symbol-macs) - (push `(< ,temp-idx ,temp-len) cl--loop-body)) + (cl--push-clause-loop-body `(< ,temp-idx ,temp-len))) (push (list var nil) loop-for-bindings) - (push `(and ,temp-seq - (or (consp ,temp-seq) - (< ,temp-idx (length ,temp-seq)))) - cl--loop-body) + (cl--push-clause-loop-body `(and ,temp-seq + (or (consp ,temp-seq) + (< ,temp-idx (length ,temp-seq))))) (push (list var `(if (consp ,temp-seq) (pop ,temp-seq) (aref ,temp-seq ,temp-idx))) @@ -1457,9 +1451,8 @@ For more details, see Info node `(cl)Loop Facility'. (push (list var '(selected-frame)) loop-for-bindings) (push (list temp nil) loop-for-bindings) - (push `(prog1 (not (eq ,var ,temp)) - (or ,temp (setq ,temp ,var))) - cl--loop-body) + (cl--push-clause-loop-body `(prog1 (not (eq ,var ,temp)) + (or ,temp (setq ,temp ,var)))) (push (list var `(next-frame ,var)) loop-for-steps))) @@ -1480,9 +1473,8 @@ For more details, see Info node `(cl)Loop Facility'. (push (list minip `(minibufferp (window-buffer ,var))) loop-for-bindings) (push (list temp nil) loop-for-bindings) - (push `(prog1 (not (eq ,var ,temp)) - (or ,temp (setq ,temp ,var))) - cl--loop-body) + (cl--push-clause-loop-body `(prog1 (not (eq ,var ,temp)) + (or ,temp (setq ,temp ,var)))) (push (list var `(next-window ,var ,minip)) loop-for-steps))) @@ -1498,17 +1490,17 @@ For more details, see Info node `(cl)Loop Facility'. (pop cl--loop-args)) (if (and ands loop-for-bindings) (push (nreverse loop-for-bindings) cl--loop-bindings) - (setq cl--loop-bindings (nconc (mapcar 'list loop-for-bindings) - cl--loop-bindings))) + (setq cl--loop-bindings (nconc (mapcar #'list loop-for-bindings) + cl--loop-bindings))) (if loop-for-sets (push `(progn ,(cl--loop-let (nreverse loop-for-sets) 'setq ands) t) cl--loop-body)) - (if loop-for-steps - (push (cons (if ands 'cl-psetq 'setq) - (apply 'append (nreverse loop-for-steps))) - cl--loop-steps)))) + (when loop-for-steps + (push (cons (if ands 'cl-psetq 'setq) + (apply #'append (nreverse loop-for-steps))) + cl--loop-steps)))) ((eq word 'repeat) (let ((temp (make-symbol "--cl-var--"))) @@ -1700,7 +1692,7 @@ If BODY is `setq', then use SPECS for assignments rather than for bindings." (push binding new)))) (if (eq body 'setq) (let ((set (cons (if par 'cl-psetq 'setq) - (apply 'nconc (nreverse new))))) + (apply #'nconc (nreverse new))))) (if temps `(let* ,(nreverse temps) ,set) set)) `(,(if par 'let 'let*) ,(nconc (nreverse temps) (nreverse new)) ,@body)))) @@ -1826,7 +1818,7 @@ For more details, see `cl-do*' description in Info node `(cl) Iteration'. (and sets (list (cons (if (or star (not (cdr sets))) 'setq 'cl-psetq) - (apply 'append sets)))))) + (apply #'append sets)))))) ,@(or (cdr endtest) '(nil))))) ;;;###autoload @@ -2024,7 +2016,12 @@ info node `(cl) Function Bindings' for details. \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" (declare (indent 1) - (debug ((&rest [&or (&define name function-form) (cl-defun)]) + (debug ((&rest [&or (&define name :unique "cl-flet@" function-form) + (&define name :unique "cl-flet@" + cl-lambda-list + cl-declarations-or-string + [&optional ("interactive" interactive)] + def-body)]) cl-declarations body))) (let ((binds ()) (newenv macroexpand-all-environment)) (dolist (binding bindings) @@ -2105,10 +2102,9 @@ This is like `cl-flet', but for macros instead of functions. (if (null bindings) (macroexp-progn body) (let* ((name (caar bindings)) (res (cl--transform-lambda (cdar bindings) name))) - (eval (car res)) (macroexpand-all (macroexp-progn body) (cons (cons name - (eval `(cl-function (lambda ,@(cdr res))) t)) + (eval `(function (lambda ,@res)) t)) macroexpand-all-environment)))))) (defun cl--sm-macroexpand (orig-fun exp &optional env) @@ -2472,7 +2468,7 @@ Each PLACE may be a symbol, or any generalized variable allowed by `setf'. \(fn PLACE...)" (declare (debug (&rest place))) - (if (not (memq nil (mapcar 'symbolp args))) + (if (not (memq nil (mapcar #'symbolp args))) (and (cdr args) (let ((sets nil) (first (car args))) @@ -2872,7 +2868,9 @@ Supported keywords for slots are: (append pred-form '(t)) `(and ,pred-form t))) forms) - (push `(put ',name 'cl-deftype-satisfies ',predicate) forms)) + (push `(eval-and-compile + (put ',name 'cl-deftype-satisfies ',predicate)) + forms)) (let ((pos 0) (descp descs)) (while descp (let* ((desc (pop descp)) @@ -2972,14 +2970,26 @@ Supported keywords for slots are: (pcase-dolist (`(,cname ,args ,doc) constrs) (let* ((anames (cl--arglist-args args)) (make (cl-mapcar (function (lambda (s d) (if (memq s anames) s d))) - slots defaults))) - (push `(,cldefsym ,cname + slots defaults)) + ;; `cl-defsubst' is fundamentally broken: it substitutes + ;; its arguments into the body's `sexp' much too naively + ;; when inlinling, which results in various problems. + ;; For example it generates broken code if your + ;; argument's name happens to be the same as some + ;; function used within the body. + ;; E.g. (cl-defsubst sm-foo (list) (list list)) + ;; will expand `(sm-foo 1)' to `(1 1)' rather than to `(list t)'! + ;; Try to catch this known case! + (con-fun (or type #'record)) + (unsafe-cl-defsubst + (or (memq con-fun args) (assq con-fun args)))) + (push `(,(if unsafe-cl-defsubst 'cl-defun cldefsym) ,cname (&cl-defs (nil ,@descs) ,@args) ,(if (stringp doc) doc (format "Constructor for objects of type `%s'." name)) ,@(if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs))) '((declare (side-effect-free t)))) - (,(or type #'record) ,@make)) + (,con-fun ,@make)) forms))) (if print-auto (nconc print-func (list '(princ ")" cl-s) t))) ;; Don't bother adding to cl-custom-print-functions since it's not used @@ -3132,13 +3142,34 @@ Of course, we really can't know that for sure, so it's just a heuristic." (or (cdr (assq sym byte-compile-function-environment)) (cdr (assq sym byte-compile-macro-environment)))))) -(put 'null 'cl-deftype-satisfies #'null) -(put 'atom 'cl-deftype-satisfies #'atom) -(put 'real 'cl-deftype-satisfies #'numberp) -(put 'fixnum 'cl-deftype-satisfies #'integerp) -(put 'base-char 'cl-deftype-satisfies #'characterp) -(put 'character 'cl-deftype-satisfies #'natnump) - +(pcase-dolist (`(,type . ,pred) + ;; Mostly kept in alphabetical order. + '((array . arrayp) + (atom . atom) + (base-char . characterp) + (boolean . booleanp) + (bool-vector . bool-vector-p) + (buffer . bufferp) + (character . natnump) + (char-table . char-table-p) + (cons . consp) + (fixnum . integerp) + (float . floatp) + (function . functionp) + (integer . integerp) + (keyword . keywordp) + (list . listp) + (number . numberp) + (null . null) + (real . numberp) + (sequence . sequencep) + (string . stringp) + (symbol . symbolp) + (vector . vectorp) + ;; FIXME: Do we really want to consider this a type? + (integer-or-marker . integer-or-marker-p) + )) + (put type 'cl-deftype-satisfies pred)) ;;;###autoload (define-inline cl-typep (val type) @@ -3207,7 +3238,10 @@ STRING is an optional description of the desired type." (macroexp-let2 macroexp-copyable-p temp form `(progn (or (cl-typep ,temp ',type) (signal 'wrong-type-argument - (list ,(or string `',type) ,temp ',form))) + (list ,(or string `',(if (eq 'satisfies + (car-safe type)) + (cadr type) type)) + ,temp ',form))) nil)))) ;;;###autoload diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index a0bc6562bc9..d9bbf6129c6 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -555,7 +555,7 @@ already is one.)" ;; Compatibility with old versions. -(defalias 'edebug-all-defuns 'edebug-all-defs) +(define-obsolete-function-alias 'edebug-all-defuns #'edebug-all-defs "28.1") ;;;###autoload (defun edebug-all-defs () @@ -741,6 +741,21 @@ Maybe clear the markers and delete the symbol's edebug property?" ;;; Offsets for reader +(defun edebug-get-edebug-or-ghost (name) + "Get NAME's value of property `edebug' or property `ghost-edebug'. + +The idea is that should function NAME be recompiled whilst +debugging is in progress, property `edebug' will get set to a +marker. The needed data will then come from property +`ghost-edebug'." + (let ((e (get name 'edebug))) + (if (consp e) + e + (let ((g (get name 'ghost-edebug))) + (if (consp g) + g + e))))) + ;; Define a structure to represent offset positions of expressions. ;; Each offset structure looks like: (before . after) for constituents, ;; or for structures that have elements: (before <subexpressions> . after) @@ -1168,6 +1183,12 @@ purpose by adding an entry to this alist, and setting ;; Not edebugging this form, so reset the symbol's edebug ;; property to be just a marker at the definition's source code. ;; This only works for defs with simple names. + + ;; Preserve the `edebug' property in case there's + ;; debugging still under way. + (let ((ghost (get def-name 'edebug))) + (if (consp ghost) + (put def-name 'ghost-edebug ghost))) (put def-name 'edebug (point-marker)) ;; Also nil out dependent defs. '(mapcar (function @@ -1219,6 +1240,13 @@ purpose by adding an entry to this alist, and setting ;; since it wraps the list of forms with a call to `edebug-enter'. ;; Uses the dynamically bound vars edebug-def-name and edebug-def-args. ;; Do this after parsing since that may find a name. + (when (string-match-p (rx bos "edebug-anon" (+ digit) eos) + (symbol-name edebug-old-def-name)) + ;; FIXME: Due to Bug#42701, we reset an anonymous name so that + ;; backtracking doesn't generate duplicate definitions. It would + ;; be better to not define wrappers in the case of a non-matching + ;; specification branch to begin with. + (setq edebug-old-def-name nil)) (setq edebug-def-name (or edebug-def-name edebug-old-def-name (gensym "edebug-anon"))) `(edebug-enter @@ -1411,6 +1439,8 @@ contains a circular object." (cons window (window-start window))))) ;; Store the edebug data in symbol's property list. + ;; We actually want to remove this property entirely, but can't. + (put edebug-def-name 'ghost-edebug nil) (put edebug-def-name 'edebug ;; A struct or vector would be better here!! (list edebug-form-begin-marker @@ -1423,8 +1453,8 @@ contains a circular object." ))) (defun edebug--restore-breakpoints (name) - (let ((data (get name 'edebug))) - (when (listp data) + (let ((data (edebug-get-edebug-or-ghost name))) + (when (consp data) (let ((offsets (nth 2 data)) (breakpoints (nth 1 data)) (start (nth 0 data)) @@ -1702,18 +1732,22 @@ contains a circular object." (&define . edebug-match-&define) (name . edebug-match-name) (:name . edebug-match-colon-name) + (:unique . edebug-match-:unique) (arg . edebug-match-arg) (def-body . edebug-match-def-body) (def-form . edebug-match-def-form) ;; Less frequently used: ;; (function . edebug-match-function) (lambda-expr . edebug-match-lambda-expr) + (cl-generic-method-qualifier + . edebug-match-cl-generic-method-qualifier) (cl-generic-method-args . edebug-match-cl-generic-method-args) (cl-macrolet-expr . edebug-match-cl-macrolet-expr) (cl-macrolet-name . edebug-match-cl-macrolet-name) (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. @@ -1832,9 +1866,6 @@ contains a circular object." ;; This means nothing matched, so it is OK. nil) ;; So, return nothing - -(def-edebug-spec &key edebug-match-&key) - (defun edebug-match-&key (cursor specs) ;; Following specs must look like (<name> <spec>) ... ;; where <name> is the name of a keyword, and spec is its spec. @@ -1847,6 +1878,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. @@ -2005,6 +2045,27 @@ contains a circular object." spec)) nil) +(defun edebug-match-:unique (_cursor spec) + "Match a `:unique PREFIX' specifier. +SPEC is the symbol name prefix for `gensym'." + (let ((suffix (gensym spec))) + (setq edebug-def-name + (if edebug-def-name + ;; Construct a new name by appending to previous name. + (intern (format "%s@%s" edebug-def-name suffix)) + suffix))) + nil) + +(defun edebug-match-cl-generic-method-qualifier (cursor) + "Match a QUALIFIER for `cl-defmethod' at CURSOR." + (let ((args (edebug-top-element-required cursor "Expected qualifier"))) + ;; Like in CLOS spec, we support any non-list values. + (unless (atom args) (edebug-no-match cursor "Atom expected")) + ;; Append the arguments to `edebug-def-name' (Bug#42671). + (setq edebug-def-name (intern (format "%s %s" edebug-def-name args))) + (edebug-move-cursor cursor) + (list args))) + (defun edebug-match-cl-generic-method-args (cursor) (let ((args (edebug-top-element-required cursor "Expected arguments"))) (if (not (consp args)) @@ -2105,10 +2166,10 @@ into `edebug--cl-macrolet-defs' which is checked in `edebug-list-form-args'." (def-edebug-spec edebug-spec (&or + edebug-spec-list (vector &rest edebug-spec) ; matches a vector ("vector" &rest edebug-spec) ; matches a vector spec ("quote" symbolp) - edebug-spec-list stringp [edebug-lambda-list-keywordp &rest edebug-spec] [keywordp gate edebug-spec] @@ -2216,6 +2277,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) @@ -2755,6 +2818,7 @@ See `edebug-behavior-alist' for implementations.") (edebug-stop)) (edebug-overlay-arrow) + (edebug--overlay-breakpoints edebug-function) (unwind-protect (if (or edebug-stop @@ -2832,7 +2896,6 @@ See `edebug-behavior-alist' for implementations.") (if (not (eq edebug-buffer edebug-outside-buffer)) (goto-char edebug-outside-point)) (if (marker-buffer (edebug-mark-marker)) - ;; Does zmacs-regions need to be nil while doing set-marker? (set-marker (edebug-mark-marker) edebug-outside-mark)) )) ; unwind-protect ;; None of the following is done if quit or signal occurs. @@ -2844,6 +2907,7 @@ See `edebug-behavior-alist' for implementations.") (goto-char edebug-buffer-outside-point)) ;; ... nothing more. ) + (edebug--overlay-breakpoints-remove (point-min) (point-max)) ;; Could be an option to keep eval display up. (if edebug-eval-buffer (kill-buffer edebug-eval-buffer)) (with-timeout-unsuspend edebug-with-timeout-suspend) @@ -3118,7 +3182,7 @@ before returning. The default is one second." ;; Return (function . index) of the nearest edebug stop point. (let* ((edebug-def-name (edebug-form-data-symbol)) (edebug-data - (let ((data (get edebug-def-name 'edebug))) + (let ((data (edebug-get-edebug-or-ghost edebug-def-name))) (if (or (null data) (markerp data)) (error "%s is not instrumented for Edebug" edebug-def-name)) data)) ; we could do it automatically, if data is a marker. @@ -3155,7 +3219,7 @@ before returning. The default is one second." (if edebug-stop-point (let* ((edebug-def-name (car edebug-stop-point)) (index (cdr edebug-stop-point)) - (edebug-data (get edebug-def-name 'edebug)) + (edebug-data (edebug-get-edebug-or-ghost edebug-def-name)) ;; pull out parts of edebug-data (edebug-def-mark (car edebug-data)) @@ -3196,7 +3260,7 @@ the breakpoint." (if edebug-stop-point (let* ((edebug-def-name (car edebug-stop-point)) (index (cdr edebug-stop-point)) - (edebug-data (get edebug-def-name 'edebug)) + (edebug-data (edebug-get-edebug-or-ghost edebug-def-name)) ;; pull out parts of edebug-data (edebug-def-mark (car edebug-data)) @@ -3228,7 +3292,45 @@ the breakpoint." (setcar (cdr edebug-data) edebug-breakpoints) (goto-char position) - )))) + (edebug--overlay-breakpoints edebug-def-name))))) + +(define-fringe-bitmap 'edebug-breakpoint + "\x3c\x7e\xff\xff\xff\xff\x7e\x3c") + +(defun edebug--overlay-breakpoints (function) + (let* ((data (edebug-get-edebug-or-ghost function)) + (start (nth 0 data)) + (breakpoints (nth 1 data)) + (offsets (nth 2 data))) + ;; First remove all old breakpoint overlays. + (edebug--overlay-breakpoints-remove + start (+ start (aref offsets (1- (length offsets))))) + ;; Then make overlays for the breakpoints (but only when we are in + ;; edebug mode). + (when edebug-active + (dolist (breakpoint breakpoints) + (let* ((pos (+ start (aref offsets (car breakpoint)))) + (overlay (make-overlay pos (1+ pos))) + (face (if (nth 4 breakpoint) + (progn + (overlay-put overlay + 'help-echo "Disabled breakpoint") + (overlay-put overlay + 'face 'edebug-disabled-breakpoint)) + (overlay-put overlay 'help-echo "Breakpoint") + (overlay-put overlay 'face 'edebug-enabled-breakpoint)))) + (overlay-put overlay 'edebug t) + (let ((fringe (make-overlay pos pos))) + (overlay-put fringe 'edebug t) + (overlay-put fringe 'before-string + (propertize + "x" 'display + `(left-fringe edebug-breakpoint ,face))))))))) + +(defun edebug--overlay-breakpoints-remove (start end) + (dolist (overlay (overlays-in start end)) + (when (overlay-get overlay 'edebug) + (delete-overlay overlay)))) (defun edebug-set-breakpoint (arg) "Set the breakpoint of nearest sexp. @@ -3236,9 +3338,9 @@ With prefix argument, make it a temporary breakpoint." (interactive "P") ;; If the form hasn't been instrumented yet, do it now. (when (and (not edebug-active) - (let ((data (get (edebug--form-data-name - (edebug-get-form-data-entry (point))) - 'edebug))) + (let ((data (edebug-get-edebug-or-ghost + (edebug--form-data-name + (edebug-get-form-data-entry (point)))))) (or (null data) (markerp data)))) (edebug-defun)) (edebug-modify-breakpoint t nil arg)) @@ -3252,7 +3354,7 @@ With prefix argument, make it a temporary breakpoint." "Unset all the breakpoints in the current form." (interactive) (let* ((name (edebug-form-data-symbol)) - (breakpoints (nth 1 (get name 'edebug)))) + (breakpoints (nth 1 (edebug-get-edebug-or-ghost name)))) (unless breakpoints (user-error "There are no breakpoints in %s" name)) (save-excursion @@ -3268,12 +3370,13 @@ With prefix argument, make it a temporary breakpoint." (user-error "No stop point near point")) (let* ((name (car stop-point)) (index (cdr stop-point)) - (data (get name 'edebug)) + (data (edebug-get-edebug-or-ghost name)) (breakpoint (assq index (nth 1 data)))) (unless breakpoint (user-error "No breakpoint near point")) (setf (nth 4 breakpoint) - (not (nth 4 breakpoint)))))) + (not (nth 4 breakpoint))) + (edebug--overlay-breakpoints name)))) (defun edebug-set-global-break-condition (expression) "Set `edebug-global-break-condition' to EXPRESSION." @@ -3448,7 +3551,7 @@ instrument cannot be found, signal an error." (goto-char func-marker) (edebug-eval-top-level-form) (list func))) - ((consp func-marker) + ((and (consp func-marker) (consp (symbol-function func))) (message "%s is already instrumented." func) (list func)) (t @@ -3667,7 +3770,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. @@ -3675,8 +3777,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) @@ -4223,7 +4324,7 @@ Save DEF-NAME, BEFORE-INDEX and AFTER-INDEX in FRAME." (let* ((index (backtrace-get-index)) (frame (nth index backtrace-frames))) (when (edebug--frame-def-name frame) - (let* ((data (get (edebug--frame-def-name frame) 'edebug)) + (let* ((data (edebug-get-edebug-or-ghost (edebug--frame-def-name frame))) (marker (nth 0 data)) (offsets (nth 2 data))) (pop-to-buffer (marker-buffer marker)) @@ -4307,7 +4408,7 @@ reinstrument it." (let* ((function (edebug-form-data-symbol)) (counts (get function 'edebug-freq-count)) (coverages (get function 'edebug-coverage)) - (data (get function 'edebug)) + (data (edebug-get-edebug-or-ghost function)) (def-mark (car data)) ; mark at def start (edebug-points (nth 2 data)) (i (1- (length edebug-points))) @@ -4465,7 +4566,7 @@ With prefix argument, make it a temporary breakpoint." (if edebug-stop-point (let* ((edebug-def-name (car edebug-stop-point)) (index (cdr edebug-stop-point)) - (edebug-data (get edebug-def-name 'edebug)) + (edebug-data (edebug-get-edebug-or-ghost edebug-def-name)) (edebug-breakpoints (car (cdr edebug-data))) (edebug-break-data (assq index edebug-breakpoints)) (edebug-break-condition (car (cdr edebug-break-data))) @@ -4479,17 +4580,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 @@ -4525,7 +4615,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-core.el b/lisp/emacs-lisp/eieio-core.el index 1e53f30a2ae..3bc65d0d4c5 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -730,7 +730,8 @@ Argument FN is the function calling this verifier." (guard (not (memq name eieio--known-slot-names)))) (macroexp--warn-and-return (format-message "Unknown slot `%S'" name) exp 'compile-only)) - (_ exp))))) + (_ exp)))) + (gv-setter eieio-oset)) (cl-check-type slot symbol) (cl-check-type obj (or eieio-object class)) (let* ((class (cond ((symbolp obj) @@ -755,6 +756,7 @@ Argument FN is the function calling this verifier." (defun eieio-oref-default (obj slot) "Do the work for the macro `oref-default' with similar parameters. Fills in OBJ's SLOT with its default value." + (declare (gv-setter eieio-oset-default)) (cl-check-type obj (or eieio-object class)) (cl-check-type slot symbol) (let* ((cl (cond ((symbolp obj) (cl--find-class obj)) 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/eieio.el b/lisp/emacs-lisp/eieio.el index 9f8b639e52d..b75410ee220 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -351,24 +351,20 @@ Elements of FIELDS can be of the form (NAME PAT) in which case the contents of field NAME is matched against PAT, or they can be of the form NAME which is a shorthand for (NAME NAME)." (declare (debug (&rest [&or (sexp pcase-PAT) sexp]))) - (let ((is (make-symbol "table"))) - ;; FIXME: This generates a horrendous mess of redundant let bindings. - ;; `pcase' needs to be improved somehow to introduce let-bindings more - ;; sparingly, or the byte-compiler needs to be taught to optimize - ;; them away. - ;; FIXME: `pcase' does not do a good job here of sharing tests&code among - ;; various branches. - `(and (pred eieio-object-p) - (app eieio-pcase-slot-index-table ,is) - ,@(mapcar (lambda (field) - (let* ((name (if (consp field) (car field) field)) - (pat (if (consp field) (cadr field) field)) - (i (make-symbol "index"))) - `(and (let (and ,i (pred natnump)) - (eieio-pcase-slot-index-from-index-table - ,is ',name)) - (app (pcase--flip aref ,i) ,pat)))) - fields)))) + ;; FIXME: This generates a horrendous mess of redundant let bindings. + ;; `pcase' needs to be improved somehow to introduce let-bindings more + ;; sparingly, or the byte-compiler needs to be taught to optimize + ;; them away. + ;; FIXME: `pcase' does not do a good job here of sharing tests&code among + ;; various branches. + `(and (pred eieio-object-p) + ,@(mapcar (lambda (field) + (pcase-exhaustive field + (`(,name ,pat) + `(app (pcase--flip eieio-oref ',name) ,pat)) + ((pred symbolp) + `(app (pcase--flip eieio-oref ',field) ,field)))) + fields))) ;;; Simple generators, and query functions. None of these would do ;; well embedded into an object. @@ -649,14 +645,6 @@ If SLOT is unbound, do nothing." nil (eieio-oset object slot (delete item (eieio-oref object slot))))) -;;; Here are some CLOS items that need the CL package -;; - -;; FIXME: Shouldn't this be a more complex gv-expander which extracts the -;; common code between oref and oset, so as to reduce the redundant work done -;; in (push foo (oref bar baz)), like we do for the `nth' expander? -(gv-define-simple-setter eieio-oref eieio-oset) - ;;; ;; We want all objects created by EIEIO to have some default set of diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index 7a7b8ec1647..4825b5c5e6c 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -5,6 +5,11 @@ ;; Author: Noah Friedman <friedman@splode.com> ;; Keywords: extensions ;; Created: 1995-10-06 +;; Version: 1.8.0 +;; Package-Requires: ((emacs "26.3")) + +;; This is a GNU ELPA :core package. Avoid functionality that is not +;; compatible with the version of Emacs recorded above. ;; This file is part of GNU Emacs. @@ -32,20 +37,18 @@ ;; the one-line documentation for that variable instead, to remind you of ;; that variable's meaning. -;; One useful way to enable this minor mode is to put the following in your -;; .emacs: -;; -;; (add-hook 'emacs-lisp-mode-hook 'eldoc-mode) -;; (add-hook 'lisp-interaction-mode-hook 'eldoc-mode) -;; (add-hook 'ielm-mode-hook 'eldoc-mode) -;; (add-hook 'eval-expression-minibuffer-setup-hook 'eldoc-mode) +;; This mode is now enabled by default in all major modes that provide +;; support for it, such as `emacs-lisp-mode'. +;; This is controlled by `global-eldoc-mode'. -;; Major modes for other languages may use ElDoc by defining an -;; appropriate function as the buffer-local value of -;; `eldoc-documentation-function'. +;; Major modes for other languages may use ElDoc by adding an +;; appropriate function to the buffer-local value of +;; `eldoc-documentation-functions'. ;;; Code: +(eval-when-compile (require 'cl-lib)) + (defgroup eldoc nil "Show function arglist or variable docstring in echo area." :group 'lisp @@ -57,20 +60,17 @@ If user input arrives before this interval of time has elapsed after the last input, no documentation will be printed. If this variable is set to 0, no idle time is required." - :type 'number - :group 'eldoc) + :type 'number) (defcustom eldoc-print-after-edit nil "If non-nil eldoc info is only shown when editing. Changing the value requires toggling `eldoc-mode'." - :type 'boolean - :group 'eldoc) + :type 'boolean) ;;;###autoload (defcustom eldoc-minor-mode-string (purecopy " ElDoc") "String to display in mode line when ElDoc Mode is enabled; nil for none." - :type '(choice string (const :tag "None" nil)) - :group 'eldoc) + :type '(choice string (const :tag "None" nil))) (defcustom eldoc-argument-case #'identity "Case to display argument names of functions, as a symbol. @@ -79,42 +79,51 @@ Actually, any name of a function which takes a string as an argument and returns another string is acceptable. Note that this variable has no effect, unless -`eldoc-documentation-function' handles it explicitly." +`eldoc-documentation-strategy' handles it explicitly." :type '(radio (function-item upcase) (function-item downcase) - function) - :group 'eldoc) + function)) (make-obsolete-variable 'eldoc-argument-case nil "25.1") (defcustom eldoc-echo-area-use-multiline-p 'truncate-sym-name-if-fit - "Allow long ElDoc messages to resize echo area display. -If value is t, never attempt to truncate messages; complete symbol name -and function arglist or 1-line variable documentation will be displayed -even if echo area must be resized to fit. - -If value is any non-nil value other than t, symbol name may be truncated -if it will enable the function arglist or documentation string to fit on a -single line without resizing window. Otherwise, behavior is just like -former case. - -If value is nil, messages are always truncated to fit in a single line of -display in the echo area. Function or variable symbol name may be -truncated to make more of the arglist or documentation string visible. - -Note that this variable has no effect, unless -`eldoc-documentation-function' handles it explicitly." - :type '(radio (const :tag "Always" t) - (const :tag "Never" nil) - (const :tag "Yes, but truncate symbol names if it will\ - enable argument list to fit on one line" truncate-sym-name-if-fit)) - :group 'eldoc) + "Allow long ElDoc doc strings to resize echo area display. +If value is t, never attempt to truncate messages, even if the +echo area must be resized to fit. + +If value is a number (integer or floating point), it has the +semantics of `max-mini-window-height', constraining the resizing +for ElDoc purposes only. + +Any resizing respects `max-mini-window-height'. + +If value is any non-nil symbol other than t, the part of the doc +string that represents the symbol's name may be truncated if it +will enable the rest of the doc string to fit on a single line, +without resizing the echo area. + +If value is nil, a doc string is always truncated to fit in a +single line of display in the echo area." + :type '(radio (const :tag "Always" t) + (float :tag "Fraction of frame height" 0.25) + (integer :tag "Number of lines" 5) + (const :tag "Never" nil) + (const :tag "Yes, but ask major-mode to truncate + symbol names if it will\ enable argument list to fit on one + line" truncate-sym-name-if-fit))) + +(defcustom eldoc-prefer-doc-buffer nil + "Prefer ElDoc's documentation buffer if it is showing in some frame. +If this variable's value is t and a piece of documentation needs +to be truncated to fit in the echo area, do so if ElDoc's +documentation buffer is not already showing, since the buffer +always holds the full documentation." + :type 'boolean) (defface eldoc-highlight-function-argument '((t (:inherit bold))) "Face used for the argument at point in a function's argument list. -Note that this face has no effect unless the `eldoc-documentation-function' -handles it explicitly." - :group 'eldoc) +Note that this face has no effect unless the `eldoc-documentation-strategy' +handles it explicitly.") ;;; No user options below here. @@ -155,7 +164,7 @@ directly. Instead, use `eldoc-add-command' and `eldoc-remove-command'.") This is used to determine if `eldoc-idle-delay' is changed by the user.") (defvar eldoc-message-function #'eldoc-minibuffer-message - "The function used by `eldoc-message' to display messages. + "The function used by `eldoc--message' to display messages. It should receive the same arguments as `message'.") (defun eldoc-edit-message-commands () @@ -182,8 +191,7 @@ area displays information about a function or variable in the text where point is. If point is on a documented variable, it displays the first line of that variable's doc string. Otherwise it displays the argument list of the function called in the -expression point is on." - :group 'eldoc :lighter eldoc-minor-mode-string +expression point is on." :lighter eldoc-minor-mode-string (setq eldoc-last-message nil) (cond ((not (eldoc--supported-p)) @@ -193,24 +201,23 @@ expression point is on." (eldoc-mode (when eldoc-print-after-edit (setq-local eldoc-message-commands (eldoc-edit-message-commands))) - (add-hook 'post-command-hook 'eldoc-schedule-timer nil t) - (add-hook 'pre-command-hook 'eldoc-pre-command-refresh-echo-area nil t)) + (add-hook 'post-command-hook #'eldoc-schedule-timer nil t) + (add-hook 'pre-command-hook #'eldoc-pre-command-refresh-echo-area nil t)) (t (kill-local-variable 'eldoc-message-commands) - (remove-hook 'post-command-hook 'eldoc-schedule-timer t) - (remove-hook 'pre-command-hook 'eldoc-pre-command-refresh-echo-area t) + (remove-hook 'post-command-hook #'eldoc-schedule-timer t) + (remove-hook 'pre-command-hook #'eldoc-pre-command-refresh-echo-area t) (when eldoc-timer (cancel-timer eldoc-timer) (setq eldoc-timer nil))))) ;;;###autoload (define-globalized-minor-mode global-eldoc-mode eldoc-mode turn-on-eldoc-mode - :group 'eldoc :initialize 'custom-initialize-delay :init-value t ;; For `read--expression', the usual global mode mechanism of ;; `change-major-mode-hook' runs in the minibuffer before - ;; `eldoc-documentation-function' is set, so `turn-on-eldoc-mode' + ;; `eldoc-documentation-strategy' is set, so `turn-on-eldoc-mode' ;; does nothing. Configure and enable eldoc from ;; `eval-expression-minibuffer-setup-hook' instead. (if global-eldoc-mode @@ -222,21 +229,24 @@ expression point is on." (defun eldoc--eval-expression-setup () ;; Setup `eldoc', similar to `emacs-lisp-mode'. FIXME: Call ;; `emacs-lisp-mode' itself? - (add-function :before-until (local 'eldoc-documentation-function) - #'elisp-eldoc-documentation-function) + (cond ((<= emacs-major-version 27) + (declare-function elisp-eldoc-documentation-function "elisp-mode") + (add-function :before-until (local 'eldoc-documentation-function) + #'elisp-eldoc-documentation-function)) + (t (add-hook 'eldoc-documentation-functions + #'elisp-eldoc-var-docstring nil t) + (add-hook 'eldoc-documentation-functions + #'elisp-eldoc-funcall nil t) + (setq eldoc-documentation-strategy 'eldoc-documentation-default))) (eldoc-mode +1)) ;;;###autoload (defun turn-on-eldoc-mode () "Turn on `eldoc-mode' if the buffer has ElDoc support enabled. -See `eldoc-documentation-function' for more detail." +See `eldoc-documentation-strategy' for more detail." (when (eldoc--supported-p) (eldoc-mode 1))) -(defun eldoc--supported-p () - "Non-nil if an ElDoc function is set for this buffer." - (not (memq eldoc-documentation-function '(nil ignore)))) - (defun eldoc-schedule-timer () "Ensure `eldoc-timer' is running. @@ -252,7 +262,9 @@ reflect the change." (when (or eldoc-mode (and global-eldoc-mode (eldoc--supported-p))) - (eldoc-print-current-symbol-info)))))) + ;; Don't ignore, but also don't full-on signal errors + (with-demoted-errors "eldoc error: %s" + (eldoc-print-current-symbol-info)) ))))) ;; If user has changed the idle delay, update the timer. (cond ((not (= eldoc-idle-delay eldoc-current-idle-delay)) @@ -277,28 +289,29 @@ Otherwise work like `message'." (or (window-in-direction 'above (minibuffer-window)) (minibuffer-selected-window) (get-largest-window))) - (when mode-line-format - (unless (and (listp mode-line-format) - (assq 'eldoc-mode-line-string mode-line-format)) + (when (and mode-line-format + (not (and (listp mode-line-format) + (assq 'eldoc-mode-line-string mode-line-format)))) (setq mode-line-format (list "" '(eldoc-mode-line-string (" " eldoc-mode-line-string " ")) - mode-line-format)))) + mode-line-format))) (setq eldoc-mode-line-string (when (stringp format-string) (apply #'format-message format-string args))) (force-mode-line-update))) - (apply 'message format-string args))) + (apply #'message format-string args))) -(defun eldoc-message (&optional string) +(make-obsolete + 'eldoc-message "use `eldoc-documentation-functions' instead." "eldoc-1.1.0") +(defun eldoc-message (&optional string) (eldoc--message string)) +(defun eldoc--message (&optional string) "Display STRING as an ElDoc message if it's non-nil. Also store it in `eldoc-last-message' and return that value." (let ((omessage eldoc-last-message)) (setq eldoc-last-message string) - ;; In emacs 19.29 and later, and XEmacs 19.13 and later, all messages - ;; are recorded in a log. Do not put eldoc messages in that log since - ;; they are Legion. + ;; Do not put eldoc messages in the log since they are Legion. ;; Emacs way of preventing log messages. (let ((message-log-max nil)) (cond (eldoc-last-message @@ -311,33 +324,58 @@ Also store it in `eldoc-last-message' and return that value." (and (symbolp command) (intern-soft (symbol-name command) eldoc-message-commands))) -;; This function goes on pre-command-hook for XEmacs or when using idle -;; timers in Emacs. Motion commands clear the echo area for some reason, +;; This function goes on pre-command-hook. +;; Motion commands clear the echo area for some reason, ;; which make eldoc messages flicker or disappear just before motion ;; begins. This function reprints the last eldoc message immediately ;; before the next command executes, which does away with the flicker. ;; This doesn't seem to be required for Emacs 19.28 and earlier. +;; FIXME: The above comment suggests we don't really understand why +;; this is needed. Maybe it's not needed any more, but if it is +;; we should figure out why. (defun eldoc-pre-command-refresh-echo-area () "Reprint `eldoc-last-message' in the echo area." (and eldoc-last-message (not (minibufferp)) ;We don't use the echo area when in minibuffer. (if (and (eldoc-display-message-no-interference-p) (eldoc--message-command-p this-command)) - (eldoc-message eldoc-last-message) - ;; No need to call eldoc-message since the echo area will be cleared + (eldoc--message eldoc-last-message) + ;; No need to call eldoc--message since the echo area will be cleared ;; for us, but do note that the last-message will be gone. (setq eldoc-last-message nil)))) -;; Decide whether now is a good time to display a message. +(defvar-local eldoc--last-request-state nil + "Tuple containing information about last ElDoc request.") +(defun eldoc--request-state () + "Compute information to store in `eldoc--last-request-state'." + (list (current-buffer) (buffer-modified-tick) (point))) + (defun eldoc-display-message-p () - "Return non-nil when it is appropriate to display an ElDoc message." - (and (eldoc-display-message-no-interference-p) - ;; If this-command is non-nil while running via an idle - ;; timer, we're still in the middle of executing a command, - ;; e.g. a query-replace where it would be annoying to - ;; overwrite the echo area. - (not this-command) - (eldoc--message-command-p last-command))) + (eldoc--request-docs-p (eldoc--request-state))) +(make-obsolete 'eldoc-display-message-p + "Use `eldoc-documentation-functions' instead." + "eldoc-1.6.0") + +(defun eldoc--request-docs-p (request-state) + "Return non-nil when it is appropriate to request docs. +REQUEST-STATE is a candidate for `eldoc--last-request-state'" + (and + ;; FIXME: The original idea behind this function is to protect the + ;; Echo area from ElDoc interference, but since that is only one of + ;; the possible outlets of ElDoc, this must soon be reworked. + (eldoc-display-message-no-interference-p) + (not (and eldoc--doc-buffer + (get-buffer-window eldoc--doc-buffer) + (equal request-state + (with-current-buffer + eldoc--doc-buffer + eldoc--last-request-state)))) + ;; If this-command is non-nil while running via an idle + ;; timer, we're still in the middle of executing a command, + ;; e.g. a query-replace where it would be annoying to + ;; overwrite the echo area. + (not this-command) + (eldoc--message-command-p last-command))) ;; Check various conditions about the current environment that might make @@ -347,74 +385,408 @@ Also store it in `eldoc-last-message' and return that value." (not (or executing-kbd-macro (bound-and-true-p edebug-active)))) -;;;###autoload -(defvar eldoc-documentation-function #'ignore - "Function to call to return doc string. -The function of no args should return a one-line string for displaying -doc about a function etc. appropriate to the context around point. -It should return nil if there's no doc appropriate for the context. -Typically doc is returned if point is on a function-like name or in its -arg list. - -The result is used as is, so the function must explicitly handle -the variables `eldoc-argument-case' and `eldoc-echo-area-use-multiline-p', -and the face `eldoc-highlight-function-argument', if they are to have any -effect. - -Major modes should modify this variable using `add-function', for example: - (add-function :before-until (local \\='eldoc-documentation-function) - #\\='foo-mode-eldoc-function) -so that the global documentation function (i.e. the default value of the -variable) is taken into account if the major mode specific function does not +(defvar eldoc-documentation-functions nil + "Hook of functions that produce doc strings. + +A doc string is typically relevant if point is on a function-like +name, inside its arg list, or on any object with some associated +information. + +Each hook function is called with at least one argument CALLBACK, +a function, and decides whether to display a doc short string +about the context around point. + +- If that decision can be taken quickly, the hook function may + call CALLBACK immediately following the protocol described + below. Alternatively it may ignore CALLBACK entirely and + return either the doc string, or nil if there's no doc + appropriate for the context. + +- If the computation of said doc string (or the decision whether + there is one at all) is expensive or can't be performed + directly, the hook function should return a non-nil, non-string + value and arrange for CALLBACK to be called at a later time, + using asynchronous processes or other asynchronous mechanisms. + +To call the CALLBACK function, the hook function must pass it an +obligatory argument DOCSTRING, a string containing the +documentation, followed by an optional list of keyword-value +pairs of the form (:KEY VALUE :KEY2 VALUE2...). KEY can be: + +* `:thing', VALUE is a short string or symbol designating what is + being reported on. The documentation display engine can elect + to remove this information depending on space contraints; + +* `:face', VALUE is a symbol designating a face to use when + displaying `:thing''s value. + +Major modes should modify this hook locally, for example: + (add-hook \\='eldoc-documentation-functions #\\='foo-mode-eldoc nil t) +so that the global value (i.e. the default value of the hook) is +taken into account if the major mode specific function does not return any documentation.") -(defun eldoc-print-current-symbol-info () - "Print the text produced by `eldoc-documentation-function'." - ;; This is run from post-command-hook or some idle timer thing, - ;; so we need to be careful that errors aren't ignored. - (with-demoted-errors "eldoc error: %s" - (if (not (eldoc-display-message-p)) - ;; Erase the last message if we won't display a new one. - (when eldoc-last-message - (eldoc-message nil)) - (let ((non-essential t)) - ;; Only keep looking for the info as long as the user hasn't - ;; requested our attention. This also locally disables inhibit-quit. - (while-no-input - (eldoc-message (funcall eldoc-documentation-function))))))) - -;; If the entire line cannot fit in the echo area, the symbol name may be -;; truncated or eliminated entirely from the output to make room for the -;; description. -(defun eldoc-docstring-format-sym-doc (prefix doc &optional face) - "Combine PREFIX and DOC, and shorten the result to fit in the echo area. - -When PREFIX is a symbol, propertize its symbol name with FACE -before combining it with DOC. If FACE is not provided, just -apply the nil face. - -See also: `eldoc-echo-area-use-multiline-p'." - (when (symbolp prefix) - (setq prefix (concat (propertize (symbol-name prefix) 'face face) ": "))) - (let* ((ea-multi eldoc-echo-area-use-multiline-p) - ;; Subtract 1 from window width since emacs will not write - ;; any chars to the last column, or in later versions, will - ;; cause a wraparound and resize of the echo area. - (ea-width (1- (window-width (minibuffer-window)))) - (strip (- (+ (length prefix) (length doc)) ea-width))) - (cond ((or (<= strip 0) - (eq ea-multi t) - (and ea-multi (> (length doc) ea-width))) - (concat prefix doc)) - ((> (length doc) ea-width) - (substring (format "%s" doc) 0 ea-width)) - ((>= strip (string-match-p ":? *\\'" prefix)) - doc) +(defvar eldoc--doc-buffer nil "Buffer displaying latest ElDoc-produced docs.") + +(defun eldoc-doc-buffer (&optional interactive) + "Get latest *eldoc* help buffer. Interactively, display it." + (interactive (list t)) + (prog1 + (if (and eldoc--doc-buffer (buffer-live-p eldoc--doc-buffer)) + eldoc--doc-buffer + (setq eldoc--doc-buffer (get-buffer-create "*eldoc*"))) + (when interactive (display-buffer eldoc--doc-buffer)))) + + +(defun eldoc--handle-docs (docs) + "Display multiple DOCS in echo area. +DOCS is a list of (STRING PLIST...). It is already sorted. +Honor most of `eldoc-echo-area-use-multiline-p'." + ;; If there's nothing to report clear the echo area, but don't erase + ;; the last *eldoc* buffer. + (if (null docs) (eldoc--message nil) + (let* + ;; Otherwise, establish some parameters. + ((width (1- (window-width (minibuffer-window)))) + (val (if (and (symbolp eldoc-echo-area-use-multiline-p) + eldoc-echo-area-use-multiline-p) + max-mini-window-height + eldoc-echo-area-use-multiline-p)) + (available (cl-typecase val + (float (truncate (* (frame-height) val))) + (integer val) + (t 1))) + (things-reported-on) + (request eldoc--last-request-state) + single-doc single-doc-sym) + ;; Then, compose the contents of the `*eldoc*' buffer. + (with-current-buffer (eldoc-doc-buffer) + ;; Set doc-buffer's `eldoc--last-request-state', too + (setq eldoc--last-request-state request) + (let ((inhibit-read-only t)) + (erase-buffer) (setq buffer-read-only t) + (local-set-key "q" 'quit-window) + (cl-loop for (docs . rest) on docs + for (this-doc . plist) = docs + for thing = (plist-get plist :thing) + when thing do + (cl-pushnew thing things-reported-on) + (setq this-doc + (concat + (propertize (format "%s" thing) + 'face (plist-get plist :face)) + ": " + this-doc)) + do (insert this-doc) + when rest do (insert "\n"))) + ;; Rename the buffer. + (when things-reported-on + (rename-buffer (format "*eldoc for %s*" + (mapconcat (lambda (s) (format "%s" s)) + things-reported-on + ", "))))) + ;; Finally, output to the echo area. I'm pretty sure nicer + ;; strategies can be used here, probably by splitting this + ;; function into some `eldoc-display-functions' special hook. + (let ((echo-area-message + (cond + (;; We handle the `truncate-sym-name-if-fit' special + ;; case first, by checking if for a lot of special + ;; conditions. + (and + (eq 'truncate-sym-name-if-fit eldoc-echo-area-use-multiline-p) + (null (cdr docs)) + (setq single-doc (caar docs)) + (setq single-doc-sym + (format "%s" (plist-get (cdar docs) :thing))) + (< (length single-doc) width) + (not (string-match "\n" single-doc)) + (> (+ (length single-doc) (length single-doc-sym) 2) width)) + single-doc) + ((> available 1) + (with-current-buffer (eldoc-doc-buffer) + (cl-loop + initially + (goto-char (point-min)) + (goto-char (line-end-position (1+ available))) + for truncated = nil then t + for needed + = (let ((truncate-lines message-truncate-lines)) + (count-screen-lines (point-min) (point) t + (minibuffer-window))) + while (> needed (if truncated (1- available) available)) + do (goto-char (line-end-position (if truncated 0 -1))) + (while (and (not (bobp)) (bolp)) (goto-char (line-end-position 0))) + finally + (unless (and truncated + eldoc-prefer-doc-buffer + (get-buffer-window eldoc--doc-buffer)) + (cl-return + (concat + (buffer-substring (point-min) (point)) + (and truncated + (format + "\n(Documentation truncated. Use `%s' to see rest)" + (substitute-command-keys "\\[eldoc-doc-buffer]"))))))))) + ((= available 1) + ;; Truncate "brutally." ; FIXME: use `eldoc-prefer-doc-buffer' too? + (with-current-buffer (eldoc-doc-buffer) + (truncate-string-to-width + (buffer-substring (goto-char (point-min)) (line-end-position 1)) width)))))) + (when echo-area-message + (eldoc--message echo-area-message)))))) + +(defun eldoc-documentation-default () + "Show first doc string for item at point. +Default value for `eldoc-documentation-strategy'." + (run-hook-with-args-until-success 'eldoc-documentation-functions + (eldoc--make-callback :patient))) + +(defun eldoc--documentation-compose-1 (eagerlyp) + "Helper function for composing multiple doc strings. +If EAGERLYP is non-nil show documentation as soon as possible, +else wait for all doc strings." + (run-hook-wrapped 'eldoc-documentation-functions + (lambda (f) + (let* ((callback (eldoc--make-callback + (if eagerlyp :eager :patient))) + (str (funcall f callback))) + (if (or (null str) (stringp str)) (funcall callback str)) + nil))) + t) + +(defun eldoc-documentation-compose () + "Show multiple doc strings at once after waiting for all. +Meant as a value for `eldoc-documentation-strategy'." + (eldoc--documentation-compose-1 nil)) + +(defun eldoc-documentation-compose-eagerly () + "Show multiple doc strings at once as soon as possible. +Meant as a value for `eldoc-documentation-strategy'." + (eldoc--documentation-compose-1 t)) + +(defun eldoc-documentation-enthusiast () + "Show most important doc string produced so far. +Meant as a value for `eldoc-documentation-strategy'." + (run-hook-wrapped 'eldoc-documentation-functions + (lambda (f) + (let* ((callback (eldoc--make-callback :enthusiast)) + (str (funcall f callback))) + (if (stringp str) (funcall callback str)) + nil)))) + +;; JT@2020-07-10: ElDoc is pre-loaded, so in Emacs < 28 we can't +;; make the "old" `eldoc-documentation-function' point to the new +;; `eldoc-documentation-strategy', so we do the reverse. This allows +;; for ElDoc to be loaded in those older Emacs versions and work with +;; whomever (major-modes, extensions, user) sets one or the other +;; variable. +(defmacro eldoc--documentation-strategy-defcustom + (main secondary value docstring &rest more) + "Defcustom helper macro for sorting `eldoc-documentation-strategy'." + (declare (indent 2)) + `(if (< emacs-major-version 28) + (progn + (defcustom ,secondary ,value ,docstring ,@more) + (define-obsolete-variable-alias ',main ',secondary "eldoc-1.1.0")) + (progn + (defcustom ,main ,value ,docstring ,@more) + (defvaralias ',secondary ',main ,docstring)))) + +(eldoc--documentation-strategy-defcustom eldoc-documentation-strategy + eldoc-documentation-function + #'eldoc-documentation-default + "How to collect and organize results of `eldoc-documentation-functions'. + +This variable controls how `eldoc-documentation-functions', which +specifies the sources of documentation, is queried and how its +results are organized before being displayed to the user. The +following values are allowed: + +- `eldoc-documentation-default': calls functions in the special + hook in order until one is found that produces a doc string + value. Display only that value; + +- `eldoc-documentation-compose': calls all functions in the + special hook and displays all of the resulting doc strings + together. Wait for all strings to be ready, and preserve their + relative as specified by the order of functions in the hook; + +- `eldoc-documentation-compose-eagerly': calls all functions in + the special hook and display as many of the resulting doc + strings as possible, as soon as possibl. Preserving the + relative order of doc strings; + +- `eldoc-documentation-enthusiast': calls all functions in the + special hook and displays only the most important resulting + docstring one at any given time. A function appearing first in + the special hook is considered more important. + +This variable can also be set to a function of no args that +returns something other than a string or nil and allows for some +or all of the special hook `eldoc-documentation-functions' to be +run. In that case, the strategy function should follow that +other variable's protocol closely and endeavor to display the +resulting doc strings itself. + +For backward compatibility to the \"old\" protocol, this variable +can also be set to a function that returns nil or a doc string, +depending whether or not there is documentation to display at +all." + :link '(info-link "(emacs) Lisp Doc") + :type '(radio (function-item eldoc-documentation-default) + (function-item eldoc-documentation-compose) + (function-item eldoc-documentation-compose-eagerly) + (function-item eldoc-documentation-enthusiast) + (function :tag "Other function")) + :version "28.1") + +(defun eldoc--supported-p () + "Non-nil if an ElDoc function is set for this buffer." + (and (not (memq eldoc-documentation-strategy '(nil ignore))) + (or eldoc-documentation-functions + ;; The old API had major modes set `eldoc-documentation-function' + ;; to provide eldoc support. It's impossible now to determine + ;; reliably whether the `eldoc-documentation-strategy' provides + ;; eldoc support (as in the old API) or whether it just provides + ;; a way to combine the results of the + ;; `eldoc-documentation-functions' (as in the new API). + ;; But at least if it's set buffer-locally it's a good hint that + ;; there's some eldoc support in the current buffer. + (local-variable-p 'eldoc-documentation-strategy)))) + +(defvar eldoc--enthusiasm-curbing-timer nil + "Timer used by the `eldoc-documentation-enthusiast' strategy. +When a doc string is encountered, it must endure a certain amount +of time unchallenged until it is displayed to the user. This +prevents blinking if a lower priority docstring comes in shortly +before a higher priority one.") + +(defalias 'eldoc #'eldoc-print-current-symbol-info) + +;; This variable should be unbound, but that confuses +;; `describe-symbol' for some reason. +(defvar eldoc--make-callback nil "Helper for function `eldoc--make-callback'.") + +;; JT@2020-07-08: the below docstring for the internal function +;; `eldoc--invoke-strategy' could be moved to +;; `eldoc-documentation-strategy' or thereabouts if/when we decide to +;; extend or publish the `make-callback' protocol. +(defun eldoc--make-callback (method) + "Make callback suitable for `eldoc-documentation-functions'. +The return value is a function FN whose lambda list is (STRING +&rest PLIST) and can be called by those functions. Its +responsibility is always to register the docstring STRING along +with options specified in PLIST as the documentation to display +for each particular situation. + +METHOD specifies how the callback behaves relative to other +competing elements in `eldoc-documentation-functions'. It can +have the following values: + +- `:enthusiast' says to display STRING as soon as possible if + there's no higher priority doc string; + +- `:patient' says to display STRING along with all other + competing strings but only when all of all + `eldoc-documentation-functions' have been collected; + +- `:eager' says to display STRING along with all other competing + strings so far, as soon as possible." + (funcall eldoc--make-callback method)) + +(defun eldoc--invoke-strategy () + "Invoke `eldoc-documentation-strategy' function. + +That function's job is to run the `eldoc-documentation-functions' +special hook, using the `run-hook' family of functions. ElDoc's +built-in strategy functions play along with the +`eldoc--make-callback' protocol, using it to produce callback to +feed to the functgions of `eldoc-documentation-functions'. + +Other third-party strategy functions do not use +`eldoc--make-callback'. They must find some alternate way to +produce callbacks to feed to `eldoc-documentation-function' and +should endeavour to display the docstrings eventually produced." + (let* (;; How many callbacks have been created by the strategy + ;; fucntion and passed to elements of + ;; `eldoc-documentation-functions'. + (howmany 0) + ;; How many calls to callbacks we're still waiting on. Used + ;; by `:patient'. + (want 0) + ;; The doc strings and corresponding options registered so + ;; far. + (docs-registered '())) + (cl-labels + ((register-doc + (pos string plist) + (when (and string (> (length string) 0)) + (push (cons pos (cons string plist)) docs-registered))) + (display-doc + () + (eldoc--handle-docs + (mapcar #'cdr + (setq docs-registered + (sort docs-registered + (lambda (a b) (< (car a) (car b)))))))) + (make-callback + (method) + (let ((pos (prog1 howmany (cl-incf howmany)))) + (cl-ecase method + (:enthusiast + (lambda (string &rest plist) + (when (and string (cl-loop for (p) in docs-registered + never (< p pos))) + (setq docs-registered '()) + (register-doc pos string plist) + (when (and (timerp eldoc--enthusiasm-curbing-timer) + (memq eldoc--enthusiasm-curbing-timer + timer-list)) + (cancel-timer eldoc--enthusiasm-curbing-timer)) + (setq eldoc--enthusiasm-curbing-timer + (run-at-time (unless (zerop pos) 0.3) + nil #'display-doc))) + t)) + (:patient + (cl-incf want) + (lambda (string &rest plist) + (register-doc pos string plist) + (when (zerop (cl-decf want)) (display-doc)) + t)) + (:eager + (lambda (string &rest plist) + (register-doc pos string plist) + (display-doc) + t)))))) + (let* ((eldoc--make-callback #'make-callback) + (res (funcall eldoc-documentation-strategy))) + ;; Observe the old and the new protocol: + (cond (;; Old protocol: got string, output immediately; + (stringp res) (register-doc 0 res nil) (display-doc)) + (;; Old protocol: got nil, clear the echo area; + (null res) (eldoc--message nil)) + (;; New protocol: trust callback will be called; + t)))))) + +(defun eldoc-print-current-symbol-info (&optional interactive) + "Document thing at point." + (interactive '(t)) + (let ((token (eldoc--request-state))) + (cond (interactive + (eldoc--invoke-strategy)) + ((not (eldoc--request-docs-p token)) + ;; Erase the last message if we won't display a new one. + (when eldoc-last-message + (eldoc--message nil))) (t - ;; Show the end of the partial symbol name, rather - ;; than the beginning, since the former is more likely - ;; to be unique given package namespace conventions. - (concat (substring prefix strip) doc))))) + (let ((non-essential t)) + (setq eldoc--last-request-state token) + ;; Only keep looking for the info as long as the user hasn't + ;; requested our attention. This also locally disables + ;; inhibit-quit. + (while-no-input + (eldoc--invoke-strategy))))))) ;; When point is in a sexp, the function args are not reprinted in the echo ;; area after every possible interactive command because some of them print diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index 167ead3ce02..e35db56550d 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -279,6 +279,7 @@ Interactively, prompt for LIBRARY using the one at or near point." (switch-to-buffer (find-file-noselect (find-library-name library))) (run-hooks 'find-function-after-hook))) +;;;###autoload (defun read-library-name () "Read and return a library name, defaulting to the one near point. diff --git a/lisp/emacs-lisp/float-sup.el b/lisp/emacs-lisp/float-sup.el index 50b157b16a4..d92ca5b9337 100644 --- a/lisp/emacs-lisp/float-sup.el +++ b/lisp/emacs-lisp/float-sup.el @@ -1,4 +1,4 @@ -;;; float-sup.el --- define some constants useful for floating point numbers. +;;; float-sup.el --- define some constants useful for floating point numbers. -*- lexical-binding:t -*- ;; Copyright (C) 1985-1987, 2001-2020 Free Software Foundation, Inc. diff --git a/lisp/emacs-lisp/generator.el b/lisp/emacs-lisp/generator.el index 26ab2679e22..c95c758a571 100644 --- a/lisp/emacs-lisp/generator.el +++ b/lisp/emacs-lisp/generator.el @@ -153,7 +153,7 @@ DYNAMIC-VAR bound to STATIC-VAR." (defun cps--add-state (kind body) "Create a new CPS state of KIND with 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)) @@ -673,7 +673,7 @@ When called as a function, NAME returns an iterator value that encapsulates the state of a computation that produces a sequence of values. Callers can retrieve each value using `iter-next'." (declare (indent defun) - (debug (&define name lambda-list lambda-doc def-body)) + (debug (&define name lambda-list lambda-doc &rest sexp)) (doc-string 3)) (cl-assert lexical-binding) (let* ((parsed-body (macroexp-parse-body body)) @@ -687,14 +687,14 @@ of values. Callers can retrieve each value using `iter-next'." "Return a lambda generator. `iter-lambda' is to `iter-defun' as `lambda' is to `defun'." (declare (indent defun) - (debug (&define lambda-list lambda-doc def-body))) + (debug (&define lambda-list lambda-doc &rest sexp))) (cl-assert lexical-binding) `(lambda ,arglist ,(cps-generate-evaluator body))) (defmacro iter-make (&rest body) "Return a new iterator." - (declare (debug t)) + (declare (debug (&rest sexp))) (cps-generate-evaluator body)) (defconst iter-empty (lambda (_op _val) (signal 'iter-end-of-sequence nil)) @@ -720,7 +720,7 @@ is blocked." Evaluate BODY with VAR bound to each value from ITERATOR. Return the value with which ITERATOR finished iteration." (declare (indent 1) - (debug ((symbolp form) body))) + (debug ((symbolp form) &rest sexp))) (let ((done-symbol (cps--gensym "iter-do-iterator-done")) (condition-symbol (cps--gensym "iter-do-condition")) (it-symbol (cps--gensym "iter-do-iterator")) diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index 065a9688770..513bd328899 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -166,15 +166,25 @@ arguments as NAME. DO is a function as defined in `gv-get'." ;; (`(expand ,expander) `(gv-define-expand ,name ,expander)) (_ (message "Unknown %s declaration %S" symbol handler) nil)))) +;; Additions for `declare'. We specify the values as named aliases so +;; that `describe-variable' prints something useful; cf. Bug#40491. + +;;;###autoload +(defsubst gv--expander-defun-declaration (&rest args) + (apply #'gv--defun-declaration 'gv-expander args)) + +;;;###autoload +(defsubst gv--setter-defun-declaration (&rest args) + (apply #'gv--defun-declaration 'gv-setter args)) + ;;;###autoload (or (assq 'gv-expander defun-declarations-alist) - (let ((x `(gv-expander - ,(apply-partially #'gv--defun-declaration 'gv-expander)))) + (let ((x (list 'gv-expander #'gv--expander-defun-declaration))) (push x macro-declarations-alist) (push x defun-declarations-alist))) ;;;###autoload (or (assq 'gv-setter defun-declarations-alist) - (push `(gv-setter ,(apply-partially #'gv--defun-declaration 'gv-setter)) + (push (list 'gv-setter #'gv--setter-defun-declaration) defun-declarations-alist)) ;; (defmacro gv-define-expand (name expander) @@ -214,7 +224,7 @@ The first arg in ARGLIST (the one that receives VAL) receives an expression which can do arbitrary things, whereas the other arguments are all guaranteed to be pure and copyable. Example use: (gv-define-setter aref (v a i) \\=`(aset ,a ,i ,v))" - (declare (indent 2) (debug (&define name sexp def-body))) + (declare (indent 2) (debug (&define name :name gv-setter sexp def-body))) `(gv-define-expander ,name (lambda (do &rest args) (declare-function diff --git a/lisp/emacs-lisp/hierarchy.el b/lisp/emacs-lisp/hierarchy.el new file mode 100644 index 00000000000..8cef029c4cf --- /dev/null +++ b/lisp/emacs-lisp/hierarchy.el @@ -0,0 +1,579 @@ +;;; hierarchy.el --- Library to create and display hierarchy structures -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Damien Cassou <damien@cassou.me> +;; Maintainer: emacs-devel@gnu.org + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Library to create, query, navigate and display hierarchy structures. + +;; Creation: After having created a hierarchy with `hierarchy-new', +;; populate it by calling `hierarchy-add-tree' or +;; `hierarchy-add-trees'. You can then optionally sort its element +;; with `hierarchy-sort'. + +;; Querying: You can learn more about your hierarchy by using +;; functions such as `hierarchy-roots', `hierarchy-has-item', +;; `hierarchy-length', `hierarchy-parent', `hierarchy-descendant-p'. + +;; Navigation: When your hierarchy is ready, you can use +;; `hierarchy-map-item', `hierarchy-map', and `map-tree' to apply +;; functions to elements of the hierarchy. + +;; Display: You can display a hierarchy as a tabulated list using +;; `hierarchy-tabulated-display' and as an expandable/foldable tree +;; using `hierarchy-convert-to-tree-widget'. The +;; `hierarchy-labelfn-*' functions will help you display each item of +;; the hierarchy the way you want it. + +;;; Limitation: + +;; - Current implementation uses #'equal to find and distinguish +;; elements. Support for user-provided equality definition is +;; desired but not yet implemented; +;; +;; - nil can't be added to a hierarchy; +;; +;; - the hierarchy is computed eagerly. + +;;; Code: + +(require 'seq) +(require 'map) +(require 'subr-x) +(require 'cl-lib) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Helpers +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(cl-defstruct (hierarchy + (:constructor hierarchy--make) + (:conc-name hierarchy--)) + (roots (list)) ; list of the hierarchy roots (no parent) + (parents (make-hash-table :test 'equal)) ; map an item to its parent + (children (make-hash-table :test 'equal)) ; map an item to its childre + ;; cache containing the set of all items in the hierarchy + (seen-items (make-hash-table :test 'equal))) ; map an item to t + +(defun hierarchy--seen-items-add (hierarchy item) + "In HIERARCHY, add ITEM to seen items." + (map-put! (hierarchy--seen-items hierarchy) item t)) + +(defun hierarchy--compute-roots (hierarchy) + "Search roots of HIERARCHY and return them." + (cl-set-difference + (map-keys (hierarchy--seen-items hierarchy)) + (map-keys (hierarchy--parents hierarchy)) + :test #'equal)) + +(defun hierarchy--sort-roots (hierarchy sortfn) + "Compute, sort and store the roots of HIERARCHY. + +SORTFN is a function taking two items of the hierarchy as parameter and +returning non-nil if the first parameter is lower than the second." + (setf (hierarchy--roots hierarchy) + (sort (hierarchy--compute-roots hierarchy) + sortfn))) + +(defun hierarchy--add-relation (hierarchy item parent acceptfn) + "In HIERARCHY, add ITEM as child of PARENT. + +ACCEPTFN is a function returning non-nil if its parameter (any object) +should be an item of the hierarchy." + (let* ((existing-parent (hierarchy-parent hierarchy item)) + (has-parent-p (funcall acceptfn existing-parent))) + (cond + ((and has-parent-p (not (equal existing-parent parent))) + (error "An item (%s) can only have one parent: '%s' vs '%s'" + item existing-parent parent)) + ((not has-parent-p) + (let ((existing-children (map-elt (hierarchy--children hierarchy) + parent (list)))) + (map-put! (hierarchy--children hierarchy) + parent (append existing-children (list item)))) + (map-put! (hierarchy--parents hierarchy) item parent))))) + +(defun hierarchy--set-equal (list1 list2 &rest cl-keys) + "Return non-nil if LIST1 and LIST2 have same elements. + +I.e., if every element of LIST1 also appears in LIST2 and if +every element of LIST2 also appears in LIST1. + +CL-KEYS are key-value pairs just like in `cl-subsetp'. Supported +keys are :key and :test." + (and (apply 'cl-subsetp list1 list2 cl-keys) + (apply 'cl-subsetp list2 list1 cl-keys))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Creation +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun hierarchy-new () + "Create a hierarchy and return it." + (hierarchy--make)) + +(defun hierarchy-add-tree (hierarchy item parentfn &optional childrenfn acceptfn) + "In HIERARCHY, add ITEM. + +PARENTFN is either nil or a function defining the child-to-parent +relationship: this function takes an item as parameter and should return +the parent of this item in the hierarchy. If the item has no parent in the +hierarchy (i.e., it should be a root), the function should return an object +not accepted by acceptfn (i.e., nil for the default value of acceptfn). + +CHILDRENFN is either nil or a function defining the parent-to-children +relationship: this function takes an item as parameter and should return a +list of children of this item in the hierarchy. + +If both PARENTFN and CHILDRENFN are non-nil, the results of PARENTFN and +CHILDRENFN are expected to be coherent with each other. + +ACCEPTFN is a function returning non-nil if its parameter (any object) +should be an item of the hierarchy. By default, ACCEPTFN returns non-nil +if its parameter is non-nil." + (unless (hierarchy-has-item hierarchy item) + (let ((acceptfn (or acceptfn #'identity))) + (hierarchy--seen-items-add hierarchy item) + (let ((parent (and parentfn (funcall parentfn item)))) + (when (funcall acceptfn parent) + (hierarchy--add-relation hierarchy item parent acceptfn) + (hierarchy-add-tree hierarchy parent parentfn childrenfn))) + (let ((children (and childrenfn (funcall childrenfn item)))) + (mapc (lambda (child) + (when (funcall acceptfn child) + (hierarchy--add-relation hierarchy child item acceptfn) + (hierarchy-add-tree hierarchy child parentfn childrenfn))) + children))))) + +(defun hierarchy-add-trees (hierarchy items parentfn &optional childrenfn acceptfn) + "Call `hierarchy-add-tree' on HIERARCHY and each element of ITEMS. + +PARENTFN, CHILDRENFN and ACCEPTFN have the same meaning as in `hierarchy-add'." + (seq-map (lambda (item) + (hierarchy-add-tree hierarchy item parentfn childrenfn acceptfn)) + items)) + +(defun hierarchy-add-list (hierarchy list &optional wrap childrenfn) + "Add to HIERARCHY the sub-lists in LIST. + +If WRAP is non-nil, allow duplicate items in LIST by wraping each +item in a cons (id . item). The root's id is 1. + +CHILDRENFN is a function (defaults to `cdr') taking LIST as a +parameter which should return LIST's children (a list). Each +child is (recursively) passed as a parameter to CHILDRENFN to get +its own children. Because of this parameter, LIST can be +anything, not necessarily a list." + (let* ((childrenfn (or childrenfn #'cdr)) + (id 0) + (wrapfn (lambda (item) + (if wrap + (cons (setq id (1+ id)) item) + item))) + (unwrapfn (if wrap #'cdr #'identity))) + (hierarchy-add-tree + hierarchy (funcall wrapfn list) nil + (lambda (item) + (mapcar wrapfn (funcall childrenfn + (funcall unwrapfn item))))) + hierarchy)) + +(defun hierarchy-from-list (list &optional wrap childrenfn) + "Create and return a hierarchy built from LIST. + +This function passes LIST, WRAP and CHILDRENFN unchanged to +`hierarchy-add-list'." + (hierarchy-add-list (hierarchy-new) list wrap childrenfn)) + +(defun hierarchy-sort (hierarchy &optional sortfn) + "Modify HIERARCHY so that its roots and item's children are sorted. + +SORTFN is a function taking two items of the hierarchy as parameter and +returning non-nil if the first parameter is lower than the second. By +default, SORTFN is `string-lessp'." + (let ((sortfn (or sortfn #'string-lessp))) + (hierarchy--sort-roots hierarchy sortfn) + (mapc (lambda (parent) + (setf + (map-elt (hierarchy--children hierarchy) parent) + (sort (map-elt (hierarchy--children hierarchy) parent) sortfn))) + (map-keys (hierarchy--children hierarchy))))) + +(defun hierarchy-extract-tree (hierarchy item) + "Return a copy of HIERARCHY with ITEM's descendants and parents." + (if (not (hierarchy-has-item hierarchy item)) + nil + (let ((tree (hierarchy-new))) + (hierarchy-add-tree tree item + (lambda (each) (hierarchy-parent hierarchy each)) + (lambda (each) + (when (or (equal each item) + (hierarchy-descendant-p hierarchy each item)) + (hierarchy-children hierarchy each)))) + tree))) + +(defun hierarchy-copy (hierarchy) + "Return a copy of HIERARCHY. + +Items in HIERARCHY are shared, but structure is not." + (hierarchy-map-hierarchy (lambda (item _) (identity item)) hierarchy)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Querying +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun hierarchy-items (hierarchy) + "Return a list of all items of HIERARCHY." + (map-keys (hierarchy--seen-items hierarchy))) + +(defun hierarchy-has-item (hierarchy item) + "Return t if HIERARCHY includes ITEM." + (map-contains-key (hierarchy--seen-items hierarchy) item)) + +(defun hierarchy-empty-p (hierarchy) + "Return t if HIERARCHY is empty." + (= 0 (hierarchy-length hierarchy))) + +(defun hierarchy-length (hierarchy) + "Return the number of items in HIERARCHY." + (hash-table-count (hierarchy--seen-items hierarchy))) + +(defun hierarchy-has-root (hierarchy item) + "Return t if one of HIERARCHY's roots is ITEM. + +A root is an item with no parent." + (seq-contains-p (hierarchy-roots hierarchy) item)) + +(defun hierarchy-roots (hierarchy) + "Return all roots of HIERARCHY. + +A root is an item with no parent." + (let ((roots (hierarchy--roots hierarchy))) + (or roots + (hierarchy--compute-roots hierarchy)))) + +(defun hierarchy-leafs (hierarchy &optional node) + "Return all leafs of HIERARCHY. + +A leaf is an item with no child. + +If NODE is an item of HIERARCHY, only return leafs under NODE." + (let ((leafs (cl-set-difference + (map-keys (hierarchy--seen-items hierarchy)) + (map-keys (hierarchy--children hierarchy))))) + (if (hierarchy-has-item hierarchy node) + (seq-filter (lambda (item) + (hierarchy-descendant-p hierarchy item node)) + leafs) + leafs))) + +(defun hierarchy-parent (hierarchy item) + "In HIERARCHY, return parent of ITEM." + (map-elt (hierarchy--parents hierarchy) item)) + +(defun hierarchy-children (hierarchy parent) + "In HIERARCHY, return children of PARENT." + (map-elt (hierarchy--children hierarchy) parent (list))) + +(defun hierarchy-child-p (hierarchy item1 item2) + "In HIERARCHY, return non-nil if and only if ITEM1 is a child of ITEM2." + (equal (hierarchy-parent hierarchy item1) item2)) + +(defun hierarchy-descendant-p (hierarchy item1 item2) + "In HIERARCHY, return non-nil if and only if ITEM1 is a descendant of ITEM2. + +ITEM1 is a descendant of ITEM2 if and only if both are items of HIERARCHY +and either: + +- ITEM1 is child of ITEM2, or +- ITEM1's parent is a descendant of ITEM2." + (and + (hierarchy-has-item hierarchy item1) + (hierarchy-has-item hierarchy item2) + (or + (hierarchy-child-p hierarchy item1 item2) + (hierarchy-descendant-p + hierarchy (hierarchy-parent hierarchy item1) item2)))) + +(defun hierarchy-equal (hierarchy1 hierarchy2) + "Return t if HIERARCHY1 and HIERARCHY2 are equal. + +Two equal hierarchies share the same items and the same +relationships among them." + (and (hierarchy-p hierarchy1) + (hierarchy-p hierarchy2) + (= (hierarchy-length hierarchy1) (hierarchy-length hierarchy2)) + ;; parents are the same + (seq-every-p (lambda (child) + (equal (hierarchy-parent hierarchy1 child) + (hierarchy-parent hierarchy2 child))) + (map-keys (hierarchy--parents hierarchy1))) + ;; children are the same + (seq-every-p (lambda (parent) + (hierarchy--set-equal + (hierarchy-children hierarchy1 parent) + (hierarchy-children hierarchy2 parent) + :test #'equal)) + (map-keys (hierarchy--children hierarchy1))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Navigation +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun hierarchy-map-item (func item hierarchy &optional indent) + "Return the result of applying FUNC to ITEM and its descendants in HIERARCHY. + +This function navigates the tree top-down: FUNCTION is first called on item +and then on each of its children. Results are concatenated in a list. + +INDENT is a number (default 0) representing the indentation of ITEM in +HIERARCHY. FUNC should take 2 argument: the item and its indentation +level." + (let ((indent (or indent 0))) + (cons + (funcall func item indent) + (seq-mapcat (lambda (child) (hierarchy-map-item func child + hierarchy (1+ indent))) + (hierarchy-children hierarchy item))))) + +(defun hierarchy-map (func hierarchy &optional indent) + "Return the result of applying FUNC to each element of HIERARCHY. + +This function navigates the tree top-down: FUNCTION is first called on each +root. To do so, it calls `hierarchy-map-item' on each root +sequentially. Results are concatenated in a list. + +FUNC should take 2 arguments: the item and its indentation level. + +INDENT is a number (default 0) representing the indentation of HIERARCHY's +roots." + (let ((indent (or indent 0))) + (seq-mapcat (lambda (root) (hierarchy-map-item func root hierarchy indent)) + (hierarchy-roots hierarchy)))) + +(defun hierarchy-map-tree (function hierarchy &optional item indent) + "Apply FUNCTION on each item of HIERARCHY under ITEM. + +This function navigates the tree bottom-up: FUNCTION is first called on +leafs and the result is passed as parameter when calling FUNCTION on +parents. + +FUNCTION should take 3 parameters: the current item, its indentation +level (a number), and a list representing the result of applying +`hierarchy-map-tree' to each child of the item. + +INDENT is 0 by default and is passed as second parameter to FUNCTION. +INDENT is incremented by 1 at each level of the tree. + +This function returns the result of applying FUNCTION to ITEM (the first +root if nil)." + (let ((item (or item (car (hierarchy-roots hierarchy)))) + (indent (or indent 0))) + (funcall function item indent + (mapcar (lambda (child) + (hierarchy-map-tree function hierarchy + child (1+ indent))) + (hierarchy-children hierarchy item))))) + +(defun hierarchy-map-hierarchy (function hierarchy) + "Apply FUNCTION to each item of HIERARCHY in a new hierarchy. + +FUNCTION should take 2 parameters, the current item and its +indentation level (a number), and should return an item to be +added to the new hierarchy." + (let* ((items (make-hash-table :test #'equal)) + (transform (lambda (item) (map-elt items item)))) + ;; Make 'items', a table mapping original items to their + ;; transformation + (hierarchy-map (lambda (item indent) + (map-put! items item (funcall function item indent))) + hierarchy) + (hierarchy--make + :roots (mapcar transform (hierarchy-roots hierarchy)) + :parents (let ((result (make-hash-table :test #'equal))) + (map-apply (lambda (child parent) + (map-put! result + (funcall transform child) + (funcall transform parent))) + (hierarchy--parents hierarchy)) + result) + :children (let ((result (make-hash-table :test #'equal))) + (map-apply (lambda (parent children) + (map-put! result + (funcall transform parent) + (seq-map transform children))) + (hierarchy--children hierarchy)) + result) + :seen-items (let ((result (make-hash-table :test #'equal))) + (map-apply (lambda (item v) + (map-put! result + (funcall transform item) + v)) + (hierarchy--seen-items hierarchy)) + result)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Display +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun hierarchy-labelfn-indent (labelfn &optional indent-string) + "Return a function rendering LABELFN indented with INDENT-STRING. + +INDENT-STRING defaults to a 2-space string. Indentation is +multiplied by the depth of the displayed item." + (let ((indent-string (or indent-string " "))) + (lambda (item indent) + (dotimes (_ indent) (insert indent-string)) + (funcall labelfn item indent)))) + +(defun hierarchy-labelfn-button (labelfn actionfn) + "Return a function rendering LABELFN in a button. + +Clicking the button triggers ACTIONFN. ACTIONFN is a function +taking an item of HIERARCHY and an indentation value (a number) +as input. This function is called when an item is clicked. The +return value of ACTIONFN is ignored." + (lambda (item indent) + (let ((start (point))) + (funcall labelfn item indent) + (make-text-button start (point) + 'action (lambda (_) (funcall actionfn item indent)))))) + +(defun hierarchy-labelfn-button-if (labelfn buttonp actionfn) + "Return a function rendering LABELFN as a button if BUTTONP. + +Pass LABELFN and ACTIONFN to `hierarchy-labelfn-button' if +BUTTONP is non-nil. Otherwise, render LABELFN without making it +a button. + +BUTTONP is a function taking an item of HIERARCHY and an +indentation value (a number) as input." + (lambda (item indent) + (if (funcall buttonp item indent) + (funcall (hierarchy-labelfn-button labelfn actionfn) item indent) + (funcall labelfn item indent)))) + +(defun hierarchy-labelfn-to-string (labelfn item indent) + "Execute LABELFN on ITEM and INDENT. Return result as a string." + (with-temp-buffer + (funcall labelfn item indent) + (buffer-substring (point-min) (point-max)))) + +(defun hierarchy-print (hierarchy &optional to-string) + "Insert HIERARCHY in current buffer as plain text. + +Use TO-STRING to convert each element to a string. TO-STRING is +a function taking an item of HIERARCHY as input and returning a +string. If nil, TO-STRING defaults to a call to `format' with \"%s\"." + (let ((to-string (or to-string (lambda (item) (format "%s" item))))) + (hierarchy-map + (hierarchy-labelfn-indent (lambda (item _) + (insert (funcall to-string item) "\n"))) + hierarchy))) + +(defun hierarchy-to-string (hierarchy &optional to-string) + "Return a string representing HIERARCHY. + +TO-STRING is passed unchanged to `hierarchy-print'." + (with-temp-buffer + (hierarchy-print hierarchy to-string) + (buffer-substring (point-min) (point-max)))) + +(defun hierarchy-tabulated-imenu-action (_item-name position) + "Move to ITEM-NAME at POSITION in current buffer." + (goto-char position) + (back-to-indentation)) + +(define-derived-mode hierarchy-tabulated-mode tabulated-list-mode "Hierarchy tabulated" + "Major mode to display a hierarchy as a tabulated list." + (setq-local imenu-generic-expression + ;; debbugs: 26457 - Cannot pass a function to + ;; imenu-generic-expression. Add + ;; `hierarchy-tabulated-imenu-action' to the end of the + ;; list when bug is fixed + '(("Item" "^[[:space:]]+\\(?1:.+\\)$" 1)))) + +(defun hierarchy-tabulated-display (hierarchy labelfn &optional buffer) + "Display HIERARCHY as a tabulated list in `hierarchy-tabulated-mode'. + +LABELFN is a function taking an item of HIERARCHY and an indentation +level (a number) as input and inserting a string to be displayed in the +table. + +The tabulated list is displayed in BUFFER, or a newly created buffer if +nil. The buffer is returned." + (let ((buffer (or buffer (generate-new-buffer "hierarchy-tabulated")))) + (with-current-buffer buffer + (hierarchy-tabulated-mode) + (setq tabulated-list-format + (vector '("Item name" 0 nil))) + (setq tabulated-list-entries + (hierarchy-map (lambda (item indent) + (list item (vector (hierarchy-labelfn-to-string + labelfn item indent)))) + hierarchy)) + (tabulated-list-init-header) + (tabulated-list-print)) + buffer)) + +(declare-function widget-convert "wid-edit") +(defun hierarchy-convert-to-tree-widget (hierarchy labelfn) + "Return a tree-widget for HIERARCHY. + +LABELFN is a function taking an item of HIERARCHY and an indentation +value (a number) as parameter and inserting a string to be displayed as a +node label." + (require 'wid-edit) + (require 'tree-widget) + (hierarchy-map-tree (lambda (item indent children) + (widget-convert + 'tree-widget + :tag (hierarchy-labelfn-to-string labelfn item indent) + :args children)) + hierarchy)) + +(defun hierarchy-tree-display (hierarchy labelfn &optional buffer) + "Display HIERARCHY as a tree widget in a new buffer. + +HIERARCHY and LABELFN are passed unchanged to +`hierarchy-convert-to-tree-widget'. + +The tree widget is displayed in BUFFER, or a newly created buffer if +nil. The buffer is returned." + (let ((buffer (or buffer (generate-new-buffer "*hierarchy-tree*"))) + (tree-widget (hierarchy-convert-to-tree-widget hierarchy labelfn))) + (with-current-buffer buffer + (setq-local buffer-read-only t) + (let ((inhibit-read-only t)) + (erase-buffer) + (widget-create tree-widget) + (goto-char (point-min)) + (special-mode))) + buffer)) + +(provide 'hierarchy) + +;;; hierarchy.el ends here 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 fa857cd4c6b..1311d94cb01 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -456,7 +456,7 @@ This will generate compile-time constants from BINDINGS." (,(concat "\\_<:" lisp-mode-symbol-regexp "\\_>") (0 font-lock-builtin-face)) ;; ELisp and CLisp `&' keywords as types. - (,(concat "\\_<\\&" lisp-mode-symbol-regexp "\\_>") + (,(concat "\\_<&" lisp-mode-symbol-regexp "\\_>") . font-lock-type-face) ;; ELisp regexp grouping constructs (,(lambda (bound) @@ -511,7 +511,7 @@ This will generate compile-time constants from BINDINGS." (,(concat "\\_<:" lisp-mode-symbol-regexp "\\_>") (0 font-lock-builtin-face)) ;; ELisp and CLisp `&' keywords as types. - (,(concat "\\_<\\&" lisp-mode-symbol-regexp "\\_>") + (,(concat "\\_<&" lisp-mode-symbol-regexp "\\_>") . font-lock-type-face) ;; This is too general -- rms. ;; A user complained that he has functions whose names start with `do' @@ -611,6 +611,8 @@ Value for `adaptive-fill-function'." ;; a single docstring. Let's fix it here. (if (looking-at "\\s-+\"[^\n\"]+\"\\s-*$") "")) +;; Maybe this should be discouraged/obsoleted and users should be +;; encouraged to use `lisp-data-mode` instead. (defun lisp-mode-variables (&optional lisp-syntax keywords-case-insensitive elisp) "Common initialization routine for lisp modes. @@ -658,6 +660,14 @@ font-lock keywords will not be case sensitive." (setq-local electric-pair-skip-whitespace 'chomp) (setq-local electric-pair-open-newline-between-pairs nil)) +;;;###autoload +(define-derived-mode lisp-data-mode prog-mode "Lisp-Data" + "Major mode for buffers holding data written in Lisp syntax." + :group 'lisp + (lisp-mode-variables t t nil) + (setq-local electric-quote-string t) + (setq imenu-case-fold-search nil)) + (defun lisp-outline-level () "Lisp mode `outline-level' function." (let ((len (- (match-end 0) (match-beginning 0)))) @@ -737,7 +747,7 @@ font-lock keywords will not be case sensitive." "Keymap for ordinary Lisp mode. All commands in `lisp-mode-shared-map' are inherited by this map.") -(define-derived-mode lisp-mode prog-mode "Lisp" +(define-derived-mode lisp-mode lisp-data-mode "Lisp" "Major mode for editing Lisp code for Lisps other than GNU Emacs Lisp. Commands: Delete converts tabs to spaces as it moves back. @@ -746,10 +756,10 @@ Blank lines separate paragraphs. Semicolons start comments. \\{lisp-mode-map} 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]\\)\\(\\\\\\\\\\)*\\)\\(;+\\|#|\\) *") + "\\(\\(^\\|[^\\\n]\\)\\(\\\\\\\\\\)*\\)\\(;+\\|#|\\) *") (setq imenu-case-fold-search t)) (defun lisp-find-tag-default () @@ -946,6 +956,7 @@ is the buffer position of the start of the containing expression." ;; setting this to a number inhibits calling hook (desired-indent nil) (retry t) + whitespace-after-open-paren calculate-lisp-indent-last-sexp containing-sexp) (cond ((or (markerp parse-start) (integerp parse-start)) (goto-char parse-start)) @@ -975,6 +986,7 @@ is the buffer position of the start of the containing expression." nil ;; Innermost containing sexp found (goto-char (1+ containing-sexp)) + (setq whitespace-after-open-paren (looking-at (rx whitespace))) (if (not calculate-lisp-indent-last-sexp) ;; indent-point immediately follows open paren. ;; Don't call hook. @@ -989,9 +1001,11 @@ is the buffer position of the start of the containing expression." calculate-lisp-indent-last-sexp) ;; This is the first line to start within the containing sexp. ;; It's almost certainly a function call. - (if (= (point) calculate-lisp-indent-last-sexp) + (if (or (= (point) calculate-lisp-indent-last-sexp) + whitespace-after-open-paren) ;; Containing sexp has nothing before this line - ;; except the first element. Indent under that element. + ;; except the first element, or the first element is + ;; preceded by whitespace. Indent under that element. nil ;; Skip the first element, find start of second (the first ;; argument of the function call) and indent under. diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el index 043cf01d2e9..8c18557c79a 100644 --- a/lisp/emacs-lisp/lisp.el +++ b/lisp/emacs-lisp/lisp.el @@ -482,7 +482,8 @@ is called as a function to find the defun's end." (if (looking-at "\\s<\\|\n") (forward-line 1)))))) (funcall end-of-defun-function) - (funcall skip) + (when (<= arg 1) + (funcall skip)) (cond ((> arg 0) ;; Moving forward. 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 7d6be3cf4e2..e6f54d206d8 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -397,6 +397,26 @@ synchronously." :type 'boolean :version "25.1") +(defcustom package-name-column-width 30 + "Column width for the Package name in the package menu." + :type 'number + :version "28.1") + +(defcustom package-version-column-width 14 + "Column width for the Package version in the package menu." + :type 'number + :version "28.1") + +(defcustom package-status-column-width 12 + "Column width for the Package status in the package menu." + :type 'number + :version "28.1") + +(defcustom package-archive-column-width 8 + "Column width for the Package status in the package menu." + :type 'number + :version "28.1") + ;;; `package-desc' object definition ;; This is the struct used internally to represent packages. @@ -421,9 +441,9 @@ synchronously." &aux (name (intern name-string)) (version (version-to-list version-string)) - (reqs (mapcar #'(lambda (elt) - (list (car elt) - (version-to-list (cadr elt)))) + (reqs (mapcar (lambda (elt) + (list (car elt) + (version-to-list (cadr elt)))) (if (eq 'quote (car requirements)) (nth 1 requirements) requirements))) @@ -670,9 +690,9 @@ updates `package-alist'." (progn (package-load-all-descriptors) package-alist))) -(defun define-package (_name-string _version-string - &optional _docstring _requirements - &rest _extra-properties) +(defun define-package ( _name-string _version-string + &optional _docstring _requirements + &rest _extra-properties) "Define a new package. NAME-STRING is the name of the package, as a string. VERSION-STRING is the version of the package, as a string. @@ -798,7 +818,7 @@ correspond to previously loaded files (those returned by ;; FIXME: not the friendliest, but simple. (require 'info) (info-initialize) - (push pkg-dir Info-directory-list)) + (add-to-list 'Info-directory-list pkg-dir)) (push name package-activated-list) ;; Don't return nil. t))) @@ -926,7 +946,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 @@ -1200,8 +1219,8 @@ The return result is a `package-desc'." cipher-algorithm digest-algorithm compress-algorithm)) -(declare-function epg-verify-string "epg" (context signature - &optional signed-text)) +(declare-function epg-verify-string "epg" ( context signature + &optional signed-text)) (declare-function epg-context-result-for "epg" (context name)) (declare-function epg-signature-status "epg" (signature) t) (declare-function epg-signature-to-string "epg" (signature)) @@ -2082,7 +2101,8 @@ to install it but still mark it as selected." (package-compute-transaction () (list (list pkg)))))) (progn (package-download-transaction transaction) - (package--quickstart-maybe-refresh)) + (package--quickstart-maybe-refresh) + (message "Package `%s' installed." name)) (message "`%s' is already installed" name)))) (defun package-strip-rcs-id (str) @@ -2377,18 +2397,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 +2594,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 +2700,19 @@ 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) + (define-key map (kbd "/ m") 'package-menu-filter-marked) map) "Local keymap for `package-menu-mode' buffers.") @@ -2729,8 +2738,12 @@ 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"] + ["Filter Marked" package-menu-filter-marked :help "Filter packages marked for upgrade"] ["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"] @@ -2757,11 +2770,11 @@ Letters do not insert themselves; instead, they are commands. (package-menu--transaction-status package-menu--transaction-status))) (setq tabulated-list-format - `[("Package" 18 package-menu--name-predicate) - ("Version" 13 package-menu--version-predicate) - ("Status" 10 package-menu--status-predicate) + `[("Package" ,package-name-column-width package-menu--name-predicate) + ("Version" ,package-version-column-width package-menu--version-predicate) + ("Status" ,package-status-column-width package-menu--status-predicate) ,@(if (cdr package-archives) - '(("Archive" 10 package-menu--archive-predicate))) + `(("Archive" ,package-archive-column-width package-menu--archive-predicate))) ("Description" 0 package-menu--description-predicate)]) (setq tabulated-list-padding 2) (setq tabulated-list-sort-key (cons "Status" nil)) @@ -3040,8 +3053,21 @@ 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. If REMEMBER-POS is non-nil, keep point on the same entry. PACKAGES should be t, which means to display all known packages, or a list of package names (symbols) to display. @@ -3049,13 +3075,10 @@ 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'. @@ -3699,48 +3722,192 @@ 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 ","))))) (define-obsolete-function-alias 'package-menu-filter #'package-menu-filter-by-keyword "27.1") (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-filter-marked () + "Filter \"*Packages*\" buffer by non-empty upgrade mark. +Unlike other filters, this leaves the marks intact." + (interactive) + (package--ensure-package-menu-mode) + (widen) + (let (found-entries mark pkg-id entry marks) + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (setq mark (char-after)) + (unless (eq mark ?\s) + (setq pkg-id (tabulated-list-get-id)) + (setq entry (package-menu--print-info-simple pkg-id)) + (push entry found-entries) + ;; remember the mark + (push (cons pkg-id mark) marks)) + (forward-line)) + (if found-entries + (progn + (setq tabulated-list-entries found-entries) + (package-menu--display t nil) + ;; redo the marks, but we must remember the marks!! + (goto-char (point-min)) + (while (not (eobp)) + (setq mark (cdr (assq (tabulated-list-get-id) marks))) + (tabulated-list-put-tag (char-to-string mark) t))) + (user-error "No packages found"))))) (defun package-menu-clear-filter () "Clear any filter currently applied to the \"*Packages*\" buffer." @@ -3789,6 +3956,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/pcase.el b/lisp/emacs-lisp/pcase.el index 36b93fa7ac5..a8ce23284c4 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -344,7 +344,8 @@ of the elements of LIST is performed as if by `pcase-let'. (seen '()) (codegen (lambda (code vars) - (let ((prev (assq code seen))) + (let ((vars (pcase--fgrep vars code)) + (prev (assq code seen))) (if (not prev) (let ((res (pcase-codegen code vars))) (push (list code vars res) seen) @@ -398,7 +399,10 @@ of the elements of LIST is performed as if by `pcase-let'. (if (pcase--small-branch-p (cdr case)) ;; Don't bother sharing multiple ;; occurrences of this leaf since it's small. - #'pcase-codegen codegen) + (lambda (code vars) + (pcase-codegen code + (pcase--fgrep vars code))) + codegen) (cdr case) vars)))) cases)))) @@ -687,14 +691,22 @@ MATCH is the pattern that needs to be matched, of the form: '(nil . :pcase--fail) '(:pcase--fail . nil)))))) -(defun pcase--fgrep (vars sexp) - "Check which of the symbols VARS appear in SEXP." +(defun pcase--fgrep (bindings sexp) + "Return those of the BINDINGS which might be used in SEXP." (let ((res '())) - (while (consp sexp) - (dolist (var (pcase--fgrep vars (pop sexp))) - (unless (memq var res) (push var res)))) - (and (memq sexp vars) (not (memq sexp res)) (push sexp res)) - res)) + (while (and (consp sexp) bindings) + (dolist (binding (pcase--fgrep bindings (pop sexp))) + (push binding res) + (setq bindings (remove binding bindings)))) + (if (vectorp sexp) + ;; With backquote, code can appear within vectors as well. + ;; This wouldn't be needed if we `macroexpand-all' before + ;; calling pcase--fgrep, OTOH. + (pcase--fgrep bindings (mapcar #'identity sexp)) + (let ((tmp (assq sexp bindings))) + (if tmp + (cons tmp res) + res))))) (defun pcase--self-quoting-p (upat) (or (keywordp upat) (integerp upat) (stringp upat))) @@ -734,13 +746,11 @@ MATCH is the pattern that needs to be matched, of the form: "Build a function call to FUN with arg ARG." (if (symbolp fun) `(,fun ,arg) - (let* (;; `vs' is an upper bound on the vars we need. - (vs (pcase--fgrep (mapcar #'car vars) fun)) - (env (mapcar (lambda (var) - (list var (cdr (assq var vars)))) - vs)) + (let* (;; `env' is an upper bound on the bindings we need. + (env (mapcar (lambda (x) (list (car x) (cdr x))) + (pcase--fgrep vars fun))) (call (progn - (when (memq arg vs) + (when (assq arg env) ;; `arg' is shadowed by `env'. (let ((newsym (gensym "x"))) (push (list newsym arg) env) @@ -748,7 +758,7 @@ MATCH is the pattern that needs to be matched, of the form: (if (functionp fun) `(funcall #',fun ,arg) `(,@fun ,arg))))) - (if (null vs) + (if (null env) call ;; Let's not replace `vars' in `fun' since it's ;; too difficult to do it right, instead just @@ -759,10 +769,12 @@ MATCH is the pattern that needs to be matched, of the form: "Build an expression that will evaluate EXP." (let* ((found (assq exp vars))) (if found (cdr found) - (let* ((vs (pcase--fgrep (mapcar #'car vars) exp)) - (env (mapcar (lambda (v) (list v (cdr (assq v vars)))) - vs))) - (if env (macroexp-let* env exp) exp))))) + (let* ((env (pcase--fgrep vars exp))) + (if env + (macroexp-let* (mapcar (lambda (x) (list (car x) (cdr x))) + env) + exp) + exp))))) ;; It's very tempting to use `pcase' below, tho obviously, it'd create ;; bootstrapping problems. diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el index aa4b2addd47..88bb0a8bd6c 100644 --- a/lisp/emacs-lisp/rx.el +++ b/lisp/emacs-lisp/rx.el @@ -1381,7 +1381,7 @@ To make local rx extensions, use `rx-let' for `rx', For more details, see Info node `(elisp) Extending Rx'. \(fn NAME [(ARGS...)] RX)" - (declare (indent 1)) + (declare (indent defun)) `(eval-and-compile (put ',name 'rx-definition ',(rx--make-binding name definition)) ',name)) diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index e3037a71901..1cc68e19edd 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -348,6 +348,7 @@ If SEQUENCE is empty, return INITIAL-VALUE and FUNCTION is not called." (setq acc (funcall function acc elt))) acc))) +;;;###autoload (cl-defgeneric seq-every-p (pred sequence) "Return non-nil if (PRED element) is non-nil for all elements of SEQUENCE." (catch 'seq--break @@ -491,6 +492,7 @@ keys. Keys are compared using `equal'." SEQUENCE must be a sequence of numbers or markers." (apply #'min (seq-into sequence 'list))) +;;;###autoload (cl-defgeneric seq-max (sequence) "Return the largest element of SEQUENCE. SEQUENCE must be a sequence of numbers or markers." diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el index 60d8fa591e9..38a7b8b54c9 100644 --- a/lisp/emacs-lisp/smie.el +++ b/lisp/emacs-lisp/smie.el @@ -52,6 +52,13 @@ ;; error because the parser just automatically does something. Better yet, ;; we can afford to use a sloppy grammar. +;; The benefits of this approach were presented in the following article, +;; which includes a kind of tutorial to get started with SMIE: +;; +;; SMIE: Weakness is Power! Auto-indentation with incomplete information +;; Stefan Monnier, <Programming> Journal 2020, volumn 5, issue 1. +;; doi: 10.22152/programming-journal.org/2020/5/1 + ;; A good background to understand the development (especially the parts ;; building the 2D precedence tables and then computing the precedence levels ;; from it) can be found in pages 187-194 of "Parsing techniques" by Dick Grune @@ -63,6 +70,7 @@ ;; Since then, some of that code has been beaten into submission, but the ;; smie-indent-keyword is still pretty obscure. + ;; Conflict resolution: ;; ;; - One source of conflicts is when you have: @@ -1356,9 +1364,9 @@ Only meaningful when called from within `smie-rules-function'." (funcall smie-rules-function :elem 'basic)) smie-indent-basic)) -(defun smie-indent--rule (method token - ;; FIXME: Too many parameters. - &optional after parent base-pos) +(defun smie-indent--rule ( method token + ;; FIXME: Too many parameters. + &optional after parent base-pos) "Compute indentation column according to `smie-rules-function'. METHOD and TOKEN are passed to `smie-rules-function'. AFTER is the position after TOKEN, if known. diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index 044c9aada0d..9f96ac50d1c 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -236,6 +236,15 @@ REGEXP defaults to \"[ \\t\\n\\r]+\"." TRIM-LEFT and TRIM-RIGHT default to \"[ \\t\\n\\r]+\"." (string-trim-left (string-trim-right string trim-right) trim-left)) +;;;###autoload +(defun string-truncate-left (string length) + "Truncate STRING to LENGTH, replacing initial surplus with \"...\"." + (let ((strlen (length string))) + (if (<= strlen length) + string + (setq length (max 0 (- length 3))) + (concat "..." (substring string (max 0 (- strlen 1 length))))))) + (defsubst string-blank-p (string) "Check whether STRING is either empty or only whitespace. The following characters count as whitespace here: space, tab, newline and diff --git a/lisp/emacs-lisp/syntax.el b/lisp/emacs-lisp/syntax.el index 11cc1988b1f..ce495af95bc 100644 --- a/lisp/emacs-lisp/syntax.el +++ b/lisp/emacs-lisp/syntax.el @@ -63,9 +63,10 @@ override the buffer's syntax table for special syntactic constructs that cannot be handled just by the buffer's syntax-table. The specified function may call `syntax-ppss' on any position -before END, but it should not call `syntax-ppss-flush-cache', -which means that it should not call `syntax-ppss' on some -position and later modify the buffer on some earlier position.") +before END, but if it calls `syntax-ppss' on some +position and later modifies the buffer on some earlier position, +then it is its responsability to call `syntax-ppss-flush-cache' to flush +the now obsolete ppss info from the cache.") (defvar syntax-propertize-chunk-size 500) @@ -138,14 +139,28 @@ delimiter or an Escaped or Char-quoted character.")) (point-max)))) (cons beg end)) -(defun syntax-propertize--shift-groups (re n) - (replace-regexp-in-string - "\\\\(\\?\\([0-9]+\\):" - (lambda (s) - (replace-match - (number-to-string (+ n (string-to-number (match-string 1 s)))) - t t s 1)) - re t t)) +(defun syntax-propertize--shift-groups-and-backrefs (re n) + (let ((new-re (replace-regexp-in-string + "\\\\(\\?\\([0-9]+\\):" + (lambda (s) + (replace-match + (number-to-string + (+ n (string-to-number (match-string 1 s)))) + t t s 1)) + re t t)) + (pos 0)) + (while (string-match "\\\\\\([0-9]+\\)" new-re pos) + (setq pos (+ 1 (match-beginning 1))) + (when (save-match-data + ;; With \N, the \ must be in a subregexp context, i.e., + ;; not in a character class or in a \{\} repetition. + (subregexp-context-p new-re (match-beginning 0))) + (let ((shifted (+ n (string-to-number (match-string 1 new-re))))) + (when (> shifted 9) + (error "There may be at most nine back-references")) + (setq new-re (replace-match (number-to-string shifted) + t t new-re 1))))) + new-re)) (defmacro syntax-propertize-precompile-rules (&rest rules) "Return a precompiled form of RULES to pass to `syntax-propertize-rules'. @@ -189,7 +204,8 @@ for subsequent HIGHLIGHTs. Also SYNTAX is free to move point, in which case RULES may not be applied to some parts of the text or may be applied several times to other parts. -Note: back-references in REGEXPs do not work." +Note: There may be at most nine back-references in the REGEXPs of +all RULES in total." (declare (debug (&rest &or symbolp ;FIXME: edebug this eval step. (form &rest (numberp @@ -218,7 +234,7 @@ Note: back-references in REGEXPs do not work." ;; tell when *this* match 0 has succeeded. (cl-incf offset) (setq re (concat "\\(" re "\\)"))) - (setq re (syntax-propertize--shift-groups re offset)) + (setq re (syntax-propertize--shift-groups-and-backrefs re offset)) (let ((code '()) (condition (cond @@ -320,6 +336,11 @@ END) suitable for `syntax-propertize-function'." (defvar-local syntax-ppss-table nil "Syntax-table to use during `syntax-ppss', if any.") +(defvar-local syntax-propertize--inhibit-flush nil + "If non-nil, `syntax-ppss-flush-cache' only flushes the ppss cache. +Otherwise it flushes both the ppss cache and the properties +set by `syntax-propertize'") + (defun syntax-propertize (pos) "Ensure that syntax-table properties are set until POS (a buffer point)." (when (< syntax-propertize--done pos) @@ -345,23 +366,27 @@ END) suitable for `syntax-propertize-function'." (end (max pos (min (point-max) (+ start syntax-propertize-chunk-size)))) - (funs syntax-propertize-extend-region-functions)) - (while funs - (let ((new (funcall (pop funs) start end)) - ;; Avoid recursion! - (syntax-propertize--done most-positive-fixnum)) - (if (or (null new) - (and (>= (car new) start) (<= (cdr new) end))) - nil - (setq start (car new)) - (setq end (cdr new)) - ;; If there's been a change, we should go through the - ;; list again since this new position may - ;; warrant a different answer from one of the funs we've - ;; already seen. - (unless (eq funs - (cdr syntax-propertize-extend-region-functions)) - (setq funs syntax-propertize-extend-region-functions))))) + (first t) + (repeat t)) + (while repeat + (setq repeat nil) + (run-hook-wrapped + 'syntax-propertize-extend-region-functions + (lambda (f) + (let ((new (funcall f start end)) + ;; Avoid recursion! + (syntax-propertize--done most-positive-fixnum)) + (if (or (null new) + (and (>= (car new) start) (<= (cdr new) end))) + nil + (setq start (car new)) + (setq end (cdr new)) + ;; If there's been a change, we should go through the + ;; list again since this new position may + ;; warrant a different answer from one of the funs we've + ;; already seen. + (unless first (setq repeat t)))) + (setq first nil)))) ;; Flush ppss cache between the original value of `start' and that ;; set above by syntax-propertize-extend-region-functions. (syntax-ppss-flush-cache start) @@ -371,8 +396,13 @@ END) suitable for `syntax-propertize-function'." ;; (message "syntax-propertizing from %s to %s" start end) (remove-text-properties start end '(syntax-table nil syntax-multiline nil)) - ;; Avoid recursion! - (let ((syntax-propertize--done most-positive-fixnum)) + ;; Make sure we only let-bind it buffer-locally. + (make-local-variable 'syntax-propertize--inhibit-flush) + ;; Let-bind `syntax-propertize--done' to avoid infinite recursion! + (let ((syntax-propertize--done most-positive-fixnum) + ;; Let `syntax-propertize-function' call + ;; `syntax-ppss-flush-cache' without worries. + (syntax-propertize--inhibit-flush t)) (funcall syntax-propertize-function start end))))))))) ;;; Link syntax-propertize with syntax.c. @@ -451,7 +481,8 @@ These are valid when the buffer has no restriction.") (defun syntax-ppss-flush-cache (beg &rest ignored) "Flush the cache of `syntax-ppss' starting at position BEG." ;; Set syntax-propertize to refontify anything past beg. - (setq syntax-propertize--done (min beg syntax-propertize--done)) + (unless syntax-propertize--inhibit-flush + (setq syntax-propertize--done (min beg syntax-propertize--done))) ;; Flush invalid cache entries. (dolist (cell (list syntax-ppss-wide syntax-ppss-narrow)) (pcase cell 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/emacs-lisp/text-property-search.el b/lisp/emacs-lisp/text-property-search.el index b6e98f59a7a..61bd98d3cfe 100644 --- a/lisp/emacs-lisp/text-property-search.el +++ b/lisp/emacs-lisp/text-property-search.el @@ -137,11 +137,19 @@ and if a matching region is found, moves point to its beginning." nil) ;; We're standing in the property we're looking for, so find the ;; end. - ((and (text-property--match-p - value (get-text-property (1- (point)) property) - predicate) - (not not-current)) - (text-property--find-end-backward (1- (point)) property value predicate)) + ((text-property--match-p + value (get-text-property (1- (point)) property) + predicate) + (let ((origin (point)) + (match (text-property--find-end-backward + (1- (point)) property value predicate))) + ;; When we want to ignore the current element, then repeat the + ;; search if we haven't moved out of it yet. + (if (and not-current + (equal (get-text-property (point) property) + (get-text-property origin property))) + (text-property-search-backward property value predicate) + match))) (t (let ((origin (point)) (ended nil) diff --git a/lisp/emacs-lisp/timer-list.el b/lisp/emacs-lisp/timer-list.el index 4fa31f32673..00d09696d2a 100644 --- a/lisp/emacs-lisp/timer-list.el +++ b/lisp/emacs-lisp/timer-list.el @@ -32,41 +32,49 @@ "List all timers in a buffer." (interactive) (pop-to-buffer-same-window (get-buffer-create "*timer-list*")) - (let ((inhibit-read-only t)) - (erase-buffer) - (timer-list-mode) - (dolist (timer (append timer-list timer-idle-list)) - (insert (format "%4s %10s %8s %s" - ;; Idle. - (if (aref timer 7) "*" " ") - ;; Next time. - (let ((time (list (aref timer 1) - (aref timer 2) - (aref timer 3)))) - (format "%.2f" - (float-time - (if (aref timer 7) - time - (time-subtract time nil))))) - ;; Repeat. - (let ((repeat (aref timer 4))) - (cond - ((numberp repeat) - (format "%.2f" (/ repeat 60))) - ((null repeat) - "-") - (t - (format "%s" repeat)))) - ;; Function. - (let ((cl-print-compiled 'static) - (cl-print-compiled-button nil) - (print-escape-newlines t)) - (cl-prin1-to-string (aref timer 5))))) - (put-text-property (line-beginning-position) - (1+ (line-beginning-position)) - 'timer timer) - (insert "\n"))) - (goto-char (point-min))) + (timer-list-mode) + (tabulated-list-init-header) + (setq tabulated-list-entries + (mapcar + (lambda (timer) + (list + nil + `[ ;; Idle. + ,(propertize + (if (aref timer 7) " *" " ") + 'help-echo "* marks idle timers" + 'timer timer) + ;; Next time. + ,(propertize + (let ((time (list (aref timer 1) + (aref timer 2) + (aref timer 3)))) + (format "%10.2f" + (float-time + (if (aref timer 7) + time + (time-subtract time nil))))) + 'help-echo "Time in sec till next invocation") + ;; Repeat. + ,(propertize + (let ((repeat (aref timer 4))) + (cond + ((numberp repeat) + (format "%8.1f" repeat)) + ((null repeat) + " -") + (t + (format "%8s" repeat)))) + 'help-echo "Symbol: repeat; number: repeat interval in sec") + ;; Function. + ,(propertize + (let ((cl-print-compiled 'static) + (cl-print-compiled-button nil) + (print-escape-newlines t)) + (cl-prin1-to-string (aref timer 5))) + 'help-echo "Function called by timer")])) + (append timer-list timer-idle-list))) + (tabulated-list-print)) ;; This command can be destructive if they don't know what they are ;; doing. Kids, don't try this at home! ;;;###autoload (put 'list-timers 'disabled "Beware: manually canceling timers can ruin your Emacs session.") @@ -74,24 +82,47 @@ (defvar timer-list-mode-map (let ((map (make-sparse-keymap))) (define-key map "c" 'timer-list-cancel) - (define-key map "n" 'next-line) - (define-key map "p" 'previous-line) (easy-menu-define nil map "" '("Timers" ["Cancel" timer-list-cancel t])) map)) -(define-derived-mode timer-list-mode special-mode "Timer-List" +(define-derived-mode timer-list-mode tabulated-list-mode "Timer-List" "Mode for listing and controlling timers." - (setq bidi-paragraph-direction 'left-to-right) - (setq truncate-lines t) (buffer-disable-undo) (setq-local revert-buffer-function #'list-timers) - (setq buffer-read-only t) - (setq header-line-format - (concat (propertize " " 'display '(space :align-to 0)) - (format "%4s %10s %8s %s" - "Idle" "Next" "Repeat" "Function")))) + (setq tabulated-list-format + '[("Idle" 6 timer-list--idle-predicate) + (" Next" 12 timer-list--next-predicate) + (" Repeat" 11 timer-list--repeat-predicate) + ("Function" 10 timer-list--function-predicate)])) + +(defun timer-list--idle-predicate (A B) + "Predicate to sort Timer-List by the Idle column." + (let ((iA (aref (cadr A) 0)) + (iB (aref (cadr B) 0))) + (cond ((string= iA iB) + (timer-list--next-predicate A B)) + ((string= iA " *") nil) + (t t)))) + +(defun timer-list--next-predicate (A B) + "Predicate to sort Timer-List by the Next column." + (let ((nA (string-to-number (aref (cadr A) 1))) + (nB (string-to-number (aref (cadr B) 1)))) + (< nA nB))) + +(defun timer-list--repeat-predicate (A B) + "Predicate to sort Timer-List by the Repeat column." + (let ((rA (aref (cadr A) 2)) + (rB (aref (cadr B) 2))) + (string< rA rB))) + +(defun timer-list--function-predicate (A B) + "Predicate to sort Timer-List by the Next column." + (let ((fA (aref (cadr A) 3)) + (fB (aref (cadr B) 3))) + (string< fA fB))) (defun timer-list-cancel () "Cancel the timer on the line under point." diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el index 9eb8feed0f1..61fd05cbb80 100644 --- a/lisp/emacs-lisp/timer.el +++ b/lisp/emacs-lisp/timer.el @@ -378,9 +378,6 @@ This function returns a timer object which you can use in (decoded-time-year now) (decoded-time-zone now))))))) - (or (time-equal-p time time) - (error "Invalid time format")) - (let ((timer (timer-create))) (timer-set-time timer time repeat) (timer-set-function timer function args) diff --git a/lisp/emulation/cua-base.el b/lisp/emulation/cua-base.el index 26a1a8955f4..c4dcb76446e 100644 --- a/lisp/emulation/cua-base.el +++ b/lisp/emulation/cua-base.el @@ -860,7 +860,7 @@ With numeric prefix arg, copy to register 0-9 instead." (defun cua-cancel () "Cancel the active region, rectangle, or global mark." (interactive) - (setq mark-active nil) + (deactivate-mark) (if (fboundp 'cua--cancel-rectangle) (cua--cancel-rectangle))) diff --git a/lisp/emulation/edt.el b/lisp/emulation/edt.el index 8dc18ebc85e..e70b44658d5 100644 --- a/lisp/emulation/edt.el +++ b/lisp/emulation/edt.el @@ -178,10 +178,8 @@ (defvar edt-user-global-map) (defvar rect-start-point) -;;; -;;; Version Information -;;; (defconst edt-version "4.0" "EDT Emulation version number.") +(make-obsolete-variable 'edt-version nil "28.1") ;;; ;;; User Configurable Variables diff --git a/lisp/emulation/viper-cmd.el b/lisp/emulation/viper-cmd.el index ca7fcaf2d91..77f1b291043 100644 --- a/lisp/emulation/viper-cmd.el +++ b/lisp/emulation/viper-cmd.el @@ -466,24 +466,7 @@ (assoc major-mode viper-emacs-state-modifier-alist))) (cdr (assoc major-mode viper-emacs-state-modifier-alist)) - viper-empty-keymap)) - )) - - ;; This var is not local in Emacs, so we make it local. It must be local - ;; because although the stack of minor modes can be the same for all buffers, - ;; the associated *keymaps* can be different. In Viper, - ;; viper-vi-local-user-map, viper-insert-local-user-map, and others can have - ;; different keymaps for different buffers. Also, the keymaps associated - ;; with viper-vi/insert-state-modifier-minor-mode can be different. - ;; ***This is needed only in case emulation-mode-map-alists is not defined. - ;; In emacs with emulation-mode-map-alists, nothing needs to be done - (unless - (and (fboundp 'add-to-ordered-list) (boundp 'emulation-mode-map-alists)) - (set (make-local-variable 'minor-mode-map-alist) - (viper-append-filter-alist - (append viper--intercept-key-maps viper--key-maps) - minor-mode-map-alist))) - ) + viper-empty-keymap))))) @@ -893,16 +876,7 @@ LOAD-FILE is the name of the file where the specific minor mode is defined. Suffixes such as .el or .elc should be stripped." (interactive "sEnter name of the load file: ") - - (eval-after-load load-file '(viper-normalize-minor-mode-map-alist)) - - ;; Change the default for minor-mode-map-alist each time a harnessed minor - ;; mode adds its own keymap to the a-list. - (unless - (and (fboundp 'add-to-ordered-list) (boundp 'emulation-mode-map-alists)) - (eval-after-load - load-file '(setq-default minor-mode-map-alist minor-mode-map-alist))) - ) + (eval-after-load load-file '(viper-normalize-minor-mode-map-alist))) (defun viper-ESC (arg) @@ -4721,8 +4695,7 @@ Please, specify your level now: ")) (interactive "cViper register to point: ") (let ((val (get-register char))) (cond - ((and (fboundp 'frame-configuration-p) - (frame-configuration-p val)) + ((frame-configuration-p val) (set-frame-configuration val)) ((window-configuration-p val) (set-window-configuration val)) 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/emulation/viper-mous.el b/lisp/emulation/viper-mous.el index 294705f7c3a..6ecfec548cb 100644 --- a/lisp/emulation/viper-mous.el +++ b/lisp/emulation/viper-mous.el @@ -66,20 +66,13 @@ or a triple-click." ;; time interval in millisecond within which successive clicks are ;; considered related (defcustom viper-multiclick-timeout (if (viper-window-display-p) - (if (featurep 'xemacs) - mouse-track-multi-click-time - double-click-time) + double-click-time 500) "Time interval in millisecond within which successive mouse clicks are considered related." :type 'integer :group 'viper-mouse) -;; current event click count; XEmacs only -(defvar viper-current-click-count 0) -;; time stamp of the last click event; XEmacs only -(defvar viper-last-click-event-timestamp 0) - ;; Local variable used to toggle wraparound search on click. (viper-deflocalvar viper-mouse-click-search-noerror t) @@ -279,11 +272,9 @@ See `viper-surrounding-word' for the definition of a word in this case." (setq interrupting-event (read-event)) (viper-mouse-event-p last-input-event))) (progn ; interrupted wait - (setq viper-global-prefix-argument arg) - ;; count this click for XEmacs - (viper-event-click-count click)) + (setq viper-global-prefix-argument arg)) ;; uninterrupted wait or the interrupting event wasn't a mouse event - (setq click-count (viper-event-click-count click)) + (setq click-count (event-click-count click)) (if (> click-count 1) (setq arg viper-global-prefix-argument viper-global-prefix-argument nil)) @@ -300,33 +291,8 @@ See `viper-surrounding-word' for the definition of a word in this case." (string-match "\\(mouse-\\|frame\\|screen\\|track\\)" (prin1-to-string (viper-event-key event))))) -;; XEmacs has no double-click events. So, we must simulate. -;; So, we have to simulate event-click-count. -(defun viper-event-click-count (click) - (if (featurep 'xemacs) (viper-event-click-count-xemacs click) - (event-click-count click))) - -(when (featurep 'xemacs) - - ;; kind of semaphore for updating viper-current-click-count - (defvar viper-counting-clicks-p nil) - - (defun viper-event-click-count-xemacs (click) - (let ((time-delta (- (event-timestamp click) - viper-last-click-event-timestamp)) - inhibit-quit) - (while viper-counting-clicks-p - (ignore)) - (setq viper-counting-clicks-p t) - (if (> time-delta viper-multiclick-timeout) - (setq viper-current-click-count 0)) - (discard-input) - (setq viper-current-click-count (1+ viper-current-click-count) - viper-last-click-event-timestamp (event-timestamp click)) - (setq viper-counting-clicks-p nil) - (if (viper-sit-for-short viper-multiclick-timeout t) - viper-current-click-count - 0)))) +(define-obsolete-function-alias 'viper-event-click-count + 'event-click-count "28.1") (declare-function viper-forward-word "viper-cmd" (arg)) (declare-function viper-adjust-window "viper-cmd" ()) @@ -364,11 +330,9 @@ this command. (setq viper-global-prefix-argument (or viper-global-prefix-argument arg) ;; remember command that was before the multiclick - this-command last-command) - ;; make sure we counted this event---needed for XEmacs only - (viper-event-click-count click)) + this-command last-command)) ;; uninterrupted wait - (setq click-count (viper-event-click-count click)) + (setq click-count (event-click-count click)) (setq click-word (viper-mouse-click-get-word click nil click-count)) (if (> click-count 1) diff --git a/lisp/emulation/viper-util.el b/lisp/emulation/viper-util.el index ebad850e6b7..1561204151d 100644 --- a/lisp/emulation/viper-util.el +++ b/lisp/emulation/viper-util.el @@ -205,6 +205,7 @@ Otherwise return the normal value." ;; incorrect. However, this gives correct result in our cases, since we are ;; testing for sufficiently high Emacs versions. (defun viper-check-version (op major minor &optional type-of-emacs) + (declare (obsolete nil "28.1")) (if (and (boundp 'emacs-major-version) (boundp 'emacs-minor-version)) (and (cond ((eq type-of-emacs 'xemacs) (featurep 'xemacs)) ((eq type-of-emacs 'emacs) (featurep 'emacs)) diff --git a/lisp/emulation/viper.el b/lisp/emulation/viper.el index 492c31bde74..59ca6298eb9 100644 --- a/lisp/emulation/viper.el +++ b/lisp/emulation/viper.el @@ -695,9 +695,6 @@ It also can't undo some Viper settings." 'mark-even-if-inactive viper-saved-non-viper-variables)) ;; Ideally, we would like to be able to de-localize local variables - (unless - (and (fboundp 'add-to-ordered-list) (boundp 'emulation-mode-map-alists)) - (viper-delocalize-var 'minor-mode-map-alist)) (viper-delocalize-var 'require-final-newline) ;; deactivate all advices done by Viper. @@ -705,11 +702,9 @@ It also can't undo some Viper settings." (setq viper-mode nil) - (when (and (fboundp 'add-to-ordered-list) (boundp 'emulation-mode-map-alists)) - (setq emulation-mode-map-alists - (delq 'viper--intercept-key-maps - (delq 'viper--key-maps emulation-mode-map-alists)) - )) + (setq emulation-mode-map-alists + (delq 'viper--intercept-key-maps + (delq 'viper--key-maps emulation-mode-map-alists))) (viper-delocalize-var 'viper-vi-minibuffer-minor-mode) (viper-delocalize-var 'viper-insert-minibuffer-minor-mode) @@ -943,13 +938,11 @@ Two differences: (setq viper-vi-state-cursor-color color-name))) - (when (and (fboundp 'add-to-ordered-list) (boundp 'emulation-mode-map-alists)) - ;; needs to be as early as possible - (add-to-ordered-list - 'emulation-mode-map-alists 'viper--intercept-key-maps 100) - ;; needs to be after cua-mode - (add-to-ordered-list 'emulation-mode-map-alists 'viper--key-maps 500) - ) + ;; needs to be as early as possible + (add-to-ordered-list + 'emulation-mode-map-alists 'viper--intercept-key-maps 100) + ;; needs to be after cua-mode + (add-to-ordered-list 'emulation-mode-map-alists 'viper--key-maps 500) ;; Emacs shell, ange-ftp, and comint-based modes (add-hook 'comint-mode-hook #'viper-comint-mode-hook) ; comint @@ -1062,10 +1055,7 @@ This may be needed if the previous `:map' command terminated abnormally." (viper--advice-add 'add-minor-mode :after (lambda (&rest _) "Run viper-normalize-minor-mode-map-alist after adding a minor mode." - (viper-normalize-minor-mode-map-alist) - (unless - (and (fboundp 'add-to-ordered-list) (boundp 'emulation-mode-map-alists)) - (setq-default minor-mode-map-alist minor-mode-map-alist)))) + (viper-normalize-minor-mode-map-alist))) ;; catch frame switching event (if (viper-window-display-p) @@ -1221,7 +1211,6 @@ These two lines must come in the order given.")) (viper-harness-minor-mode "outline") (viper-harness-minor-mode "allout") (viper-harness-minor-mode "xref") - (viper-harness-minor-mode "lmenu") (viper-harness-minor-mode "vc") (viper-harness-minor-mode "ltx-math") ; LaTeX-math-mode in AUC-TeX, which (viper-harness-minor-mode "latex") ; sits in one of these two files @@ -1254,12 +1243,7 @@ These two lines must come in the order given.")) ;; Without setting the default, new buffers that come up in emacs mode have ;; minor-mode-map-alist = nil, unless we call viper-change-state-* (when (eq viper-current-state 'emacs-state) - (viper-change-state-to-emacs) - (unless - (and (fboundp 'add-to-ordered-list) - (boundp 'emulation-mode-map-alists)) - (setq-default minor-mode-map-alist minor-mode-map-alist)) - ) + (viper-change-state-to-emacs)) (if (this-major-mode-requires-vi-state major-mode) (viper-mode)) diff --git a/lisp/epa-dired.el b/lisp/epa-dired.el index f601d426566..4ff1ba33941 100644 --- a/lisp/epa-dired.el +++ b/lisp/epa-dired.el @@ -1,4 +1,5 @@ ;;; epa-dired.el --- the EasyPG Assistant, dired extension -*- lexical-binding: t -*- + ;; Copyright (C) 2006-2020 Free Software Foundation, Inc. ;; Author: Daiki Ueno <ueno@unixuser.org> @@ -29,48 +30,40 @@ (defun epa-dired-do-decrypt () "Decrypt marked files." (interactive) - (let ((file-list (dired-get-marked-files))) - (while file-list - (epa-decrypt-file (expand-file-name (car file-list))) - (setq file-list (cdr file-list))) - (revert-buffer))) + (dolist (file (dired-get-marked-files)) + (epa-decrypt-file (expand-file-name file))) + (revert-buffer)) ;;;###autoload (defun epa-dired-do-verify () "Verify marked files." (interactive) - (let ((file-list (dired-get-marked-files))) - (while file-list - (epa-verify-file (expand-file-name (car file-list))) - (setq file-list (cdr file-list))))) + (dolist (file (dired-get-marked-files)) + (epa-verify-file (expand-file-name file)))) ;;;###autoload (defun epa-dired-do-sign () "Sign marked files." (interactive) - (let ((file-list (dired-get-marked-files))) - (while file-list - (epa-sign-file - (expand-file-name (car file-list)) - (epa-select-keys (epg-make-context) "Select keys for signing. + (dolist (file (dired-get-marked-files)) + (epa-sign-file + (expand-file-name file) + (epa-select-keys (epg-make-context) "Select keys for signing. If no one is selected, default secret key is used. " - nil t) - (y-or-n-p "Make a detached signature? ")) - (setq file-list (cdr file-list))) - (revert-buffer))) + nil t) + (y-or-n-p "Make a detached signature? "))) + (revert-buffer)) ;;;###autoload (defun epa-dired-do-encrypt () "Encrypt marked files." (interactive) - (let ((file-list (dired-get-marked-files))) - (while file-list - (epa-encrypt-file - (expand-file-name (car file-list)) - (epa-select-keys (epg-make-context) "Select recipients for encryption. -If no one is selected, symmetric encryption will be performed. ")) - (setq file-list (cdr file-list))) - (revert-buffer))) + (dolist (file (dired-get-marked-files)) + (epa-encrypt-file + (expand-file-name file) + (epa-select-keys (epg-make-context) "Select recipients for encryption. +If no one is selected, symmetric encryption will be performed. "))) + (revert-buffer)) (provide 'epa-dired) diff --git a/lisp/epa-file.el b/lisp/epa-file.el index dedf20b0d77..3b0cc84e5f6 100644 --- a/lisp/epa-file.el +++ b/lisp/epa-file.el @@ -1,4 +1,5 @@ ;;; epa-file.el --- the EasyPG Assistant, transparent file encryption -*- lexical-binding: t -*- + ;; Copyright (C) 2006-2020 Free Software Foundation, Inc. ;; Author: Daiki Ueno <ueno@unixuser.org> @@ -21,10 +22,13 @@ ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Code: +;;; Dependencies (require 'epa) (require 'epa-hook) +;;; Options + (defcustom epa-file-cache-passphrase-for-symmetric-encryption nil "If non-nil, cache passphrase for symmetric encryption. @@ -40,26 +44,18 @@ Note that this option has no effect if you use GnuPG 2.0." (defcustom epa-file-select-keys nil "Control whether or not to pop up the key selection dialog. -If t, always asks user to select recipients. +If t, always ask user to select recipients. If nil, query user only when `epa-file-encrypt-to' is not set. -If neither t nor nil, doesn't ask user. In this case, symmetric +If neither t nor nil, don't ask user. In this case, symmetric encryption is used." :type '(choice (const :tag "Ask always" t) (const :tag "Ask when recipients are not set" nil) (const :tag "Don't ask" silent)) :group 'epa-file) -(defvar epa-file-passphrase-alist nil) - -(eval-and-compile - (if (fboundp 'encode-coding-string) - (defalias 'epa-file--encode-coding-string 'encode-coding-string) - (defalias 'epa-file--encode-coding-string 'identity))) +;;; Other -(eval-and-compile - (if (fboundp 'decode-coding-string) - (defalias 'epa-file--decode-coding-string 'decode-coding-string) - (defalias 'epa-file--decode-coding-string 'identity))) +(defvar epa-file-passphrase-alist nil) (defun epa-file-passphrase-callback-function (context key-id file) (if (and epa-file-cache-passphrase-for-symmetric-encryption @@ -71,8 +67,8 @@ encryption is used." (or (copy-sequence (cdr entry)) (progn (unless entry - (setq entry (list file) - epa-file-passphrase-alist + (setq entry (list file)) + (setq epa-file-passphrase-alist (cons entry epa-file-passphrase-alist))) (setq passphrase (epa-passphrase-callback-function context @@ -82,6 +78,8 @@ encryption is used." passphrase)))) (epa-passphrase-callback-function context key-id file))) +;;; File Handler + (defvar epa-inhibit nil "Non-nil means don't try to decrypt .gpg files when operating on them.") @@ -161,17 +159,25 @@ encryption is used." (nth 3 error))) (let ((exists (file-exists-p local-file))) (when exists - ;; Hack to prevent find-file from opening empty buffer - ;; when decryption failed (bug#6568). See the place - ;; where `find-file-not-found-functions' are called in - ;; `find-file-noselect-1'. - (setq-local epa-file-error error) - (add-hook 'find-file-not-found-functions - 'epa-file--find-file-not-found-function - nil t) - (epa-display-error context)) - (signal (if exists 'file-error 'file-missing) - (cons "Opening input file" (cdr error)))))) + (epa-display-error context) + ;; When the .gpg file isn't an encrypted file (e.g., + ;; it's a keyring.gpg file instead), then gpg will + ;; say "Unexpected exit" as the error message. In + ;; that case, just display the bytes. + (if (equal (caddr error) "Unexpected; Exit") + (setq string (with-temp-buffer + (insert-file-contents-literally local-file) + (buffer-string))) + ;; Hack to prevent find-file from opening empty buffer + ;; when decryption failed (bug#6568). See the place + ;; where `find-file-not-found-functions' are called in + ;; `find-file-noselect-1'. + (setq-local epa-file-error error) + (add-hook 'find-file-not-found-functions + 'epa-file--find-file-not-found-function + nil t) + (signal (if exists 'file-error 'file-missing) + (cons "Opening input file" (cdr error)))))))) (set-buffer buf) ;In case timer/filter changed/killed it (bug#16029)! (setq-local epa-file-encrypt-to (mapcar #'car (epg-context-result-for @@ -236,11 +242,7 @@ encryption is used." (setq file (expand-file-name file)) (let* ((coding-system (or coding-system-for-write (if (fboundp 'select-safe-coding-system) - ;; This is needed since Emacs 22 has - ;; no-conversion setting for *.gpg in - ;; `auto-coding-alist'. - (let ((buffer-file-name - (file-name-sans-extension file))) + (let ((buffer-file-name file)) (select-safe-coding-system (point-min) (point-max))) buffer-file-coding-system))) @@ -266,7 +268,7 @@ encryption is used." (epg-encrypt-string context (if (stringp start) - (epa-file--encode-coding-string start coding-system) + (encode-coding-string start coding-system) (unless start (setq start (point-min) end (point-max))) @@ -280,8 +282,8 @@ encryption is used." ;; decrypted contents. (format-encode-buffer (with-current-buffer buffer buffer-file-format)) - (epa-file--encode-coding-string (buffer-string) - coding-system))) + (encode-coding-string (buffer-string) + coding-system))) (if (or (eq epa-file-select-keys t) (and (null epa-file-select-keys) (not (local-variable-p 'epa-file-encrypt-to @@ -317,6 +319,8 @@ If no one is selected, symmetric encryption will be performed. " (message "Wrote %s" buffer-file-name)))) (put 'write-region 'epa-file 'epa-file-write-region) +;;; Commands + (defun epa-file-select-keys () "Select recipients for encryption." (interactive) diff --git a/lisp/epa-hook.el b/lisp/epa-hook.el index d424e7a9faf..6f12f8a6bfa 100644 --- a/lisp/epa-hook.el +++ b/lisp/epa-hook.el @@ -1,4 +1,5 @@ ;;; epa-hook.el --- preloaded code to enable epa-file.el -*- lexical-binding: t -*- + ;; Copyright (C) 2006-2020 Free Software Foundation, Inc. ;; Author: Daiki Ueno <ueno@unixuser.org> @@ -35,10 +36,10 @@ (defcustom epa-file-name-regexp (purecopy "\\.gpg\\(~\\|\\.~[0-9]+~\\)?\\'") "Regexp which matches filenames to be encrypted with GnuPG. -If you set this outside Custom while epa-file is already enabled, you -have to call `epa-file-name-regexp-update' after setting it to -properly update file-name-handler-alist. Setting this through Custom -does that automatically." +If you set this outside Custom while epa-file is already enabled, +you have to call `epa-file-name-regexp-update' after setting it +to properly update `file-name-handler-alist'. Setting this +through Custom does that automatically." :type 'regexp :group 'epa-file :set 'epa-file--file-name-regexp-set) @@ -72,6 +73,9 @@ May either be a string or a list of strings.") (list epa-file-name-regexp nil 'epa-file)) (defun epa-file-name-regexp-update () + "Update `file-name-handler-alist' after configuring outside Custom. +After setting `epa-file-name-regexp-update' outside the Custom +interface, update `file-name-handler-alist'." (interactive) (unless (equal (car epa-file-handler) epa-file-name-regexp) (setcar epa-file-handler epa-file-name-regexp))) diff --git a/lisp/epa-mail.el b/lisp/epa-mail.el index 63475256ca8..6e6c0a498d2 100644 --- a/lisp/epa-mail.el +++ b/lisp/epa-mail.el @@ -1,4 +1,5 @@ ;;; epa-mail.el --- the EasyPG Assistant, minor-mode for mail composer -*- lexical-binding: t -*- + ;; Copyright (C) 2006-2020 Free Software Foundation, Inc. ;; Author: Daiki Ueno <ueno@unixuser.org> @@ -21,10 +22,13 @@ ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Code: +;;; Dependencies (require 'epa) (require 'mail-utils) +;;; Local Mode + (defvar epa-mail-mode-map (let ((keymap (make-sparse-keymap))) (define-key keymap "\C-c\C-ed" 'epa-mail-decrypt) @@ -50,6 +54,8 @@ "A minor-mode for composing encrypted/clearsigned mails." nil " epa-mail" epa-mail-mode-map) +;;; Utilities + (defun epa-mail--find-usable-key (keys usage) "Find a usable key from KEYS for USAGE. USAGE would be `sign' or `encrypt'." @@ -64,6 +70,8 @@ USAGE would be `sign' or `encrypt'." (setq pointer (cdr pointer)))) (setq keys (cdr keys))))) +;;; Commands + ;;;###autoload (defun epa-mail-decrypt () "Decrypt OpenPGP armors in the current buffer. @@ -241,6 +249,8 @@ The buffer is expected to contain a mail message." (interactive) (epa-import-armor-in-region (point-min) (point-max))) +;;; Global Mode + ;;;###autoload (define-minor-mode epa-global-mail-mode "Minor mode to hook EasyPG into Mail mode." diff --git a/lisp/epa.el b/lisp/epa.el index 47c177e6cd5..d190824293f 100644 --- a/lisp/epa.el +++ b/lisp/epa.el @@ -21,13 +21,18 @@ ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Code: +;;; Dependencies (require 'epg) (require 'font-lock) (require 'widget) -(eval-when-compile (require 'wid-edit)) +(eval-when-compile + (require 'subr-x) + (require 'wid-edit)) (require 'derived) +;;; Options + (defgroup epa nil "The EasyPG Assistant" :version "23.1" @@ -56,11 +61,6 @@ If neither t nor nil, ask user for confirmation." :type 'integer :group 'epa) -(defgroup epa-faces nil - "Faces for epa-mode." - :version "23.1" - :group 'epa) - (defcustom epa-mail-aliases nil "Alist of aliases of email addresses that stand for encryption keys. Each element is a list of email addresses (ALIAS EXPANSIONS...). @@ -76,6 +76,13 @@ The command `epa-mail-encrypt' uses this." :group 'epa :version "24.4") +;;; Faces + +(defgroup epa-faces nil + "Faces for epa-mode." + :version "23.1" + :group 'epa) + (defface epa-validity-high '((default :weight bold) (((class color) (background dark)) :foreground "PaleTurquoise")) @@ -117,13 +124,15 @@ The command `epa-mail-encrypt' uses this." '((default :weight bold) (((class color) (background dark)) :foreground "PaleTurquoise")) "Face for the name of the attribute field." - :group 'epa) + :version "28.1" + :group 'epa-faces) (defface epa-field-body '((default :slant italic) (((class color) (background dark)) :foreground "turquoise")) "Face for the body of the attribute field." - :group 'epa) + :version "28.1" + :group 'epa-faces) (defcustom epa-validity-face-alist '((unknown . epa-validity-disabled) @@ -138,8 +147,11 @@ The command `epa-mail-encrypt' uses this." (full . epa-validity-high) (ultimate . epa-validity-high)) "An alist mapping validity values to faces." + :version "28.1" :type '(repeat (cons symbol face)) - :group 'epa) + :group 'epa-faces) + +;;; Variables (defvar epa-font-lock-keywords '(("^\\*" @@ -185,6 +197,8 @@ You should bind this variable with `let', but do not set it globally.") (defvar epa-key-list-mode-map (let ((keymap (make-sparse-keymap)) (menu-map (make-sparse-keymap))) + (set-keymap-parent keymap widget-keymap) + (define-key keymap "\C-m" 'epa-show-key) (define-key keymap "m" 'epa-mark-key) (define-key keymap "u" 'epa-unmark-key) (define-key keymap "d" 'epa-decrypt-file) @@ -245,6 +259,8 @@ You should bind this variable with `let', but do not set it globally.") (defvar epa-exit-buffer-function #'quit-window) +;;; Key Widget + (define-widget 'epa-key 'push-button "Button for representing an epg-key object." :format "%[%v%]" @@ -286,6 +302,8 @@ You should bind this variable with `let', but do not set it globally.") (epg-sub-key-id (car (epg-key-sub-key-list (widget-get widget :value)))))) +;;; Modes + (define-derived-mode epa-key-list-mode special-mode "EPA Keys" "Major mode for `epa-list-keys'." (buffer-disable-undo) @@ -309,6 +327,9 @@ You should bind this variable with `let', but do not set it globally.") (setq truncate-lines t buffer-read-only t)) +;;; Commands +;;;; Marking + (defun epa-mark-key (&optional arg) "Mark a key on the current line. If ARG is non-nil, unmark the key." @@ -331,12 +352,15 @@ If ARG is non-nil, mark the key." (interactive "P") (epa-mark-key (not arg))) +;;;; Quitting + (defun epa-exit-buffer () - "Exit the current buffer. -`epa-exit-buffer-function' is called if it is set." + "Exit the current buffer using `epa-exit-buffer-function'." (interactive) (funcall epa-exit-buffer-function)) +;;;; Listing and Selecting + (defun epa--insert-keys (keys) (save-excursion (save-restriction @@ -361,7 +385,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,16 +398,30 @@ 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)) + (widget-setup)) (make-local-variable 'epa-list-keys-arguments) (setq epa-list-keys-arguments (list name secret)) (goto-char (point-min)) @@ -396,7 +437,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) @@ -476,6 +523,16 @@ If SECRET is non-nil, list secret keys instead of public keys." (let ((keys (epg-list-keys context names secret))) (epa--select-keys prompt keys))) +;;;; Key Details + +(defun epa-show-key () + "Show a key on the current line." + (interactive) + (if-let ((key (get-text-property (point) 'epa-key))) + (save-selected-window + (epa--show-key key)) + (error "No key on this line"))) + (defun epa--show-key (key) (let* ((primary-sub-key (car (epg-key-sub-key-list key))) (entry (assoc (epg-sub-key-id primary-sub-key) @@ -554,6 +611,8 @@ If SECRET is non-nil, list secret keys instead of public keys." (goto-char (point-min)) (pop-to-buffer (current-buffer)))) +;;;; Encryption and Signatures + (defun epa-display-info (info) (if epa-popup-info-window (save-selected-window @@ -1068,16 +1127,7 @@ If no one is selected, default secret key is used. " 'start-open t 'end-open t))))) -(defalias 'epa--derived-mode-p - (if (fboundp 'derived-mode-p) - #'derived-mode-p - (lambda (&rest modes) - "Non-nil if the current major mode is derived from one of MODES. -Uses the `derived-mode-parent' property of the symbol to trace backwards." - (let ((parent major-mode)) - (while (and (not (memq parent modes)) - (setq parent (get parent 'derived-mode-parent)))) - parent)))) +(define-obsolete-function-alias 'epa--derived-mode-p 'derived-mode-p "28.1") ;;;###autoload (defun epa-encrypt-region (start end recipients sign signers) @@ -1154,6 +1204,8 @@ If no one is selected, symmetric encryption will be performed. ") 'start-open t 'end-open t))))) +;;;; Key Management + ;;;###autoload (defun epa-delete-keys (keys &optional allow-secret) "Delete selected KEYS." @@ -1190,7 +1242,7 @@ If no one is selected, symmetric encryption will be performed. ") (if (epg-context-result-for context 'import) (epa-display-info (epg-import-result-to-string (epg-context-result-for context 'import)))) - ;; FIXME: Why not use the (otherwise unused) epa--derived-mode-p? + ;; FIXME: Why not use the derived-mode-p? (if (eq major-mode 'epa-key-list-mode) (apply #'epa--list-keys epa-list-keys-arguments)))) diff --git a/lisp/epg-config.el b/lisp/epg-config.el index daa9a5abd17..9f0c7e4c509 100644 --- a/lisp/epg-config.el +++ b/lisp/epg-config.el @@ -22,6 +22,7 @@ ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Code: +;;; Prelude (eval-when-compile (require 'cl-lib)) @@ -34,6 +35,8 @@ (define-obsolete-variable-alias 'epg-bug-report-address 'report-emacs-bug-address "27.1") +;;; Options + (defgroup epg () "Interface to the GNU Privacy Guard (GnuPG)." :tag "EasyPG" @@ -106,6 +109,8 @@ through the minibuffer, instead of external Pinentry program." Note that the buffer name starts with a space." :type 'boolean) +;;; Constants + (defconst epg-gpg-minimum-version "1.4.3") (defconst epg-gpg2-minimum-version "2.1.6") @@ -133,6 +138,8 @@ The first element of each entry is protocol symbol, which is either `OpenPGP' or `CMS'. The second element is a function which constructs a configuration object (actually a plist).") +;;; "Configuration" + (defvar epg--configurations nil) ;;;###autoload @@ -202,13 +209,13 @@ version requirement is met." (cond ((eq type 'group) (if (string-match "\\`\\([^:]+\\):" args) - (setq groups - (cons (cons (downcase (match-string 1 args)) - (delete "" (split-string - (substring args - (match-end 0)) - ";"))) - groups)) + (setq groups + (cons (cons (downcase (match-string 1 args)) + (delete "" (split-string + (substring args + (match-end 0)) + ";"))) + groups)) (if epg-debug (message "Invalid group configuration: %S" args)))) ((memq type '(pubkey cipher digest compress)) diff --git a/lisp/epg.el b/lisp/epg.el index 222fd913e17..96af3ad4bca 100644 --- a/lisp/epg.el +++ b/lisp/epg.el @@ -1,4 +1,5 @@ ;;; epg.el --- the EasyPG Library -*- lexical-binding: t -*- + ;; Copyright (C) 1999-2000, 2002-2020 Free Software Foundation, Inc. ;; Author: Daiki Ueno <ueno@unixuser.org> @@ -21,10 +22,15 @@ ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Code: +;;; Prelude (require 'epg-config) (eval-when-compile (require 'cl-lib)) +(define-error 'epg-error "GPG error") + +;;; Variables + (defvar epg-user-id nil "GnuPG ID of your default identity.") @@ -41,6 +47,8 @@ (defvar epg-agent-file nil) (defvar epg-agent-mtime nil) +;;; Enums + ;; from gnupg/common/openpgpdefs.h (defconst epg-cipher-algorithm-alist '((0 . "NONE") @@ -123,7 +131,7 @@ (defconst epg-no-data-reason-alist '((1 . "No armored data") - (2 . "Expected a packet but did not found one") + (2 . "Expected a packet but did not find one") (3 . "Invalid packet found, this may indicate a non OpenPGP message") (4 . "Signature expected but not found"))) @@ -169,7 +177,8 @@ (defvar epg-prompt-alist nil) -(define-error 'epg-error "GPG error") +;;; Structs +;;;; Data Struct (cl-defstruct (epg-data (:constructor nil) @@ -180,6 +189,8 @@ (file nil :read-only t) (string nil :read-only t)) +;;;; Context Struct + (cl-defstruct (epg-context (:constructor nil) (:constructor epg-context--make @@ -218,6 +229,8 @@ (error-output "") error-buffer) +;;;; Context Methods + ;; This is not an alias, just so we can mark it as autoloaded. ;;;###autoload (defun epg-make-context (&optional protocol armor textmode include-certs @@ -281,6 +294,8 @@ callback data (if any)." (declare (obsolete setf "25.1")) (setf (epg-context-signers context) signers)) +;;;; Other Structs + (cl-defstruct (epg-signature (:constructor nil) (:constructor epg-make-signature @@ -385,6 +400,8 @@ callback data (if any)." secret-unchanged not-imported imports) +;;; Functions + (defun epg-context-result-for (context name) "Return the result of CONTEXT associated with NAME." (cdr (assq name (epg-context-result context)))) @@ -404,37 +421,28 @@ callback data (if any)." (pubkey-algorithm (epg-signature-pubkey-algorithm signature)) (key-id (epg-signature-key-id signature))) (concat - (cond ((eq (epg-signature-status signature) 'good) - "Good signature from ") - ((eq (epg-signature-status signature) 'bad) - "Bad signature from ") - ((eq (epg-signature-status signature) 'expired) - "Expired signature from ") - ((eq (epg-signature-status signature) 'expired-key) - "Signature made by expired key ") - ((eq (epg-signature-status signature) 'revoked-key) - "Signature made by revoked key ") - ((eq (epg-signature-status signature) 'no-pubkey) - "No public key for ")) + (cl-case (epg-signature-status signature) + (good "Good signature from ") + (bad "Bad signature from ") + (expired "Expired signature from ") + (expired-key "Signature made by expired key ") + (revoked-key "Signature made by revoked key ") + (no-pubkey "No public key for ")) key-id - (if user-id - (concat " " - (if (stringp user-id) - (epg--decode-percent-escape-as-utf-8 user-id) - (epg-decode-dn user-id))) - "") - (if (epg-signature-validity signature) - (format " (trust %s)" (epg-signature-validity signature)) - "") - (if (epg-signature-creation-time signature) - (format-time-string " created at %Y-%m-%dT%T%z" - (epg-signature-creation-time signature)) - "") - (if pubkey-algorithm - (concat " using " - (or (cdr (assq pubkey-algorithm epg-pubkey-algorithm-alist)) - (format "(unknown algorithm %d)" pubkey-algorithm))) - "")))) + (and user-id + (concat " " + (if (stringp user-id) + (epg--decode-percent-escape-as-utf-8 user-id) + (epg-decode-dn user-id)))) + (and (epg-signature-validity signature) + (format " (trust %s)" (epg-signature-validity signature))) + (and (epg-signature-creation-time signature) + (format-time-string " created at %Y-%m-%dT%T%z" + (epg-signature-creation-time signature))) + (and pubkey-algorithm + (concat " using " + (or (cdr (assq pubkey-algorithm epg-pubkey-algorithm-alist)) + (format "(unknown algorithm %d)" pubkey-algorithm))))))) (defun epg-verify-result-to-string (verify-result) "Convert VERIFY-RESULT to a human readable string." @@ -859,6 +867,8 @@ callback data (if any)." (format "Untrusted key %s %s. Use anyway? " key-id user-id)) "Use untrusted key anyway? "))) +;;; Status Functions + (defun epg--status-GET_BOOL (context string) (let (inhibit-quit) (condition-case nil @@ -1234,6 +1244,8 @@ callback data (if any)." (epg-context-result-for context 'import-status))) (epg-context-set-result-for context 'import-status nil))) +;;; Functions + (defun epg-passphrase-callback-function (context key-id _handback) (declare (obsolete epa-passphrase-callback-function "23.1")) (if (eq key-id 'SYM) @@ -1303,6 +1315,8 @@ callback data (if any)." (if (aref line 6) (epg--time-from-seconds (aref line 6))))) +;;; Public Functions + (defun epg-list-keys (context &optional name mode) "Return a list of epg-key objects matched with NAME. If MODE is nil or `public', only public keyring should be searched. @@ -1683,7 +1697,8 @@ Otherwise, it makes a cleartext signature." (if (epg-context-result-for context 'error) (let ((errors (epg-context-result-for context 'error))) (signal 'epg-error - (list "Sign failed" (epg-errors-to-string errors)))))) + (list "Sign failed" (epg-errors-to-string errors)))) + (signal 'epg-error '("Signing failed (unknown reason)")))) (epg-read-output context)) (epg-delete-output-file context) (if input-file @@ -2031,6 +2046,8 @@ If you are unsure, use synchronous version of this function (epg-errors-to-string errors)))))) (epg-reset context))) +;;; Decode Functions + (defun epg--decode-percent-escape (string) (setq string (encode-coding-string string 'raw-text)) (let ((index 0)) diff --git a/lisp/erc/erc-autoaway.el b/lisp/erc/erc-autoaway.el index 0950cec4f7f..0923ed6e735 100644 --- a/lisp/erc/erc-autoaway.el +++ b/lisp/erc/erc-autoaway.el @@ -54,7 +54,7 @@ If `erc-autoaway-idle-method' is `emacs', you must call this function each time you change `erc-autoaway-idle-seconds'." (interactive) (when erc-autoaway-idletimer - (erc-cancel-timer erc-autoaway-idletimer)) + (cancel-timer erc-autoaway-idletimer)) (setq erc-autoaway-idletimer (run-with-idle-timer erc-autoaway-idle-seconds t @@ -133,7 +133,7 @@ Related variables: `erc-public-away-p' and `erc-away-nickname'." (remove-hook 'erc-after-connect 'erc-autoaway-insinuate-maybe) (remove-hook 'erc-disconnected-hook 'erc-autoaway-remove-maybe)) ((eq erc-autoaway-idle-method 'emacs) - (erc-cancel-timer erc-autoaway-idletimer) + (cancel-timer erc-autoaway-idletimer) (setq erc-autoaway-idletimer nil))) (remove-hook 'erc-timer-hook 'erc-autoaway-possibly-set-away) (remove-hook 'erc-server-305-functions 'erc-autoaway-reset-indicators)))) diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el index 526e854beca..4f3d85ba3c8 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 @@ -520,7 +520,8 @@ If no subword-mode is active, then this is "Set up a timer to periodically ping the current server. The current buffer is given by BUFFER." (with-current-buffer buffer - (and erc-server-ping-handler (erc-cancel-timer erc-server-ping-handler)) + (when erc-server-ping-handler + (cancel-timer erc-server-ping-handler)) (when erc-server-send-ping-interval (setq erc-server-ping-handler (run-with-timer 4 erc-server-send-ping-interval @@ -533,7 +534,7 @@ The current buffer is given by BUFFER." (if timer-tuple ;; this buffer already has a timer. Cancel it and set the new one (progn - (erc-cancel-timer (cdr timer-tuple)) + (cancel-timer (cdr timer-tuple)) (setf (cdr (assq buffer erc-server-ping-timer-alist)) erc-server-ping-handler)) ;; no existing timer for this buffer. Add new one @@ -731,7 +732,7 @@ Conditionally try to reconnect and take appropriate action." (erc-with-all-buffers-of-server cproc nil (setq erc-server-connected nil)) (when erc-server-ping-handler - (progn (erc-cancel-timer erc-server-ping-handler) + (progn (cancel-timer erc-server-ping-handler) (setq erc-server-ping-handler nil))) (run-hook-with-args 'erc-disconnected-hook (erc-current-nick) (system-name) "") @@ -856,7 +857,7 @@ Additionally, detect whether the IRC process has hung." ;; remove timer if the server buffer has been killed (let ((timer (assq buf erc-server-ping-timer-alist))) (when timer - (erc-cancel-timer (cdr timer)) + (cancel-timer (cdr timer)) (setcdr timer nil))))) ;; From Circe @@ -864,41 +865,42 @@ Additionally, detect whether the IRC process has hung." "Send messages in `erc-server-flood-queue'. See `erc-server-flood-margin' for an explanation of the flood protection algorithm." - (with-current-buffer buffer - (let ((now (current-time))) - (when erc-server-flood-timer - (erc-cancel-timer erc-server-flood-timer) - (setq erc-server-flood-timer nil)) - (when (time-less-p erc-server-flood-last-message now) - (setq erc-server-flood-last-message (erc-emacs-time-to-erc-time now))) - (while (and erc-server-flood-queue - (time-less-p erc-server-flood-last-message - (time-add now erc-server-flood-margin))) - (let ((msg (caar erc-server-flood-queue)) - (encoding (cdar erc-server-flood-queue))) - (setq erc-server-flood-queue (cdr erc-server-flood-queue) - erc-server-flood-last-message - (+ erc-server-flood-last-message - erc-server-flood-penalty)) - (erc-log-irc-protocol msg 'outbound) - (erc-log (concat "erc-server-send-queue: " - msg "(" (buffer-name buffer) ")")) - (when (erc-server-process-alive) - (condition-case nil - ;; Set encoding just before sending the string - (progn - (when (fboundp 'set-process-coding-system) - (set-process-coding-system erc-server-process - 'raw-text encoding)) - (process-send-string erc-server-process msg)) - ;; Sometimes the send can occur while the process is - ;; being killed, which results in a weird SIGPIPE error. - ;; Catch this and ignore it. - (error nil))))) - (when erc-server-flood-queue - (setq erc-server-flood-timer - (run-at-time (+ 0.2 erc-server-flood-penalty) - nil #'erc-server-send-queue buffer)))))) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (let ((now (current-time))) + (when erc-server-flood-timer + (cancel-timer erc-server-flood-timer) + (setq erc-server-flood-timer nil)) + (when (time-less-p erc-server-flood-last-message now) + (setq erc-server-flood-last-message (erc-emacs-time-to-erc-time now))) + (while (and erc-server-flood-queue + (time-less-p erc-server-flood-last-message + (time-add now erc-server-flood-margin))) + (let ((msg (caar erc-server-flood-queue)) + (encoding (cdar erc-server-flood-queue))) + (setq erc-server-flood-queue (cdr erc-server-flood-queue) + erc-server-flood-last-message + (+ erc-server-flood-last-message + erc-server-flood-penalty)) + (erc-log-irc-protocol msg 'outbound) + (erc-log (concat "erc-server-send-queue: " + msg "(" (buffer-name buffer) ")")) + (when (erc-server-process-alive) + (condition-case nil + ;; Set encoding just before sending the string + (progn + (when (fboundp 'set-process-coding-system) + (set-process-coding-system erc-server-process + 'raw-text encoding)) + (process-send-string erc-server-process msg)) + ;; Sometimes the send can occur while the process is + ;; being killed, which results in a weird SIGPIPE error. + ;; Catch this and ignore it. + (error nil))))) + (when erc-server-flood-queue + (setq erc-server-flood-timer + (run-at-time (+ 0.2 erc-server-flood-penalty) + nil #'erc-server-send-queue buffer))))))) (defun erc-message (message-command line &optional force) "Send LINE to the server as a privmsg or a notice. diff --git a/lisp/erc/erc-capab.el b/lisp/erc/erc-capab.el index fc45725f789..4afe6a7614b 100644 --- a/lisp/erc/erc-capab.el +++ b/lisp/erc/erc-capab.el @@ -170,11 +170,11 @@ PARSED is an `erc-parsed' response struct." (string-match "^\\([-\\+]\\)\\(.+\\)$" msg)) (setf (erc-response.contents parsed) (if erc-capab-identify-mode - (erc-propertize (match-string 2 msg) - 'erc-identified - (if (string= (match-string 1 msg) "+") - 1 - 0)) + (propertize (match-string 2 msg) + 'erc-identified + (if (string= (match-string 1 msg) "+") + 1 + 0)) (match-string 2 msg))) nil))) @@ -190,9 +190,9 @@ PARSED is an `erc-parsed' response struct." ;; assuming the first use of `nickname' is the sender's nick (re-search-forward (regexp-quote nickname) nil t)) (goto-char (match-beginning 0)) - (insert (erc-propertize erc-capab-identify-prefix - 'font-lock-face - 'erc-capab-identify-unidentified)))))) + (insert (propertize erc-capab-identify-prefix + 'font-lock-face + 'erc-capab-identify-unidentified)))))) (defun erc-capab-identify-get-unidentified-nickname (parsed) "Return the nickname of the user if unidentified. diff --git a/lisp/erc/erc-compat.el b/lisp/erc/erc-compat.el index c77d5abf2e4..d71221b2674 100644 --- a/lisp/erc/erc-compat.el +++ b/lisp/erc/erc-compat.el @@ -43,12 +43,12 @@ Return the same string, if the encoding operation is trivial. See `erc-encoding-coding-alist'." (encode-coding-string s coding-system t)) -(defalias 'erc-propertize 'propertize) -(defalias 'erc-view-mode-enter 'view-mode-enter) +(define-obsolete-function-alias 'erc-propertize #'propertize "28.1") +(define-obsolete-function-alias 'erc-view-mode-enter #'view-mode-enter "28.1") (autoload 'help-function-arglist "help-fns") -(defalias 'erc-function-arglist 'help-function-arglist) -(defalias 'erc-delete-dups 'delete-dups) -(defalias 'erc-replace-regexp-in-string 'replace-regexp-in-string) +(define-obsolete-function-alias 'erc-function-arglist #'help-function-arglist "28.1") +(define-obsolete-function-alias 'erc-delete-dups #'delete-dups "28.1") +(define-obsolete-function-alias 'erc-replace-regexp-in-string #'replace-regexp-in-string "28.1") (defun erc-set-write-file-functions (new-val) (set (make-local-variable 'write-file-functions) new-val)) @@ -79,10 +79,12 @@ START is the beginning position of the last match (see `match-beginning'). See `replace-match' for explanations of FIXEDCASE and LITERAL." (replace-match newtext fixedcase literal string subexp)) -(defalias 'erc-with-selected-window 'with-selected-window) -(defalias 'erc-cancel-timer 'cancel-timer) -(defalias 'erc-make-obsolete 'make-obsolete) -(defalias 'erc-make-obsolete-variable 'make-obsolete-variable) +(define-obsolete-function-alias 'erc-with-selected-window + #'with-selected-window "28.1") +(define-obsolete-function-alias 'erc-cancel-timer #'cancel-timer "28.1") +(define-obsolete-function-alias 'erc-make-obsolete #'make-obsolete "28.1") +(define-obsolete-function-alias 'erc-make-obsolete-variable + #'make-obsolete-variable "28.1") ;; Provide a simpler replacement for `member-if' (defun erc-member-if (predicate list) diff --git a/lisp/erc/erc-dcc.el b/lisp/erc/erc-dcc.el index 26701cec1e4..bf98eb818f3 100644 --- a/lisp/erc/erc-dcc.el +++ b/lisp/erc/erc-dcc.el @@ -423,7 +423,7 @@ where FOO is one of CLOSE, GET, SEND, LIST, CHAT, etc." #'(lambda (elt) (eq (plist-get elt :type) 'CHAT)) erc-dcc-list))) - ('close (erc-delete-dups + ('close (delete-dups (mapcar (lambda (elt) (symbol-name (plist-get elt :type))) erc-dcc-list))) ('get (mapcar #'erc-dcc-nick @@ -627,17 +627,17 @@ that subcommand." ?q query ?n nick ?u login ?h host)))) (defconst erc-dcc-ctcp-query-send-regexp - (concat "^DCC SEND \\(" + (concat "^DCC SEND \\(?:" ;; Following part matches either filename without spaces ;; or filename enclosed in double quotes with any number ;; of escaped double quotes inside. - "\"\\(\\(.*?\\(\\\\\"\\)?\\)+?\\)\"\\|\\([^ ]+\\)" + "\"\\(\\(?:\\\\\"\\|[^\"\\]\\)+\\)\"\\|\\([^ ]+\\)" "\\) \\([0-9]+\\) \\([0-9]+\\) *\\([0-9]*\\)")) (define-inline erc-dcc-unquote-filename (filename) (inline-quote - (erc-replace-regexp-in-string "\\\\\\\\" "\\" - (erc-replace-regexp-in-string "\\\\\"" "\"" ,filename t t) t t))) + (replace-regexp-in-string "\\\\\\\\" "\\" + (replace-regexp-in-string "\\\\\"" "\"" ,filename t t) t t))) (defun erc-dcc-handle-ctcp-send (proc query nick login host to) "This is called if a CTCP DCC SEND subcommand is sent to the client. @@ -653,11 +653,11 @@ It extracts the information about the dcc request and adds it to ?r "SEND" ?n nick ?u login ?h host)) ((string-match erc-dcc-ctcp-query-send-regexp query) (let ((filename - (or (match-string 5 query) - (erc-dcc-unquote-filename (match-string 2 query)))) - (ip (erc-decimal-to-ip (match-string 6 query))) - (port (match-string 7 query)) - (size (match-string 8 query))) + (or (match-string 2 query) + (erc-dcc-unquote-filename (match-string 1 query)))) + (ip (erc-decimal-to-ip (match-string 3 query))) + (port (match-string 4 query)) + (size (match-string 5 query))) ;; FIXME: a warning really should also be sent ;; if the ip address != the host the dcc sender is on. (erc-display-message @@ -1193,8 +1193,8 @@ other client." (setq posn (match-end 0)) (erc-display-message nil nil proc - 'dcc-chat-privmsg ?n (erc-propertize erc-dcc-from 'font-lock-face - 'erc-nick-default-face) ?m line)) + 'dcc-chat-privmsg ?n (propertize erc-dcc-from 'font-lock-face + 'erc-nick-default-face) ?m line)) (setq erc-dcc-unprocessed-output (substring str posn))))) (defun erc-dcc-chat-buffer-killed () diff --git a/lisp/erc/erc-ezbounce.el b/lisp/erc/erc-ezbounce.el index 1032af7a304..5c2faff96de 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-goodies.el b/lisp/erc/erc-goodies.el index 94d5de280c6..ff7a77f1265 100644 --- a/lisp/erc/erc-goodies.el +++ b/lisp/erc/erc-goodies.el @@ -232,6 +232,10 @@ The value `erc-interpret-controls-p' must also be t for this to work." "ERC bold face." :group 'erc-faces) +(defface erc-italic-face '((t :slant italic)) + "ERC italic face." + :group 'erc-faces) + (defface erc-inverse-face '((t :foreground "White" :background "Black")) "ERC inverse face." @@ -383,6 +387,7 @@ See `erc-interpret-controls-p' and `erc-interpret-mirc-color' for options." (erc-controls-strip s)) (erc-interpret-controls-p (let ((boldp nil) + (italicp nil) (inversep nil) (underlinep nil) (fg nil) @@ -401,6 +406,8 @@ See `erc-interpret-controls-p' and `erc-interpret-mirc-color' for options." (setq bg bg-color)) ((string= control "\C-b") (setq boldp (not boldp))) + ((string= control "\C-]") + (setq italicp (not italicp))) ((string= control "\C-v") (setq inversep (not inversep))) ((string= control "\C-_") @@ -413,13 +420,14 @@ See `erc-interpret-controls-p' and `erc-interpret-mirc-color' for options." (ding))) ((string= control "\C-o") (setq boldp nil + italicp nil inversep nil underlinep nil fg nil bg nil)) (t nil)) (erc-controls-propertize - start end boldp inversep underlinep fg bg s))) + start end boldp italicp inversep underlinep fg bg s))) s)) (t s))))) @@ -432,13 +440,13 @@ See `erc-interpret-controls-p' and `erc-interpret-mirc-color' for options." s))) (defvar erc-controls-remove-regexp - "\C-b\\|\C-_\\|\C-v\\|\C-g\\|\C-o\\|\C-c[0-9]?[0-9]?\\(,[0-9][0-9]?\\)?" + "\C-b\\|\C-]\\|\C-_\\|\C-v\\|\C-g\\|\C-o\\|\C-c[0-9]?[0-9]?\\(,[0-9][0-9]?\\)?" "Regular expression which matches control characters to remove.") (defvar erc-controls-highlight-regexp - (concat "\\(\C-b\\|\C-v\\|\C-_\\|\C-g\\|\C-o\\|" + (concat "\\(\C-b\\|\C-]\\|\C-v\\|\C-_\\|\C-g\\|\C-o\\|" "\C-c\\([0-9][0-9]?\\)?\\(,\\([0-9][0-9]?\\)\\)?\\)" - "\\([^\C-b\C-v\C-_\C-c\C-g\C-o\n]*\\)") + "\\([^\C-b\C-]\C-v\C-_\C-c\C-g\C-o\n]*\\)") "Regular expression which matches control chars and the text to highlight.") (defun erc-controls-highlight () @@ -451,6 +459,7 @@ Also see `erc-interpret-controls-p' and `erc-interpret-mirc-color'." (replace-match ""))) (erc-interpret-controls-p (let ((boldp nil) + (italicp nil) (inversep nil) (underlinep nil) (fg nil) @@ -467,6 +476,8 @@ Also see `erc-interpret-controls-p' and `erc-interpret-mirc-color'." (setq bg bg-color)) ((string= control "\C-b") (setq boldp (not boldp))) + ((string= control "\C-]") + (setq italicp (not italicp))) ((string= control "\C-v") (setq inversep (not inversep))) ((string= control "\C-_") @@ -479,16 +490,17 @@ Also see `erc-interpret-controls-p' and `erc-interpret-mirc-color'." (ding))) ((string= control "\C-o") (setq boldp nil + italicp nil inversep nil underlinep nil fg nil bg nil)) (t nil)) (erc-controls-propertize start end - boldp inversep underlinep fg bg))))) + boldp italicp inversep underlinep fg bg))))) (t nil))) -(defun erc-controls-propertize (from to boldp inversep underlinep fg bg +(defun erc-controls-propertize (from to boldp italicp inversep underlinep fg bg &optional str) "Prepend properties from IRC control characters between FROM and TO. If optional argument STR is provided, apply to STR, otherwise prepend properties @@ -500,6 +512,9 @@ to a region in the current buffer." (append (if boldp '(erc-bold-face) nil) + (if italicp + '(erc-italic-face) + nil) (if inversep '(erc-inverse-face) nil) diff --git a/lisp/erc/erc-join.el b/lisp/erc/erc-join.el index 280d6bfe0f1..79c111082f6 100644 --- a/lisp/erc/erc-join.el +++ b/lisp/erc/erc-join.el @@ -113,7 +113,7 @@ servers, presumably in the same domain." This is called from a timer set up by `erc-autojoin-channels'." (if erc--autojoin-timer (setq erc--autojoin-timer - (erc-cancel-timer erc--autojoin-timer))) + (cancel-timer erc--autojoin-timer))) (with-current-buffer buffer ;; Don't kick of another delayed autojoin or try to wait for ;; another ident response: @@ -127,7 +127,7 @@ This is called from a timer set up by `erc-autojoin-channels'." This function is run from `erc-nickserv-identified-hook'." (if erc--autojoin-timer (setq erc--autojoin-timer - (erc-cancel-timer erc--autojoin-timer))) + (cancel-timer erc--autojoin-timer))) (when (eq erc-autojoin-timing 'ident) (let ((server (or erc-session-server erc-server-announced-name)) (joined (mapcar (lambda (buf) @@ -153,18 +153,20 @@ This function is run from `erc-nickserv-identified-hook'." 'erc-autojoin-channels-delayed server nick (current-buffer)))) ;; `erc-autojoin-timing' is `connect': - (dolist (l erc-autojoin-channels-alist) - (when (string-match (car l) server) - (let ((server (or erc-session-server erc-server-announced-name))) + (let ((server (or erc-session-server erc-server-announced-name))) + (dolist (l erc-autojoin-channels-alist) + (when (string-match-p (car l) server) (dolist (chan (cdr l)) - (let ((buffer (erc-get-buffer chan))) - ;; Only auto-join the channels that we aren't already in - ;; using a different nick. + (let ((buffer + (car (erc-buffer-filter + (lambda () + (let ((current (erc-default-target))) + (and (stringp current) + (string-match-p (car l) + (or erc-session-server erc-server-announced-name)) + (string-equal (erc-downcase chan) + (erc-downcase current))))))))) (when (or (not buffer) - ;; If the same channel is joined on another - ;; server the best-effort is to just join - (not (string-match (car l) - (process-name erc-server-process))) (not (with-current-buffer buffer (erc-server-process-alive)))) (erc-server-join-channel server chan)))))))) diff --git a/lisp/erc/erc-list.el b/lisp/erc/erc-list.el index 5faeabb721a..036d7733ed7 100644 --- a/lisp/erc/erc-list.el +++ b/lisp/erc/erc-list.el @@ -71,13 +71,13 @@ (defun erc-list-make-string (channel users topic) (concat channel - (erc-propertize " " - 'display (list 'space :align-to erc-list-nusers-column) - 'face 'fixed-pitch) + (propertize " " + 'display (list 'space :align-to erc-list-nusers-column) + 'face 'fixed-pitch) users - (erc-propertize " " - 'display (list 'space :align-to erc-list-topic-column) - 'face 'fixed-pitch) + (propertize " " + 'display (list 'space :align-to erc-list-topic-column) + 'face 'fixed-pitch) topic)) ;; Insert a record into the list buffer. @@ -143,19 +143,19 @@ ;; Helper function that makes a buttonized column header. (defun erc-list-button (title column) - (erc-propertize title - 'column-number column - 'help-echo "mouse-1: sort by column" - 'mouse-face 'header-line-highlight - 'keymap erc-list-menu-sort-button-map)) + (propertize title + 'column-number column + 'help-echo "mouse-1: sort by column" + 'mouse-face 'header-line-highlight + 'keymap erc-list-menu-sort-button-map)) (define-derived-mode erc-list-menu-mode special-mode "ERC-List" "Major mode for editing a list of irc channels." (setq header-line-format (concat - (erc-propertize " " - 'display '(space :align-to 0) - 'face 'fixed-pitch) + (propertize " " + 'display '(space :align-to 0) + 'face 'fixed-pitch) (erc-list-make-string (erc-list-button "Channel" 1) (erc-list-button "# Users" 2) "Topic"))) diff --git a/lisp/erc/erc-log.el b/lisp/erc/erc-log.el index 1bad6d16c87..e2c066da9b1 100644 --- a/lisp/erc/erc-log.el +++ b/lisp/erc/erc-log.el @@ -334,7 +334,7 @@ This will not work with full paths, only names. Any unsafe characters in the name are replaced with \"!\". The filename is downcased." - (downcase (erc-replace-regexp-in-string + (downcase (replace-regexp-in-string "[/\\]" "!" (convert-standard-filename filename)))) (defun erc-current-logfile (&optional buffer) diff --git a/lisp/erc/erc-match.el b/lisp/erc/erc-match.el index 3107ff2ccd1..6e87a183fc1 100644 --- a/lisp/erc/erc-match.el +++ b/lisp/erc/erc-match.el @@ -555,16 +555,15 @@ See `erc-log-match-format'." (and (eq erc-log-matches-flag 'away) (erc-away-time))) match-buffer-name) - (let ((line (format-spec erc-log-match-format - (format-spec-make - ?n nick - ?t (format-time-string - (or (and (boundp 'erc-timestamp-format) - erc-timestamp-format) - "[%Y-%m-%d %H:%M] ")) - ?c (or (erc-default-target) "") - ?m message - ?u nickuserhost)))) + (let ((line (format-spec + erc-log-match-format + `((?n . ,nick) + (?t . ,(format-time-string + (or (bound-and-true-p erc-timestamp-format) + "[%Y-%m-%d %H:%M] "))) + (?c . ,(or (erc-default-target) "")) + (?m . ,message) + (?u . ,nickuserhost))))) (with-current-buffer (erc-log-matches-make-buffer match-buffer-name) (let ((inhibit-read-only t)) (goto-char (point-max)) @@ -578,9 +577,9 @@ See `erc-log-match-format'." (with-current-buffer buffer (unless buffer-already (insert " == Type \"q\" to dismiss messages ==\n") - (erc-view-mode-enter nil (lambda (buffer) - (when (y-or-n-p "Discard messages? ") - (kill-buffer buffer))))) + (view-mode-enter nil (lambda (buffer) + (when (y-or-n-p "Discard messages? ") + (kill-buffer buffer))))) buffer))) (defun erc-log-matches-come-back (proc parsed) diff --git a/lisp/erc/erc-networks.el b/lisp/erc/erc-networks.el index 1234962c51c..8551cdd1dee 100644 --- a/lisp/erc/erc-networks.el +++ b/lisp/erc/erc-networks.el @@ -756,8 +756,8 @@ Return the name of this server's network as a symbol." (erc-with-server-buffer (intern (downcase (symbol-name erc-network))))) -(erc-make-obsolete 'erc-current-network 'erc-network - "Obsolete since erc-networks 1.5") +(make-obsolete 'erc-current-network 'erc-network + "Obsolete since erc-networks 1.5") (defun erc-network-name () "Return the name of the current network as a string." @@ -812,7 +812,7 @@ As an example: (let* ((completion-ignore-case t) (net (intern (completing-read "Network: " - (erc-delete-dups + (delete-dups (mapcar (lambda (x) (list (symbol-name (nth 1 x)))) erc-server-alist))))) diff --git a/lisp/erc/erc-speedbar.el b/lisp/erc/erc-speedbar.el index 5a469aa4e4e..b64e42b7ee4 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/erc/erc.el b/lisp/erc/erc.el index cfde84e19aa..41d7516fbb4 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -63,6 +63,8 @@ (require 'thingatpt) (require 'auth-source) (require 'erc-compat) +(require 'time-date) +(require 'iso8601) (eval-when-compile (require 'subr-x)) (defvar erc-official-location @@ -1212,7 +1214,7 @@ which the local user typed." :group 'erc-faces) (defface erc-header-line - '((t :foreground "grey20" :background "grey90")) + '((t :inherit header-line)) "ERC face used for the header line. This will only be used if `erc-header-line-face-method' is non-nil." @@ -1606,33 +1608,47 @@ symbol, it may have these values: (defun erc-generate-new-buffer-name (server port target) "Create a new buffer name based on the arguments." (when (numberp port) (setq port (number-to-string port))) - (let ((buf-name (or target - (or (let ((name (concat server ":" port))) - (when (> (length name) 1) - name)) - ;; This fallback should in fact never happen - "*erc-server-buffer*"))) - buffer-name) + (let* ((buf-name (or target + (let ((name (concat server ":" port))) + (when (> (length name) 1) + name)) + ;; This fallback should in fact never happen. + "*erc-server-buffer*")) + (full-buf-name (concat buf-name "/" server)) + (dup-buf-name (buffer-name (car (erc-channel-list nil)))) + buffer-name) ;; Reuse existing buffers, but not if the buffer is a connected server ;; buffer and not if its associated with a different server than the ;; current ERC buffer. - ;; if buf-name is taken by a different connection (or by something !erc) - ;; then see if "buf-name/server" meets the same criteria - (dolist (candidate (list buf-name (concat buf-name "/" server))) - (if (and (not buffer-name) - erc-reuse-buffers - (or (not (get-buffer candidate)) - (or target - (with-current-buffer (get-buffer candidate) - (and (erc-server-buffer-p) - (not (erc-server-process-alive))))) - (with-current-buffer (get-buffer candidate) - (and (string= erc-session-server server) - (erc-port-equal erc-session-port port))))) - (setq buffer-name candidate))) - ;; if buffer-name is unset, neither candidate worked out for us, + ;; If buf-name is taken by a different connection (or by something !erc) + ;; then see if "buf-name/server" meets the same criteria. + (if (and dup-buf-name (string-match-p (concat buf-name "/") dup-buf-name)) + (setq buffer-name full-buf-name) ; ERC buffer with full name already exists. + (dolist (candidate (list buf-name full-buf-name)) + (if (and (not buffer-name) + erc-reuse-buffers + (or (not (get-buffer candidate)) + ;; Looking for a server buffer, so there's no target. + (and (not target) + (with-current-buffer (get-buffer candidate) + (and (erc-server-buffer-p) + (not (erc-server-process-alive))))) + ;; Channel buffer; check that it's from the right server. + (and target + (with-current-buffer (get-buffer candidate) + (and (string= erc-session-server server) + (erc-port-equal erc-session-port port)))))) + (setq buffer-name candidate) + (when (and (not buffer-name) (get-buffer buf-name) erc-reuse-buffers) + ;; A new buffer will be created with the name buf-name/server, rename + ;; the existing name-duplicated buffer with the same format as well. + (with-current-buffer (get-buffer buf-name) + (when (derived-mode-p 'erc-mode) ; ensure it's an erc buffer + (rename-buffer + (concat buf-name "/" (or erc-session-server erc-server-announced-name))))))))) + ;; If buffer-name is unset, neither candidate worked out for us, ;; fallback to the old <N> uniquification method: - (or buffer-name (generate-new-buffer-name (concat buf-name "/" server))))) + (or buffer-name (generate-new-buffer-name full-buf-name)))) (defun erc-get-buffer-create (server port target) "Create a new buffer based on the arguments." @@ -1858,7 +1874,7 @@ buffer rather than a server buffer.") ;; modify `transforms' to specify what needs to be changed ;; each item is in the format '(old . new) (let ((transforms '((pcomplete . completion)))) - (erc-delete-dups + (delete-dups (mapcar (lambda (m) (or (cdr (assoc m transforms)) m)) mods)))) @@ -2311,7 +2327,7 @@ and appears in face `erc-input-face' in the buffer." (setq result (concat result network-name " << " line "\n"))) result) - (erc-propertize + (propertize (concat network-name " >> " string (if (/= ?\n (aref string @@ -2334,7 +2350,7 @@ If ARG is non-nil, show the *erc-protocol* buffer." (interactive "P") (let* ((buf (get-buffer-create "*erc-protocol*"))) (with-current-buffer buf - (erc-view-mode-enter) + (view-mode-enter) (when (null (current-local-map)) (let ((inhibit-read-only t)) (insert (erc-make-notice "This buffer displays all IRC protocol traffic exchanged with each server.\n")) @@ -2768,7 +2784,7 @@ See also `erc-server-send'." (defun erc-get-arglist (fun) "Return the argument list of a function without the parens." - (let ((arglist (format "%S" (erc-function-arglist fun)))) + (let ((arglist (format "%S" (help-function-arglist fun)))) (if (string-match "\\`(\\(.*\\))\\'" arglist) (match-string 1 arglist) arglist))) @@ -2903,6 +2919,44 @@ therefore has to contain the command itself as well." (erc-server-send (substring line 1)) t) +(defvar erc--read-time-period-history nil) + +(defun erc--read-time-period (prompt) + "Read a time period on the \"2h\" format. +If there's no letter spec, the input is interpreted as a number of seconds. + +If input is blank, this function returns nil. Otherwise it +returns the time spec converted to a number of seconds." + (let ((period (string-trim + (read-string prompt nil 'erc--read-time-period-history)))) + (cond + ;; Blank input. + ((zerop (length period)) + nil) + ;; All-number -- interpret as seconds. + ((string-match-p "\\`[0-9]+\\'" period) + (string-to-number period)) + ;; Parse as a time spec. + (t + (let ((time (condition-case nil + (iso8601-parse-duration + (concat (cond + ((string-match-p "\\`P" (upcase period)) + ;; Somebody typed in a full ISO8601 period. + (upcase period)) + ((string-match-p "[YD]" (upcase period)) + ;; If we have a year/day element, + ;; we have a full spec. + "P") + (t + ;; Otherwise it's just a sub-day spec. + "PT")) + (upcase period))) + (wrong-type-argument nil)))) + (unless time + (user-error "%s is not a valid time period" period)) + (decoded-time-period time)))))) + (defun erc-cmd-IGNORE (&optional user) "Ignore USER. This should be a regexp matching nick!user@host. If no USER argument is specified, list the contents of `erc-ignore-list'." @@ -2912,10 +2966,18 @@ If no USER argument is specified, list the contents of `erc-ignore-list'." (y-or-n-p (format "Use regexp-quoted form (%s) instead? " quoted))) (setq user quoted)) - (erc-display-line - (erc-make-notice (format "Now ignoring %s" user)) - 'active) - (erc-with-server-buffer (add-to-list 'erc-ignore-list user))) + (let ((timeout + (erc--read-time-period + "Add a timeout? (Blank for no, or a time spec like 2h): ")) + (buffer (current-buffer))) + (when timeout + (run-at-time timeout nil + (lambda () + (erc--unignore-user user buffer)))) + (erc-display-line + (erc-make-notice (format "Now ignoring %s" user)) + 'active) + (erc-with-server-buffer (add-to-list 'erc-ignore-list user)))) (if (null (erc-with-server-buffer erc-ignore-list)) (erc-display-line (erc-make-notice "Ignore list is empty") 'active) (erc-display-line (erc-make-notice "Ignore list:") 'active) @@ -2939,12 +3001,17 @@ If no USER argument is specified, list the contents of `erc-ignore-list'." (erc-make-notice (format "%s is not currently ignored!" user)) 'active))) (when ignored-nick + (erc--unignore-user user (current-buffer)))) + t) + +(defun erc--unignore-user (user buffer) + (when (buffer-live-p buffer) + (with-current-buffer buffer (erc-display-line (erc-make-notice (format "No longer ignoring %s" user)) 'active) (erc-with-server-buffer - (setq erc-ignore-list (delete ignored-nick erc-ignore-list))))) - t) + (setq erc-ignore-list (delete user erc-ignore-list)))))) (defun erc-cmd-CLEAR () "Clear the window content." @@ -3097,16 +3164,18 @@ were most recently invited. See also `invitation'." (setq chnl (erc-ensure-channel-name channel))) (when chnl ;; Prevent double joining of same channel on same server. - (let ((joined-channels - (mapcar #'(lambda (chanbuf) - (with-current-buffer chanbuf (erc-default-target))) - (erc-channel-list erc-server-process)))) - (if (erc-member-ignore-case chnl joined-channels) - (switch-to-buffer (car (erc-member-ignore-case chnl - joined-channels))) - (let ((server (with-current-buffer (process-buffer erc-server-process) - (or erc-session-server erc-server-announced-name)))) - (erc-server-join-channel server chnl key)))))) + (let* ((joined-channels + (mapcar #'(lambda (chanbuf) + (with-current-buffer chanbuf (erc-default-target))) + (erc-channel-list erc-server-process))) + (server (with-current-buffer (process-buffer erc-server-process) + (or erc-session-server erc-server-announced-name))) + (chnl-name (car (erc-member-ignore-case chnl joined-channels)))) + (if chnl-name + (switch-to-buffer (if (get-buffer chnl-name) + chnl-name + (concat chnl-name "/" server))) + (erc-server-join-channel server chnl key))))) t) (defalias 'erc-cmd-CHANNEL 'erc-cmd-JOIN) @@ -3502,7 +3571,7 @@ If S is non-nil, it will be used as the quit reason." If S is non-nil, it will be used as the quit reason." (or s (if (fboundp 'yow) - (erc-replace-regexp-in-string "\n" "" (yow)) + (replace-regexp-in-string "\n" "" (yow)) (erc-quit/part-reason-default)))) (make-obsolete 'erc-quit-reason-zippy "it will be removed." "24.4") @@ -3529,7 +3598,7 @@ If S is non-nil, it will be used as the part reason." If S is non-nil, it will be used as the quit reason." (or s (if (fboundp 'yow) - (erc-replace-regexp-in-string "\n" "" (yow)) + (replace-regexp-in-string "\n" "" (yow)) (erc-quit/part-reason-default)))) (make-obsolete 'erc-part-reason-zippy "it will be removed." "24.4") @@ -3945,13 +4014,13 @@ If FACE is non-nil, it will be used to propertize the prompt. If it is nil, ;; Do not extend the text properties when typing at the end ;; of the prompt, but stuff typed in front of the prompt ;; shall remain part of the prompt. - (setq prompt (erc-propertize prompt - 'start-open t ; XEmacs - 'rear-nonsticky t ; Emacs - 'erc-prompt t - 'field t - 'front-sticky t - 'read-only t)) + (setq prompt (propertize prompt + 'start-open t ; XEmacs + 'rear-nonsticky t ; Emacs + 'erc-prompt t + 'field t + 'front-sticky t + 'read-only t)) (erc-put-text-property 0 (1- (length prompt)) 'font-lock-face (or face 'erc-prompt-face) prompt) @@ -4334,15 +4403,15 @@ See also `erc-format-nick-function'." (defun erc-get-user-mode-prefix (user) (when user (cond ((erc-channel-user-owner-p user) - (erc-propertize "~" 'help-echo "owner")) + (propertize "~" 'help-echo "owner")) ((erc-channel-user-admin-p user) - (erc-propertize "&" 'help-echo "admin")) + (propertize "&" 'help-echo "admin")) ((erc-channel-user-op-p user) - (erc-propertize "@" 'help-echo "operator")) + (propertize "@" 'help-echo "operator")) ((erc-channel-user-halfop-p user) - (erc-propertize "%" 'help-echo "half-op")) + (propertize "%" 'help-echo "half-op")) ((erc-channel-user-voice-p user) - (erc-propertize "+" 'help-echo "voice")) + (propertize "+" 'help-echo "voice")) (t "")))) (defun erc-format-@nick (&optional user _channel-data) @@ -4353,7 +4422,7 @@ prefix. Use CHANNEL-DATA to determine op and voice status. See also `erc-format-nick-function'." (when user (let ((nick (erc-server-user-nickname user))) - (concat (erc-propertize + (concat (propertize (erc-get-user-mode-prefix nick) 'font-lock-face 'erc-nick-prefix-face) nick)))) @@ -4366,12 +4435,12 @@ also `erc-format-nick-function'." (nick (erc-current-nick)) (mode (erc-get-user-mode-prefix nick))) (concat - (erc-propertize open 'font-lock-face 'erc-default-face) - (erc-propertize mode 'font-lock-face 'erc-my-nick-prefix-face) - (erc-propertize nick 'font-lock-face 'erc-my-nick-face) - (erc-propertize close 'font-lock-face 'erc-default-face))) + (propertize open 'font-lock-face 'erc-default-face) + (propertize mode 'font-lock-face 'erc-my-nick-prefix-face) + (propertize nick 'font-lock-face 'erc-my-nick-face) + (propertize close 'font-lock-face 'erc-default-face))) (let ((prefix "> ")) - (erc-propertize prefix 'font-lock-face 'erc-default-face)))) + (propertize prefix 'font-lock-face 'erc-default-face)))) (defun erc-echo-notice-in-default-buffer (s parsed buffer _sender) "Echos a private notice in the default buffer, namely the @@ -6391,17 +6460,16 @@ if `erc-away' is non-nil." (defun erc-update-mode-line-buffer (buffer) "Update the mode line in a single ERC buffer BUFFER." (with-current-buffer buffer - (let ((spec (format-spec-make - ?a (erc-format-away-status) - ?l (erc-format-lag-time) - ?m (erc-format-channel-modes) - ?n (or (erc-current-nick) "") - ?N (erc-format-network) - ?o (or (erc-controls-strip erc-channel-topic) "") - ?p (erc-port-to-string erc-session-port) - ?s (erc-format-target-and/or-server) - ?S (erc-format-target-and/or-network) - ?t (erc-format-target))) + (let ((spec `((?a . ,(erc-format-away-status)) + (?l . ,(erc-format-lag-time)) + (?m . ,(erc-format-channel-modes)) + (?n . ,(or (erc-current-nick) "")) + (?N . ,(erc-format-network)) + (?o . ,(or (erc-controls-strip erc-channel-topic) "")) + (?p . ,(erc-port-to-string erc-session-port)) + (?s . ,(erc-format-target-and/or-server)) + (?S . ,(erc-format-target-and/or-network)) + (?t . ,(erc-format-target)))) (process-status (cond ((and (erc-server-process-alive) (not erc-server-connected)) ":connecting") @@ -6434,16 +6502,16 @@ if `erc-away' is non-nil." (fill-region (point-min) (point-max)) (buffer-string)))) (setq header-line-format - (erc-replace-regexp-in-string + (replace-regexp-in-string "%" "%%" (if face - (erc-propertize header 'help-echo help-echo - 'face face) - (erc-propertize header 'help-echo help-echo)))))) + (propertize header 'help-echo help-echo + 'face face) + (propertize header 'help-echo help-echo)))))) (t (setq header-line-format (if face - (erc-propertize header 'face face) + (propertize header 'face face) header))))))) (force-mode-line-update))) @@ -6710,7 +6778,7 @@ functions." nick user host channel (if (not (string= reason "")) (format ": %s" - (erc-replace-regexp-in-string "%" "%%" reason)) + (replace-regexp-in-string "%" "%%" reason)) ""))))) diff --git a/lisp/eshell/em-cmpl.el b/lisp/eshell/em-cmpl.el index 48c99acac33..dcf56af6051 100644 --- a/lisp/eshell/em-cmpl.el +++ b/lisp/eshell/em-cmpl.el @@ -244,6 +244,26 @@ to writing a completion function." (let ((completion-at-point-functions '(elisp-completion-at-point))) (completion-at-point))) +(defvar eshell-cmpl-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [(control ?i)] #'completion-at-point) + ;; jww (1999-10-19): Will this work on anything but X? + (define-key map [backtab] #'pcomplete-reverse) + (define-key map [(meta ??)] #'completion-help-at-point) + (define-key map [(meta control ?i)] #'eshell-complete-lisp-symbol) + ;; C-c prefix: + (define-key map (kbd "C-c M-h") #'eshell-completion-help) + (define-key map (kbd "C-c TAB") #'pcomplete-expand-and-complete) + (define-key map (kbd "C-c C-i") #'pcomplete-expand-and-complete) + (define-key map (kbd "C-c SPC") #'pcomplete-expand) + map)) + +(define-minor-mode eshell-cmpl-mode + "Minor mode that provides a keymap when `eshell-cmpl' active. + +\\{eshell-cmpl-mode-map}" + :keymap eshell-cmpl-mode-map) + (defun eshell-cmpl-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the completions module." (set (make-local-variable 'pcomplete-command-completion-function) @@ -291,22 +311,9 @@ to writing a completion function." eshell-special-chars-outside-quoting))) nil t) (add-hook 'pcomplete-quote-arg-hook #'eshell-quote-backslash nil t) - ;;(define-key eshell-mode-map [(meta tab)] 'eshell-complete-lisp-symbol) ; Redundant - (define-key eshell-mode-map [(meta control ?i)] 'eshell-complete-lisp-symbol) - (define-key eshell-command-map [(meta ?h)] 'eshell-completion-help) - (define-key eshell-command-map [tab] 'pcomplete-expand-and-complete) - (define-key eshell-command-map [(control ?i)] - 'pcomplete-expand-and-complete) - (define-key eshell-command-map [space] 'pcomplete-expand) - (define-key eshell-command-map [? ] 'pcomplete-expand) - ;;(define-key eshell-mode-map [tab] 'completion-at-point) ;Redundant! - (define-key eshell-mode-map [(control ?i)] 'completion-at-point) (add-hook 'completion-at-point-functions #'pcomplete-completions-at-point nil t) - ;; jww (1999-10-19): Will this work on anything but X? - (define-key eshell-mode-map - (if (featurep 'xemacs) [iso-left-tab] [backtab]) 'pcomplete-reverse) - (define-key eshell-mode-map [(meta ??)] 'completion-help-at-point)) + (eshell-cmpl-mode)) (defun eshell-completion-command-name () "Return the command name, possibly sans globbing." diff --git a/lisp/eshell/em-dirs.el b/lisp/eshell/em-dirs.el index 1949e5dc8fc..51df6fa1d52 100644 --- a/lisp/eshell/em-dirs.el +++ b/lisp/eshell/em-dirs.el @@ -168,6 +168,9 @@ Thus, this does not include the current directory.") (defvar eshell-last-dir-ring nil "The last directory that Eshell was in.") +(defconst eshell-inside-emacs (format "%s,eshell" emacs-version) + "Value for the `INSIDE_EMACS' environment variable.") + ;;; Functions: (defun eshell-dirs-initialize () ;Called from `eshell-mode' via intern-soft! @@ -191,6 +194,8 @@ Thus, this does not include the current directory.") (unless (ring-empty-p eshell-last-dir-ring) (expand-file-name (ring-ref eshell-last-dir-ring 0)))) + t) + ("INSIDE_EMACS" eshell-inside-emacs t)))) (when eshell-cd-on-directory diff --git a/lisp/eshell/em-glob.el b/lisp/eshell/em-glob.el index 43483dcd50e..a32a6abe29c 100644 --- a/lisp/eshell/em-glob.el +++ b/lisp/eshell/em-glob.el @@ -232,8 +232,6 @@ resulting regular expression." (regexp-quote (substring pattern matched-in-pattern)) "\\'"))) -(defvar ange-cache) ; XEmacs? See esh-util - (defun eshell-extended-glob (glob) "Return a list of files generated from GLOB, perhaps looking for DIRS-ONLY. This function almost fully supports zsh style filename generation @@ -252,7 +250,7 @@ the form: (INCLUDE-REGEXP EXCLUDE-REGEXP (PRED-FUNC-LIST) (MOD-FUNC-LIST))" (let ((paths (eshell-split-path glob)) - eshell-glob-matches message-shown ange-cache) + eshell-glob-matches message-shown) (unwind-protect (if (and (cdr paths) (file-name-absolute-p (car paths))) diff --git a/lisp/eshell/em-hist.el b/lisp/eshell/em-hist.el index 73742a361da..267936583e1 100644 --- a/lisp/eshell/em-hist.el +++ b/lisp/eshell/em-hist.el @@ -202,6 +202,32 @@ element, regardless of any text on the command line. In that case, map) "Keymap used in isearch in Eshell.") +(defvar eshell-hist-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [up] #'eshell-previous-matching-input-from-input) + (define-key map [down] #'eshell-next-matching-input-from-input) + (define-key map [(control up)] #'eshell-previous-input) + (define-key map [(control down)] #'eshell-next-input) + (define-key map [(meta ?r)] #'eshell-previous-matching-input) + (define-key map [(meta ?s)] #'eshell-next-matching-input) + (define-key map (kbd "C-c M-r") #'eshell-previous-matching-input-from-input) + (define-key map (kbd "C-c M-s") #'eshell-next-matching-input-from-input) + ;; FIXME: Relies on `eshell-hist-match-partial' being set _before_ + ;; em-hist is loaded and won't respect changes. + (if eshell-hist-match-partial + (progn + (define-key map [(meta ?p)] 'eshell-previous-matching-input-from-input) + (define-key map [(meta ?n)] 'eshell-next-matching-input-from-input) + (define-key map (kbd "C-c M-p") #'eshell-previous-input) + (define-key map (kbd "C-c M-n") #'eshell-next-input)) + (define-key map [(meta ?p)] #'eshell-previous-input) + (define-key map [(meta ?n)] #'eshell-next-input) + (define-key map (kbd "C-c M-p") #'eshell-previous-matching-input-from-input) + (define-key map (kbd "C-c M-n") #'eshell-next-matching-input-from-input)) + (define-key map (kbd "C-c C-l") #'eshell-list-history) + (define-key map (kbd "C-c C-x") #'eshell-get-next-from-history) + map)) + (defvar eshell-rebind-keys-alist) ;;; Functions: @@ -216,6 +242,12 @@ Returns non-nil if INPUT is blank." Returns nil if INPUT is prepended by blank space, otherwise non-nil." (not (string-match-p "\\`\\s-+" input))) +(define-minor-mode eshell-hist-mode + "Minor mode for the eshell-hist module. + +\\{eshell-hist-mode-map}" + :keymap eshell-hist-mode-map) + (defun eshell-hist-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the history management code for one Eshell buffer." (when (eshell-using-module 'eshell-cmpl) @@ -242,30 +274,7 @@ Returns nil if INPUT is prepended by blank space, otherwise non-nil." (lambda () (setq overriding-terminal-local-map nil))) nil t)) - (define-key eshell-mode-map [up] 'eshell-previous-matching-input-from-input) - (define-key eshell-mode-map [down] 'eshell-next-matching-input-from-input) - (define-key eshell-mode-map [(control up)] 'eshell-previous-input) - (define-key eshell-mode-map [(control down)] 'eshell-next-input) - (define-key eshell-mode-map [(meta ?r)] 'eshell-previous-matching-input) - (define-key eshell-mode-map [(meta ?s)] 'eshell-next-matching-input) - (define-key eshell-command-map [(meta ?r)] - 'eshell-previous-matching-input-from-input) - (define-key eshell-command-map [(meta ?s)] - 'eshell-next-matching-input-from-input) - (if eshell-hist-match-partial - (progn - (define-key eshell-mode-map [(meta ?p)] - 'eshell-previous-matching-input-from-input) - (define-key eshell-mode-map [(meta ?n)] - 'eshell-next-matching-input-from-input) - (define-key eshell-command-map [(meta ?p)] 'eshell-previous-input) - (define-key eshell-command-map [(meta ?n)] 'eshell-next-input)) - (define-key eshell-mode-map [(meta ?p)] 'eshell-previous-input) - (define-key eshell-mode-map [(meta ?n)] 'eshell-next-input) - (define-key eshell-command-map [(meta ?p)] - 'eshell-previous-matching-input-from-input) - (define-key eshell-command-map [(meta ?n)] - 'eshell-next-matching-input-from-input))) + (eshell-hist-mode)) (make-local-variable 'eshell-history-size) (or eshell-history-size @@ -300,10 +309,7 @@ Returns nil if INPUT is prepended by blank space, otherwise non-nil." (add-hook 'kill-emacs-hook #'eshell-save-some-history) (make-local-variable 'eshell-input-filter-functions) - (add-hook 'eshell-input-filter-functions #'eshell-add-to-history nil t) - - (define-key eshell-command-map [(control ?l)] 'eshell-list-history) - (define-key eshell-command-map [(control ?x)] 'eshell-get-next-from-history)) + (add-hook 'eshell-input-filter-functions #'eshell-add-to-history nil t)) (defun eshell-save-some-history () "Save the history for any open Eshell buffers." diff --git a/lisp/eshell/em-ls.el b/lisp/eshell/em-ls.el index 70b3ad611a1..c1a022ee521 100644 --- a/lisp/eshell/em-ls.el +++ b/lisp/eshell/em-ls.el @@ -239,7 +239,6 @@ scope during the evaluation of TEST-SEXP." (defvar show-recursive) (defvar show-size) (defvar sort-method) -(defvar ange-cache) (defvar dired-flag) ;;; Functions: @@ -406,7 +405,7 @@ Sort entries alphabetically across.") (setq listing-style 'by-columns)) (unless args (setq args (list "."))) - (let ((eshell-ls-exclude-regexp eshell-ls-exclude-regexp) ange-cache) + (let ((eshell-ls-exclude-regexp eshell-ls-exclude-regexp)) (when ignore-pattern (unless (eshell-using-module 'eshell-glob) (error (concat "-I option requires that `eshell-glob'" diff --git a/lisp/eshell/em-pred.el b/lisp/eshell/em-pred.el index ee4b28fb3ae..c26f654e278 100644 --- a/lisp/eshell/em-pred.el +++ b/lisp/eshell/em-pred.el @@ -229,6 +229,12 @@ FOR LISTS OF ARGUMENTS: EXAMPLES: *.c(:o) sorted list of .c files") +(defvar eshell-pred-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c M-q") #'eshell-display-predicate-help) + (define-key map (kbd "C-c M-m") #'eshell-display-modifier-help) + map)) + ;;; Functions: (defun eshell-display-predicate-help () @@ -245,12 +251,17 @@ EXAMPLES: (lambda () (insert eshell-modifier-help-string))))) +(define-minor-mode eshell-pred-mode + "Minor mode for the eshell-pred module. + +\\{eshell-pred-mode-map}" + :keymap eshell-pred-mode-map) + (defun eshell-pred-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the predicate/modifier code." (add-hook 'eshell-parse-argument-hook #'eshell-parse-arg-modifier t t) - (define-key eshell-command-map [(meta ?q)] 'eshell-display-predicate-help) - (define-key eshell-command-map [(meta ?m)] 'eshell-display-modifier-help)) + (eshell-pred-mode)) (defun eshell-apply-modifiers (lst predicates modifiers) "Apply to LIST a series of PREDICATES and MODIFIERS." @@ -440,11 +451,9 @@ resultant list of strings." `(lambda (file) (let ((attrs (file-attributes file))) (if attrs - (,(if (eq qual ?-) - 'time-less-p - (if (eq qual ?+) - '(lambda (a b) (time-less-p b a)) - 'time-equal-p)) + (,(cond ((eq qual ?-) #'time-less-p) + ((eq qual ?+) (lambda (a b) (time-less-p b a))) + (#'time-equal-p)) ,when (nth ,attr-index attrs))))))) (defun eshell-pred-file-type (type) @@ -467,7 +476,7 @@ that `ls -l' will show in the first column of its display." (defsubst eshell-pred-file-mode (mode) "Return a test which tests that MODE pertains to the file." `(lambda (file) - (let ((modes (file-modes file))) + (let ((modes (file-modes file 'nofollow))) (if modes (logand ,mode modes))))) diff --git a/lisp/eshell/em-prompt.el b/lisp/eshell/em-prompt.el index bbf3b94ff44..9ae5ae12816 100644 --- a/lisp/eshell/em-prompt.el +++ b/lisp/eshell/em-prompt.el @@ -97,8 +97,20 @@ arriving, or after." :options '(eshell-show-maximum-output) :group 'eshell-prompt) +(defvar eshell-prompt-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c C-n") #'eshell-next-prompt) + (define-key map (kbd "C-c C-p") #'eshell-previous-prompt) + map)) + ;;; Functions: +(define-minor-mode eshell-prompt-mode + "Minor mode for eshell-prompt module. + +\\{eshell-prompt-mode-map}" + :keymap eshell-prompt-mode-map) + (defun eshell-prompt-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the prompting code." (unless eshell-non-interactive-p @@ -110,9 +122,7 @@ arriving, or after." (set (make-local-variable 'eshell-skip-prompt-function) 'eshell-skip-prompt) - - (define-key eshell-command-map [(control ?n)] 'eshell-next-prompt) - (define-key eshell-command-map [(control ?p)] 'eshell-previous-prompt))) + (eshell-prompt-mode))) (defun eshell-emit-prompt () "Emit a prompt if eshell is being used interactively." diff --git a/lisp/eshell/em-rebind.el b/lisp/eshell/em-rebind.el index 85593e45160..bf5a4bf1afe 100644 --- a/lisp/eshell/em-rebind.el +++ b/lisp/eshell/em-rebind.el @@ -137,6 +137,11 @@ This is default behavior of shells like bash." :type '(repeat function) :group 'eshell-rebind) +(defvar eshell-rebind-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c M-l") #'eshell-lock-local-map) + map)) + ;; Internal Variables: (defvar eshell-input-keymap) @@ -145,6 +150,12 @@ This is default behavior of shells like bash." ;;; Functions: +(define-minor-mode eshell-rebind-mode + "Minor mode for the eshell-rebind module. + +\\{eshell-rebind-mode-map}" + :keymap eshell-rebind-mode-map) + (defun eshell-rebind-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the inputting code." (unless eshell-non-interactive-p @@ -154,7 +165,7 @@ This is default behavior of shells like bash." (make-local-variable 'overriding-local-map) (add-hook 'post-command-hook 'eshell-rebind-input-map nil t) (set (make-local-variable 'eshell-lock-keymap) nil) - (define-key eshell-command-map [(meta ?l)] 'eshell-lock-local-map))) + (eshell-rebind-mode))) (defun eshell-lock-local-map (&optional arg) "Lock or unlock the current local keymap. diff --git a/lisp/eshell/em-unix.el b/lisp/eshell/em-unix.el index 51699a7aa46..fbd3cfbb6fc 100644 --- a/lisp/eshell/em-unix.el +++ b/lisp/eshell/em-unix.el @@ -469,8 +469,6 @@ Remove the DIRECTORY(ies), if they are empty.") (eshell-parse-command (format "tar %s %s" tar-args archive) args)))) -(defvar ange-cache) ; XEmacs? See esh-util - ;; this is to avoid duplicating code... (defmacro eshell-mvcpln-template (command action func query-var force-var &optional preserve) @@ -488,8 +486,7 @@ Remove the DIRECTORY(ies), if they are empty.") (or (not no-dereference) (not (file-symlink-p (car args))))))) (eshell-shorthand-tar-command ,command args) - (let ((target (car (last args))) - ange-cache) + (let ((target (car (last args)))) (setcdr (last args 2) nil) (eshell-shuffle-files ,command ,action args target ,func nil @@ -924,7 +921,7 @@ Summarize disk usage of each FILE, recursively for directories.") ;; filesystem support means nothing under Windows (if (eshell-under-windows-p) (setq only-one-filesystem nil)) - (let ((size 0.0) ange-cache) + (let ((size 0.0)) (while args (if only-one-filesystem (setq only-one-filesystem diff --git a/lisp/eshell/esh-arg.el b/lisp/eshell/esh-arg.el index 86ceb41ffd2..e7b07b4208d 100644 --- a/lisp/eshell/esh-arg.el +++ b/lisp/eshell/esh-arg.el @@ -155,14 +155,22 @@ treated as a literal character." :type 'hook :group 'eshell-arg) +(defvar eshell-arg-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c M-b") #'eshell-insert-buffer-name) + map)) + ;;; Functions: +(define-minor-mode eshell-arg-mode + "Minor mode for the arg eshell module. + +\\{eshell-arg-mode-map}" + :keymap eshell-arg-mode-map) + (defun eshell-arg-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the argument parsing code." - ;; This is supposedly run after enabling esh-mode, when eshell-mode-map - ;; already exists. - (defvar eshell-command-map) - (define-key eshell-command-map [(meta ?b)] 'eshell-insert-buffer-name) + (eshell-arg-mode) (set (make-local-variable 'eshell-inside-quote-regexp) nil) (set (make-local-variable 'eshell-outside-quote-regexp) nil)) diff --git a/lisp/eshell/esh-mode.el b/lisp/eshell/esh-mode.el index db5fddb2aaf..d0147b345aa 100644 --- a/lisp/eshell/esh-mode.el +++ b/lisp/eshell/esh-mode.el @@ -213,10 +213,7 @@ This is used by `eshell-watch-for-password-prompt'." ;; these are only set to nil initially for the sake of the ;; byte-compiler, when compiling other files which `require' this one (defvar eshell-mode nil) -(defvar eshell-mode-map nil) (defvar eshell-command-running-string "--") -(defvar eshell-command-map nil) -(defvar eshell-command-prefix nil) (defvar eshell-last-input-start nil) (defvar eshell-last-input-end nil) (defvar eshell-last-output-start nil) @@ -280,6 +277,32 @@ This is used by `eshell-watch-for-password-prompt'." (standard-syntax-table)) st)) +(defvar eshell-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [(control ?c)] 'eshell-command-map) + (define-key map "\r" #'eshell-send-input) + (define-key map "\M-\r" #'eshell-queue-input) + (define-key map [(meta control ?l)] #'eshell-show-output) + (define-key map [(control ?a)] #'eshell-bol) + map)) + +(defvar eshell-command-map + (let ((map (define-prefix-command 'eshell-command-map))) + (define-key map [(meta ?o)] #'eshell-mark-output) + (define-key map [(meta ?d)] #'eshell-toggle-direct-send) + (define-key map [(control ?a)] #'eshell-bol) + (define-key map [(control ?b)] #'eshell-backward-argument) + (define-key map [(control ?e)] #'eshell-show-maximum-output) + (define-key map [(control ?f)] #'eshell-forward-argument) + (define-key map [(control ?m)] #'eshell-copy-old-input) + (define-key map [(control ?o)] #'eshell-kill-output) + (define-key map [(control ?r)] #'eshell-show-output) + (define-key map [(control ?t)] #'eshell-truncate-buffer) + (define-key map [(control ?u)] #'eshell-kill-input) + (define-key map [(control ?w)] #'backward-kill-word) + (define-key map [(control ?y)] #'eshell-repeat-argument) + map)) + ;;; User Functions: (defun eshell-kill-buffer-function () @@ -298,10 +321,6 @@ and the hook `eshell-exit-hook'." "Emacs shell interactive mode." (setq-local eshell-mode t) - ;; FIXME: What the hell!? - (setq-local eshell-mode-map (make-sparse-keymap)) - (use-local-map eshell-mode-map) - (when eshell-status-in-mode-line (make-local-variable 'eshell-command-running-string) (let ((fmt (copy-sequence mode-line-format))) @@ -310,31 +329,6 @@ and the hook `eshell-exit-hook'." (if mode-line-elt (setcar mode-line-elt 'eshell-command-running-string)))) - (define-key eshell-mode-map "\r" 'eshell-send-input) - (define-key eshell-mode-map "\M-\r" 'eshell-queue-input) - (define-key eshell-mode-map [(meta control ?l)] 'eshell-show-output) - (define-key eshell-mode-map [(control ?a)] 'eshell-bol) - - (setq-local eshell-command-prefix (make-symbol "eshell-command-prefix")) - (fset eshell-command-prefix (make-sparse-keymap)) - (setq-local eshell-command-map (symbol-function eshell-command-prefix)) - (define-key eshell-mode-map [(control ?c)] eshell-command-prefix) - - (define-key eshell-command-map [(meta ?o)] 'eshell-mark-output) - (define-key eshell-command-map [(meta ?d)] 'eshell-toggle-direct-send) - - (define-key eshell-command-map [(control ?a)] 'eshell-bol) - (define-key eshell-command-map [(control ?b)] 'eshell-backward-argument) - (define-key eshell-command-map [(control ?e)] 'eshell-show-maximum-output) - (define-key eshell-command-map [(control ?f)] 'eshell-forward-argument) - (define-key eshell-command-map [(control ?m)] 'eshell-copy-old-input) - (define-key eshell-command-map [(control ?o)] 'eshell-kill-output) - (define-key eshell-command-map [(control ?r)] 'eshell-show-output) - (define-key eshell-command-map [(control ?t)] 'eshell-truncate-buffer) - (define-key eshell-command-map [(control ?u)] 'eshell-kill-input) - (define-key eshell-command-map [(control ?w)] 'backward-kill-word) - (define-key eshell-command-map [(control ?y)] 'eshell-repeat-argument) - (setq local-abbrev-table eshell-mode-abbrev-table) (set (make-local-variable 'list-buffers-directory) diff --git a/lisp/eshell/esh-proc.el b/lisp/eshell/esh-proc.el index c3ac3a5b71b..db1b258c8f5 100644 --- a/lisp/eshell/esh-proc.el +++ b/lisp/eshell/esh-proc.el @@ -109,6 +109,16 @@ information, for example." (defvar eshell-process-list nil "A list of the current status of subprocesses.") +(defvar eshell-proc-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c M-i") #'eshell-insert-process) + (define-key map (kbd "C-c C-c") #'eshell-interrupt-process) + (define-key map (kbd "C-c C-k") #'eshell-kill-process) + (define-key map (kbd "C-c C-d") #'eshell-send-eof-to-process) + (define-key map (kbd "C-c C-s") #'list-processes) + (define-key map (kbd "C-c C-\\") #'eshell-quit-process) + map)) + ;;; Functions: (defun eshell-kill-process-function (proc status) @@ -121,20 +131,16 @@ PROC and STATUS to functions on the latter." (eshell-reset-after-proc status) (run-hook-with-args 'eshell-kill-hook proc status)) +(define-minor-mode eshell-proc-mode + "Minor mode for the proc eshell module. + +\\{eshell-proc-mode-map}" + :keymap eshell-proc-mode-map) + (defun eshell-proc-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the process handling code." (make-local-variable 'eshell-process-list) - ;; This is supposedly run after enabling esh-mode, when eshell-command-map - ;; already exists. - (defvar eshell-command-map) - (define-key eshell-command-map [(meta ?i)] 'eshell-insert-process) - (define-key eshell-command-map [(control ?c)] 'eshell-interrupt-process) - (define-key eshell-command-map [(control ?k)] 'eshell-kill-process) - (define-key eshell-command-map [(control ?d)] 'eshell-send-eof-to-process) -; (define-key eshell-command-map [(control ?q)] 'eshell-continue-process) - (define-key eshell-command-map [(control ?s)] 'list-processes) -; (define-key eshell-command-map [(control ?z)] 'eshell-stop-process) - (define-key eshell-command-map [(control ?\\)] 'eshell-quit-process)) + (eshell-proc-mode)) (defun eshell-reset-after-proc (status) "Reset the command input location after a process terminates. @@ -289,7 +295,7 @@ See `eshell-needs-pipe'." (process-environment (eshell-environment-variables)) proc decoding encoding changed) (cond - ((fboundp 'start-file-process) + ((fboundp 'make-process) (setq proc (let ((process-connection-type (unless (eshell-needs-pipe-p command) diff --git a/lisp/eshell/esh-util.el b/lisp/eshell/esh-util.el index 0328c1f12fa..ab030ede05b 100644 --- a/lisp/eshell/esh-util.el +++ b/lisp/eshell/esh-util.el @@ -647,14 +647,8 @@ gid format. Valid values are `string' and `integer', defaulting to (let ((base (file-name-nondirectory file)) (dir (file-name-directory file))) (if (string-equal "" base) (setq base ".")) - (if (boundp 'ange-cache) - (setq entry (cdr (assoc base (cdr (assoc dir ange-cache)))))) (unless entry (setq entry (eshell-parse-ange-ls dir)) - (if (boundp 'ange-cache) - (setq ange-cache - (cons (cons dir entry) - ange-cache))) (if entry (let ((fentry (assoc base (cdr entry)))) (if fentry diff --git a/lisp/eshell/esh-var.el b/lisp/eshell/esh-var.el index 75ccf5b8353..96838d41327 100644 --- a/lisp/eshell/esh-var.el +++ b/lisp/eshell/esh-var.el @@ -179,26 +179,50 @@ if they are quoted with a backslash." (eshell-apply-indices eshell-command-arguments indices))))) "This list provides aliasing for variable references. -It is very similar in concept to what `eshell-user-aliases-list' does -for commands. Each member of this defines the name of a command, -and the Lisp value to return for that variable if it is accessed -via the syntax `$NAME'. - -If the value is a function, that function will be called with two -arguments: the list of the indices that was used in the reference, and -whether the user is requesting the length of the ultimate element. -For example, a reference of `$NAME[10][20]' would result in the -function for alias `NAME' being called (assuming it were aliased to a -function), and the arguments passed to this function would be the list -'(10 20)', and nil." +Each member defines the name of a variable, and a Lisp value used to +compute the string value that will be returned when the variable is +accessed via the syntax `$NAME'. + +If the value is a function, call that function with two arguments: the +list of the indices that was used in the reference, and whether the +user is requesting the length of the ultimate element. For example, a +reference of `$NAME[10][20]' would result in the function for alias +`NAME' being called (assuming it were aliased to a function), and the +arguments passed to this function would be the list '(10 20)', and +nil. + +If the value is a string, return the value for the variable with that +name in the current environment. If no variable with that name exists +in the environment, but if a symbol with that same name exists and has +a value bound to it, return its value instead. You can prioritize +symbol values over environment values by setting +`eshell-prefer-lisp-variables' to t. + +If the value is a symbol, return the value bound to it. + +If the value has any other type, signal an error. + +Additionally, each member may specify if it should be copied to the +environment of created subprocesses." :type '(repeat (list string sexp (choice (const :tag "Copy to environment" t) (const :tag "Use only in Eshell" nil))))) (put 'eshell-variable-aliases-list 'risky-local-variable t) +(defvar eshell-var-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c M-v") #'eshell-insert-envvar) + map)) + ;;; Functions: +(define-minor-mode eshell-var-mode + "Minor mode for the esh-var module. + +\\{eshell-var-mode-map}" + :keymap eshell-var-mode-map) + (defun eshell-var-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the variable handle code." ;; Break the association with our parent's environment. Otherwise, @@ -207,11 +231,6 @@ function), and the arguments passed to this function would be the list (set (make-local-variable 'process-environment) (eshell-copy-environment))) - ;; This is supposedly run after enabling esh-mode, when eshell-command-map - ;; already exists. - (defvar eshell-command-map) - (define-key eshell-command-map [(meta ?v)] 'eshell-insert-envvar) - (set (make-local-variable 'eshell-special-chars-inside-quoting) (append eshell-special-chars-inside-quoting '(?$))) (set (make-local-variable 'eshell-special-chars-outside-quoting) diff --git a/lisp/eshell/eshell.el b/lisp/eshell/eshell.el index 2a63882ff09..5ffb159b575 100644 --- a/lisp/eshell/eshell.el +++ b/lisp/eshell/eshell.el @@ -265,14 +265,18 @@ information on Eshell, see Info node `(eshell)Top'." (eshell-mode)) buf)) -(defun eshell-return-exits-minibuffer () - ;; This is supposedly run after enabling esh-mode, when eshell-mode-map - ;; already exists. - (defvar eshell-mode-map) - (define-key eshell-mode-map [(control ?g)] 'abort-recursive-edit) - (define-key eshell-mode-map [(control ?m)] 'exit-minibuffer) - (define-key eshell-mode-map [(control ?j)] 'exit-minibuffer) - (define-key eshell-mode-map [(meta control ?m)] 'exit-minibuffer)) +(define-minor-mode eshell-command-mode + "Minor mode for `eshell-command' input. +\\{eshell-command-mode-map}" + :keymap (let ((map (make-sparse-keymap))) + (define-key map [(control ?g)] 'abort-recursive-edit) + (define-key map [(control ?m)] 'exit-minibuffer) + (define-key map [(control ?j)] 'exit-minibuffer) + (define-key map [(meta control ?m)] 'exit-minibuffer) + map)) + +(define-obsolete-function-alias 'eshell-return-exits-minibuffer + #'eshell-command-mode "28.1") (defvar eshell-non-interactive-p nil "A variable which is non-nil when Eshell is not running interactively. @@ -292,7 +296,7 @@ With prefix ARG, insert output into the current buffer at point." ;; Enable `eshell-mode' only in this minibuffer. (minibuffer-with-setup-hook #'(lambda () (eshell-mode) - (eshell-return-exits-minibuffer)) + (eshell-command-mode +1)) (unless command (setq command (read-from-minibuffer "Emacs shell command: ")) (if (eshell-using-module 'eshell-hist) 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/facemenu.el b/lisp/facemenu.el index b10d874b21b..419b76101b5 100644 --- a/lisp/facemenu.el +++ b/lisp/facemenu.el @@ -621,12 +621,11 @@ color. The function should accept a single argument, the color name." (downcase b)))))) (setq color (list color))) (let* ((opoint (point)) - (color-values (color-values (car color))) - (light-p (>= (apply 'max color-values) - (* (car (color-values "white")) .5)))) + (fg (readable-foreground-color (car color)))) (insert (car color)) (indent-to 22) - (put-text-property opoint (point) 'face `(:background ,(car color))) + (put-text-property opoint (point) 'face `(:background ,(car color) + :foreground ,fg)) (put-text-property (prog1 (point) (insert " ") @@ -639,7 +638,7 @@ color. The function should accept a single argument, the color name." (insert (propertize (apply 'format "#%02x%02x%02x" (mapcar (lambda (c) (ash c -8)) - color-values)) + (color-values (car color)))) 'mouse-face 'highlight 'help-echo (let ((hsv (apply 'color-rgb-to-hsv @@ -651,7 +650,7 @@ color. The function should accept a single argument, the color name." opoint (point) 'follow-link t 'mouse-face (list :background (car color) - :foreground (if light-p "black" "white")) + :foreground fg) 'color-name (car color) 'action callback-fn))) (insert "\n")) diff --git a/lisp/faces.el b/lisp/faces.el index 4d1d9561d49..ba85973bf10 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -1560,7 +1560,7 @@ is given, in which case return its value instead." ;; return it to the caller. Since there will most definitely be something to ;; return in this case, there's no need to know/check if a match was found. (if defaults - (append result defaults) + (append defaults result) (if match-found result no-match-retval)))) @@ -1785,16 +1785,42 @@ with the color they represent as background color." (defined-colors frame))) (defun readable-foreground-color (color) - "Return a readable foreground color for background COLOR." - (let* ((rgb (color-values color)) - (max (apply #'max rgb)) - (black (car (color-values "black"))) - (white (car (color-values "white")))) - ;; Select black or white depending on which one is less similar to - ;; the brightest component. - (if (> (abs (- max black)) (abs (- max white))) - "black" - "white"))) + "Return a readable foreground color for background COLOR. +The returned value is a string representing black or white, depending +on which one provides better contrast with COLOR." + ;; We use #ffffff instead of "white", because the latter is sometimes + ;; less than white. That way, we get the best contrast possible. + (if (color-dark-p (mapcar (lambda (c) (/ c 65535.0)) + (color-values color))) + "#ffffff" "black")) + +(defconst color-luminance-dark-limit 0.325 + "The relative luminance below which a color is considered 'dark'. +A 'dark' color in this sense provides better contrast with white +than with black; see `color-dark-p'. +This value was determined experimentally.") + +(defun color-dark-p (rgb) + "Whether RGB is more readable against white than black. +RGB is a 3-element list (R G B), each component in the range [0,1]. +This predicate can be used both for determining a suitable (black or white) +contrast colour with RGB as background and as foreground." + (unless (<= 0 (apply #'min rgb) (apply #'max rgb) 1) + (error "RGB components %S not in [0,1]" rgb)) + ;; Compute the relative luminance after gamma-correcting (assuming sRGB), + ;; and compare to a cut-off value determined experimentally. + ;; See https://en.wikipedia.org/wiki/Relative_luminance for details. + (let* ((sr (nth 0 rgb)) + (sg (nth 1 rgb)) + (sb (nth 2 rgb)) + ;; Gamma-correct the RGB components to linear values. + ;; Use the power 2.2 as an approximation to sRGB gamma; + ;; it should be good enough for the purpose of this function. + (r (expt sr 2.2)) + (g (expt sg 2.2)) + (b (expt sb 2.2)) + (y (+ (* r 0.2126) (* g 0.7152) (* b 0.0722)))) + (< y color-luminance-dark-limit))) (declare-function xw-color-defined-p "xfns.c" (color &optional frame)) @@ -1822,7 +1848,7 @@ COLOR should be a string naming a color (e.g. \"white\"), or a string specifying a color's RGB components (e.g. \"#ff12ec\"). Return a list of three integers, (RED GREEN BLUE), each between 0 -and either 65280 or 65535 (the maximum depends on the system). +and 65535 inclusive. Use `color-name-to-rgb' if you want RGB floating-point values normalized to 1.0. diff --git a/lisp/ffap.el b/lisp/ffap.el index 66ef0824d8a..ceba9d26223 100644 --- a/lisp/ffap.el +++ b/lisp/ffap.el @@ -54,6 +54,8 @@ ;; C-x 5 r ffap-read-only-other-frame ;; C-x 5 d ffap-dired-other-frame ;; +;; C-x t f ffap-other-tab +;; ;; S-mouse-3 ffap-at-mouse ;; C-S-mouse-3 ffap-menu ;; @@ -1080,7 +1082,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: @@ -1607,7 +1609,7 @@ Each ALIST entry looks like (STRING . DATA) and defines one choice. Function CONT is applied to the entry chosen by the user." ;; Note: this function is used with a different continuation ;; by the ffap-url add-on package. - ;; Could try rewriting to use easymenu.el or lmenu.el. + ;; Could try rewriting to use easymenu.el. (let (choice) (cond ;; Emacs mouse: @@ -1758,6 +1760,14 @@ Only intended for interactive use." (set-window-dedicated-p win wdp)) value)) +(defun ffap-other-tab (filename) + "Like `ffap', but put buffer in another tab. +Only intended for interactive use." + (interactive (list (ffap-prompter nil " other tab"))) + (pcase (save-window-excursion (find-file-at-point filename)) + ((or (and (pred bufferp) b) `(,(and (pred bufferp) b) . ,_)) + (switch-to-buffer-other-tab b)))) + (defun ffap--toggle-read-only (buffer-or-list) (dolist (buffer (if (listp buffer-or-list) buffer-or-list @@ -2013,6 +2023,7 @@ This hook is intended to be put in `file-name-at-point-functions'." (global-set-key [remap find-file-other-window] 'ffap-other-window) (global-set-key [remap find-file-other-frame] 'ffap-other-frame) + (global-set-key [remap find-file-other-tab] 'ffap-other-tab) (global-set-key [remap find-file-read-only-other-window] 'ffap-read-only-other-window) (global-set-key [remap find-file-read-only-other-frame] 'ffap-read-only-other-frame) diff --git a/lisp/fileloop.el b/lisp/fileloop.el index 833bb0401cb..d52e35d886f 100644 --- a/lisp/fileloop.el +++ b/lisp/fileloop.el @@ -201,30 +201,34 @@ operating on the next file and nil otherwise." ;;;###autoload (defun fileloop-initialize-replace (from to files case-fold &optional delimited) "Initialize a new round of query&replace on several files. - FROM is a regexp and TO is the replacement to use. - FILES describes the files, as in `fileloop-initialize'. - CASE-FOLD can be t, nil, or `default': - if it is nil, matching of FROM is case-sensitive. - if it is t, matching of FROM is case-insensitive, except - when `search-upper-case' is non-nil and FROM includes - upper-case letters. - if it is `default', the function uses the value of - `case-fold-search' instead. - DELIMITED if non-nil means replace only word-delimited matches." +FROM is a regexp and TO is the replacement to use. +FILES describes the files, as in `fileloop-initialize'. +CASE-FOLD can be t, nil, or `default': + if it is nil, matching of FROM is case-sensitive. + if it is t, matching of FROM is case-insensitive, except + when `search-upper-case' is non-nil and FROM includes + upper-case letters. + if it is `default', the function uses the value of + `case-fold-search' instead. +DELIMITED if non-nil means replace only word-delimited matches." ;; FIXME: Not sure how the delimited-flag interacts with the regexp-flag in ;; `perform-replace', so I just try to mimic the old code. - (fileloop-initialize - files - (lambda () - (let ((case-fold-search (fileloop--case-fold from case-fold))) - (if (re-search-forward from nil t) - ;; When we find a match, move back - ;; to the beginning of it so perform-replace - ;; will see it. - (goto-char (match-beginning 0))))) - (lambda () - (let ((case-fold-search (fileloop--case-fold from case-fold))) - (perform-replace from to t t delimited nil multi-query-replace-map))))) + (let ((mstart (make-hash-table :test 'eq))) + (fileloop-initialize + files + (lambda () + (let ((case-fold-search (fileloop--case-fold from case-fold))) + (when (re-search-forward from nil t) + ;; When we find a match, save its beginning for + ;; `perform-replace' (we used to just set point, but this + ;; is unreliable in the face of + ;; `switch-to-buffer-preserve-window-point'). + (puthash (current-buffer) (match-beginning 0) mstart)))) + (lambda () + (let ((case-fold-search (fileloop--case-fold from case-fold))) + (perform-replace from to t t delimited nil multi-query-replace-map + (gethash (current-buffer) mstart (point-min)) + (point-max))))))) (provide 'fileloop) ;;; fileloop.el ends here diff --git a/lisp/files.el b/lisp/files.el index 3e4ad7c0d44..9270f334afa 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") @@ -430,7 +430,13 @@ idle for `auto-save-visited-interval' seconds." Unlike `auto-save-mode', this mode will auto-save buffer contents to the visited files directly and will also run all save-related -hooks. See Info node `Saving' for details of the save process." +hooks. See Info node `Saving' for details of the save process. + +You can also set the buffer-local value of the variable +`auto-save-visited-mode' to nil. A buffer where the buffer-local +value of this variable is nil is ignored for the purpose of +`auto-save-visited-mode', even if `auto-save-visited-mode' is +enabled." :group 'auto-save :global t (when auto-save--timer (cancel-timer auto-save--timer)) @@ -441,6 +447,7 @@ hooks. See Info node `Saving' for details of the save process." #'save-some-buffers :no-prompt (lambda () (and buffer-file-name + auto-save-visited-mode (not (and buffer-auto-save-file-name auto-save-visited-file-name)))))))) @@ -745,10 +752,16 @@ resulting list of directory names. For an empty path element (i.e., a leading or trailing separator, or two adjacent separators), return nil (meaning `default-directory') as the associated list element." (when (stringp search-path) - (mapcar (lambda (f) - (if (equal "" f) nil - (substitute-in-file-name (file-name-as-directory f)))) - (split-string search-path path-separator)))) + (let ((spath (substitute-env-vars search-path))) + (mapcar (lambda (f) + (if (equal "" f) nil + (let ((dir (expand-file-name (file-name-as-directory f)))) + ;; Previous implementation used `substitute-in-file-name' + ;; which collapse multiple "/" in front. Do the same for + ;; backward compatibility. + (if (string-match "\\`/+" dir) + (substring dir (1- (match-end 0))) dir)))) + (split-string spath path-separator))))) (defun cd-absolute (dir) "Change current directory to given absolute file name DIR." @@ -1094,6 +1107,8 @@ REMOTE is non-nil, search on the remote host indicated by (let ((default-directory (file-name-quote default-directory 'top))) (locate-file command exec-path exec-suffixes 1)))) +(declare-function read-library-name "find-func" nil) + (defun load-library (library) "Load the Emacs Lisp library named LIBRARY. LIBRARY should be a string. @@ -1103,12 +1118,7 @@ well as `load-file-rep-suffixes'). See Info node `(emacs)Lisp Libraries' for more details. See `load-file' for a different interface to `load'." - (interactive - (let (completion-ignored-extensions) - (list (completing-read "Load library: " - (apply-partially 'locate-file-completion-table - load-path - (get-load-suffixes)))))) + (interactive (list (read-library-name))) (load library)) (defun file-remote-p (file &optional identification connected) @@ -1917,6 +1927,8 @@ killed." (setq buffer-file-truename otrue) (setq dired-directory odir) (lock-buffer) + (if (get-buffer oname) + (kill-buffer oname)) (rename-buffer oname))) (unless (eq (current-buffer) obuf) (with-current-buffer obuf @@ -2660,6 +2672,13 @@ since only a single case-insensitive search through the alist is made." ("\\.ltx\\'" . latex-mode) ("\\.dtx\\'" . doctex-mode) ("\\.org\\'" . org-mode) + ;; .dir-locals.el is not really Elisp. Could use the + ;; `dir-locals-file' constant if it weren't defined below. + ("\\.dir-locals\\(?:-2\\)?\\.el\\'" . lisp-data-mode) + ("eww-bookmarks\\'" . lisp-data-mode) + ("tramp\\'" . lisp-data-mode) + ("places\\'" . lisp-data-mode) + ("\\.emacs-places\\'" . lisp-data-mode) ("\\.el\\'" . emacs-lisp-mode) ("Project\\.ede\\'" . emacs-lisp-mode) ("\\.\\(scm\\|stk\\|ss\\|sch\\)\\'" . scheme-mode) @@ -2670,8 +2689,6 @@ since only a single case-insensitive search through the alist is made." ("\\.p\\'" . pascal-mode) ("\\.pas\\'" . pascal-mode) ("\\.\\(dpr\\|DPR\\)\\'" . delphi-mode) - ("\\.ad[abs]\\'" . ada-mode) - ("\\.ad[bs]\\.dg\\'" . ada-mode) ("\\.\\([pP]\\([Llm]\\|erl\\|od\\)\\|al\\)\\'" . perl-mode) ("Imakefile\\'" . makefile-imake-mode) ("Makeppfile\\(?:\\.mk\\)?\\'" . makefile-makepp-mode) ; Put this before .mk @@ -4674,6 +4691,7 @@ BACKUPNAME is the backup file name, which is the old file renamed." ;; Create temp files with strict access rights. It's easy to ;; loosen them later, whereas it's impossible to close the ;; time-window of loose permissions otherwise. + (let (nofollow-flag) (with-file-modes ?\700 (when (condition-case nil ;; Try to overwrite old backup first. @@ -4684,6 +4702,7 @@ BACKUPNAME is the backup file name, which is the old file renamed." (when (file-exists-p to-name) (delete-file to-name)) (copy-file from-name to-name nil t t) + (setq nofollow-flag 'nofollow) nil) (file-already-exists t)) ;; The file was somehow created by someone else between @@ -4696,7 +4715,7 @@ BACKUPNAME is the backup file name, which is the old file renamed." (with-demoted-errors (set-file-extended-attributes to-name extended-attributes))) (and modes - (set-file-modes to-name (logand modes #o1777))))) + (set-file-modes to-name (logand modes #o1777) nofollow-flag))))) (defvar file-name-version-regexp "\\(?:~\\|\\.~[-[:alnum:]:#@^._]+\\(?:~[[:digit:]]+\\)?~\\)" @@ -5755,7 +5774,10 @@ If called interactively, then PARENTS is non-nil." (defconst directory-files-no-dot-files-regexp "[^.]\\|\\.\\.\\." - "Regexp matching any file name except \".\" and \"..\".") + "Regexp matching any file name except \".\" and \"..\". +More precisely, it matches parts of any nonempty string except those two. +It is useful as the regexp argument to `directory-files' and +`directory-files-and-attributes'.") (defun files--force (no-such fn &rest args) "Use NO-SUCH to affect behavior of function FN applied to list ARGS. @@ -5902,7 +5924,8 @@ into NEWNAME instead." ;; If default-directory is a remote directory, make sure we find its ;; copy-directory handler. (let ((handler (or (find-file-name-handler directory 'copy-directory) - (find-file-name-handler newname 'copy-directory)))) + (find-file-name-handler newname 'copy-directory))) + (follow parents)) (if handler (funcall handler 'copy-directory directory newname keep-time parents copy-contents) @@ -5922,7 +5945,8 @@ into NEWNAME instead." (or parents (not (file-directory-p newname))) (setq newname (concat newname (file-name-nondirectory directory)))) - (make-directory (directory-file-name newname) parents))) + (make-directory (directory-file-name newname) parents)) + (t (setq follow t))) ;; Copy recursively. (dolist (file @@ -5942,9 +5966,10 @@ into NEWNAME instead." ;; Set directory attributes. (let ((modes (file-modes directory)) (times (and keep-time (file-attribute-modification-time - (file-attributes directory))))) - (if modes (set-file-modes newname modes)) - (if times (set-file-times newname times)))))) + (file-attributes directory)))) + (follow-flag (unless follow 'nofollow))) + (if modes (set-file-modes newname modes follow-flag)) + (if times (set-file-times newname times follow-flag)))))) ;; At time of writing, only info uses this. @@ -7250,10 +7275,15 @@ if any returns nil. If `confirm-kill-emacs' is non-nil, calls it." (setq active t)) (setq processes (cdr processes))) (or (not active) - (with-displayed-buffer-window + (with-current-buffer-window (get-buffer-create "*Process List*") - '(display-buffer--maybe-at-bottom - (dedicated . t)) + `(display-buffer--maybe-at-bottom + (dedicated . t) + (window-height . fit-window-to-buffer) + (preserve-size . (nil . t)) + (body-function + . ,#'(lambda (_window) + (list-processes t)))) #'(lambda (window _value) (with-selected-window window (unwind-protect @@ -7261,8 +7291,7 @@ if any returns nil. If `confirm-kill-emacs' is non-nil, calls it." (setq confirm nil) (yes-or-no-p "Active processes exist; kill them and exit anyway? ")) (when (window-live-p window) - (quit-restore-window window 'kill))))) - (list-processes t))))) + (quit-restore-window window 'kill))))))))) ;; Query the user for other things, perhaps. (run-hook-with-args-until-failure 'kill-emacs-query-functions) (or (null confirm) @@ -7536,6 +7565,27 @@ as in \"og+rX-w\"." op char-right))) num-rights)) +(defun file-modes-number-to-symbolic (mode) + (string + (if (zerop (logand 8192 mode)) + (if (zerop (logand 16384 mode)) ?- ?d) + ?c) ; completeness + (if (zerop (logand 256 mode)) ?- ?r) + (if (zerop (logand 128 mode)) ?- ?w) + (if (zerop (logand 64 mode)) + (if (zerop (logand 2048 mode)) ?- ?S) + (if (zerop (logand 2048 mode)) ?x ?s)) + (if (zerop (logand 32 mode)) ?- ?r) + (if (zerop (logand 16 mode)) ?- ?w) + (if (zerop (logand 8 mode)) + (if (zerop (logand 1024 mode)) ?- ?S) + (if (zerop (logand 1024 mode)) ?x ?s)) + (if (zerop (logand 4 mode)) ?- ?r) + (if (zerop (logand 2 mode)) ?- ?w) + (if (zerop (logand 512 mode)) + (if (zerop (logand 1 mode)) ?- ?x) + (if (zerop (logand 1 mode)) ?T ?t)))) + (defun file-modes-symbolic-to-number (modes &optional from) "Convert symbolic file modes to numeric file modes. MODES is the string to convert, it should match 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 71f8ac740ee..820d6d0a3b9 100644 --- a/lisp/finder.el +++ b/lisp/finder.el @@ -197,7 +197,7 @@ from; the default is `load-path'." (cons d f)) (directory-files d nil el-file-regexp)))) (progress (make-progress-reporter - (byte-compile-info-string "Scanning files for finder") + (byte-compile-info "Scanning files for finder") 0 (length files))) package-override base-name ; processed summary keywords package version entry desc) @@ -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/font-lock.el b/lisp/font-lock.el index 506c888ff64..c633877e640 100644 --- a/lisp/font-lock.el +++ b/lisp/font-lock.el @@ -51,7 +51,7 @@ ;; also the variable `font-lock-maximum-size'. Support modes for Font Lock ;; mode can be used to speed up Font Lock mode. See `font-lock-support-mode'. -;;; How Font Lock mode fontifies: +;;;; How Font Lock mode fontifies: ;; When Font Lock mode is turned on in a buffer, it (a) fontifies the entire ;; buffer and (b) installs one of its fontification functions on one of the @@ -96,7 +96,7 @@ ;; some syntactic parsers for common languages and a son-of-font-lock.el could ;; use them rather then relying so heavily on the keyword (regexp) pass. -;;; How Font Lock mode supports modes or is supported by modes: +;;;; How Font Lock mode supports modes or is supported by modes: ;; Modes that support Font Lock mode do so by defining one or more variables ;; whose values specify the fontification. Font Lock mode knows of these @@ -112,7 +112,7 @@ ;; Font Lock mode fontification behavior can be modified in a number of ways. ;; See the below comments and the comments distributed throughout this file. -;;; Constructing patterns: +;;;; Constructing patterns: ;; See the documentation for the variable `font-lock-keywords'. ;; @@ -120,7 +120,7 @@ ;; `font-lock-syntactic-keywords' can be generated via the function ;; `regexp-opt'. -;;; Adding patterns for modes that already support Font Lock: +;;;; Adding patterns for modes that already support Font Lock: ;; Though Font Lock highlighting patterns already exist for many modes, it's ;; likely there's something that you want fontified that currently isn't, even @@ -135,7 +135,7 @@ ;; other variables. For example, additional C types can be specified via the ;; variable `c-font-lock-extra-types'. -;;; Adding patterns for modes that do not support Font Lock: +;;;; Adding patterns for modes that do not support Font Lock: ;; Not all modes support Font Lock mode. If you (as a user of the mode) add ;; patterns for a new mode, you must define in your ~/.emacs a variable or @@ -155,7 +155,7 @@ ;; (set (make-local-variable 'font-lock-defaults) ;; '(foo-font-lock-keywords t)))) -;;; Adding Font Lock support for modes: +;;;; Adding Font Lock support for modes: ;; Of course, it would be better that the mode already supports Font Lock mode. ;; The package author would do something similar to above. The mode must @@ -575,6 +575,7 @@ This is normally set via `font-lock-defaults'.") "Non-nil means use this syntax table for fontifying. If this is nil, the major mode's syntax table is used. This is normally set via `font-lock-defaults'.") +(defvar-local font-lock--syntax-table-affects-ppss nil) (defvar font-lock-mark-block-function nil "Non-nil means use this function to mark a block of text. @@ -985,7 +986,7 @@ The value of this variable is used when Font Lock mode is turned on." ((bound-and-true-p lazy-lock-mode) (lazy-lock-after-unfontify-buffer)))) -;;; End of Font Lock Support mode. +;; End of Font Lock Support mode. ;;; Fontification functions. @@ -1120,9 +1121,10 @@ locking for a mode, and is not meant to be called from lisp functions." "Make sure the region BEG...END has been fontified. If the region is not specified, it defaults to the entire accessible portion of the buffer." - (font-lock-set-defaults) - (funcall font-lock-ensure-function - (or beg (point-min)) (or end (point-max)))) + (when (font-lock-specified-p t) + (font-lock-set-defaults) + (funcall font-lock-ensure-function + (or beg (point-min)) (or end (point-max))))) (defun font-lock-default-fontify-buffer () "Fontify the whole buffer using `font-lock-fontify-region-function'." @@ -1391,7 +1393,7 @@ delimit the region to fontify." (font-lock-fontify-region (point) (mark))) ((error quit) (message "Fontifying block...%s" error-data))))))) -;;; End of Fontification functions. +;; End of Fontification functions. ;;; Additional text property functions. @@ -1483,7 +1485,7 @@ Optional argument OBJECT is the string or buffer containing the text." (put-text-property start next prop new object)))))) (setq start (text-property-not-all next end prop nil object))))) -;;; End of Additional text property functions. +;; End of Additional text property functions. ;;; Syntactic regexp fontification functions. @@ -1589,7 +1591,7 @@ START should be at the beginning of a line." (setq highlights (cdr highlights)))) (setq keywords (cdr keywords))))) -;;; End of Syntactic regexp fontification functions. +;; End of Syntactic regexp fontification functions. ;;; Syntactic fontification functions. @@ -1609,7 +1611,15 @@ START should be at the beginning of a line." (regexp-quote (replace-regexp-in-string "^ *" "" comment-end)))) ;; Find the `start' state. - (state (syntax-ppss start)) + (state (if (or syntax-ppss-table + (not font-lock--syntax-table-affects-ppss)) + (syntax-ppss start) + ;; If `syntax-ppss' doesn't have its own syntax-table and + ;; we have installed our own syntax-table which + ;; differs from the standard one in ways which affects PPSS, + ;; then we can't use `syntax-ppss' since that would pollute + ;; and be polluted by its cache. + (parse-partial-sexp (point-min) start))) face beg) (if loudly (message "Fontifying %s... (syntactically...)" (buffer-name))) ;; @@ -1640,7 +1650,7 @@ START should be at the beginning of a line." (setq state (parse-partial-sexp (point) end nil nil state 'syntax-table)))))) -;;; End of Syntactic fontification functions. +;; End of Syntactic fontification functions. ;;; Keyword regexp fontification functions. @@ -1774,9 +1784,9 @@ LOUDLY, if non-nil, allows progress-meter bar." (setq keywords (cdr keywords))) (set-marker pos nil))) -;;; End of Keyword regexp fontification functions. +;; End of Keyword regexp fontification functions. -;; Various functions. +;;; Various functions. (defun font-lock-compile-keywords (keywords &optional syntactic-keywords) "Compile KEYWORDS into the form (t KEYWORDS COMPILED...) @@ -1906,6 +1916,7 @@ Sets various variables using `font-lock-defaults' and ;; Case fold during regexp fontification? (setq-local font-lock-keywords-case-fold-search (nth 2 defaults)) ;; Syntax table for regexp and syntactic fontification? + (kill-local-variable 'font-lock--syntax-table-affects-ppss) (if (null (nth 3 defaults)) (setq-local font-lock-syntax-table nil) (setq-local font-lock-syntax-table (copy-syntax-table (syntax-table))) @@ -1915,7 +1926,14 @@ Sets various variables using `font-lock-defaults' and (dolist (char (if (numberp (car selem)) (list (car selem)) (mapcar #'identity (car selem)))) - (modify-syntax-entry char syntax font-lock-syntax-table))))) + (unless (memq (car (aref font-lock-syntax-table char)) + '(1 2 3)) ;"." "w" "_" + (setq font-lock--syntax-table-affects-ppss t)) + (modify-syntax-entry char syntax font-lock-syntax-table) + (unless (memq (car (aref font-lock-syntax-table char)) + '(1 2 3)) ;"." "w" "_" + (setq font-lock--syntax-table-affects-ppss t)) + )))) ;; (nth 4 defaults) used to hold `font-lock-beginning-of-syntax-function', ;; but that was removed in 25.1, so if it's a cons cell, we assume that ;; it's part of the variable alist. @@ -2084,7 +2102,7 @@ Sets various variables using `font-lock-defaults' and "Font Lock mode face used to highlight grouping constructs in Lisp regexps." :group 'font-lock-faces) -;;; End of Color etc. support. +;; End of Color etc. support. ;;; Menu support. @@ -2186,7 +2204,7 @@ Sets various variables using `font-lock-defaults' and ;; ;; Deactivate less/more fontification entries. ;; (setq font-lock-fontify-level nil)) -;;; End of Menu support. +;; End of Menu support. ;;; Various regexp information shared by several modes. ;; ;; Information specific to a single mode should go in its load library. diff --git a/lisp/format-spec.el b/lisp/format-spec.el index 9278bd74c42..6af79a44167 100644 --- a/lisp/format-spec.el +++ b/lisp/format-spec.el @@ -1,4 +1,4 @@ -;;; format-spec.el --- functions for formatting arbitrary formatting strings +;;; format-spec.el --- format arbitrary formatting strings -*- lexical-binding: t -*- ;; Copyright (C) 1999-2020 Free Software Foundation, Inc. @@ -24,10 +24,8 @@ ;;; Code: -(eval-when-compile - (require 'subr-x)) - -(defun format-spec (format specification &optional only-present) +;;;###autoload +(defun format-spec (format specification &optional ignore-missing) "Return a string based on FORMAT and SPECIFICATION. FORMAT is a string containing `format'-like specs like \"su - %u %k\". SPECIFICATION is an alist mapping format specification characters @@ -39,22 +37,22 @@ For instance: \\=`((?u . ,(user-login-name)) (?l . \"ls\"))) -Each %-spec may contain optional flag and width modifiers, as -follows: +Each %-spec may contain optional flag, width, and precision +modifiers, as follows: - %<flags><width>character + %<flags><width><precision>character The following flags are allowed: * 0: Pad to the width, if given, with zeros instead of spaces. * -: Pad to the width, if given, on the right instead of the left. -* <: Truncate to the width, if given, on the left. -* >: Truncate to the width, if given, on the right. +* <: Truncate to the width and precision, if given, on the left. +* >: Truncate to the width and precision, if given, on the right. * ^: Convert to upper case. * _: Convert to lower case. -The width modifier behaves like the corresponding one in `format' -when applied to %s. +The width and truncation modifiers behave like the corresponding +ones in `format' when applied to %s. For example, \"%<010b\" means \"substitute into the output the value associated with ?b in SPECIFICATION, either padding it with @@ -64,89 +62,108 @@ characters wide\". Any text properties of FORMAT are copied to the result, with any text properties of a %-spec itself copied to its substitution. -ONLY-PRESENT indicates how to handle %-spec characters not +IGNORE-MISSING indicates how to handle %-spec characters not present in SPECIFICATION. If it is nil or omitted, emit an -error; otherwise leave those %-specs and any occurrences of -\"%%\" in FORMAT verbatim in the result, including their text -properties, if any." +error; if it is the symbol `ignore', leave those %-specs verbatim +in the result, including their text properties, if any; if it is +the symbol `delete', remove those %-specs from the result; +otherwise do the same as for the symbol `ignore', but also leave +any occurrences of \"%%\" in FORMAT verbatim in the result." (with-temp-buffer (insert format) (goto-char (point-min)) (while (search-forward "%" nil t) (cond - ;; Quoted percent sign. - ((eq (char-after) ?%) - (unless only-present - (delete-char 1))) - ;; Valid format spec. - ((looking-at "\\([-0 _^<>]*\\)\\([0-9.]*\\)\\([a-zA-Z]\\)") - (let* ((modifiers (match-string 1)) - (num (match-string 2)) - (spec (string-to-char (match-string 3))) - (val (assq spec specification))) - (if (not val) - (unless only-present - (error "Invalid format character: `%%%c'" spec)) - (setq val (cdr val) - modifiers (format-spec--parse-modifiers modifiers)) - ;; Pad result to desired length. - (let ((text (format "%s" val))) - (when num - (setq num (string-to-number num)) - (setq text (format-spec--pad text num modifiers)) - (when (> (length text) num) - (cond - ((memq :chop-left modifiers) - (setq text (substring text (- (length text) num)))) - ((memq :chop-right modifiers) - (setq text (substring text 0 num)))))) - (when (memq :uppercase modifiers) - (setq text (upcase text))) - (when (memq :lowercase modifiers) - (setq text (downcase text))) - ;; Insert first, to preserve text properties. - (insert-and-inherit text) - ;; Delete the specifier body. - (delete-region (+ (match-beginning 0) (length text)) - (+ (match-end 0) (length text))) - ;; Delete the percent sign. - (delete-region (1- (match-beginning 0)) (match-beginning 0)))))) - ;; Signal an error on bogus format strings. - (t - (unless only-present - (error "Invalid format string"))))) + ;; Quoted percent sign. + ((= (following-char) ?%) + (when (memq ignore-missing '(nil ignore delete)) + (delete-char 1))) + ;; Valid format spec. + ((looking-at (rx (? (group (+ (in " 0<>^_-")))) + (? (group (+ digit))) + (? (group ?. (+ digit))) + (group alpha))) + (let* ((beg (point)) + (end (match-end 0)) + (flags (match-string 1)) + (width (match-string 2)) + (trunc (match-string 3)) + (char (string-to-char (match-string 4))) + (text (assq char specification))) + (cond (text + ;; Handle flags. + (setq text (format-spec--do-flags + (format "%s" (cdr text)) + (format-spec--parse-flags flags) + (and width (string-to-number width)) + (and trunc (car (read-from-string trunc 1))))) + ;; Insert first, to preserve text properties. + (insert-and-inherit text) + ;; Delete the specifier body. + (delete-region (point) (+ end (length text))) + ;; Delete the percent sign. + (delete-region (1- beg) beg)) + ((eq ignore-missing 'delete) + ;; Delete the whole format spec. + (delete-region (1- beg) end)) + ((not ignore-missing) + (error "Invalid format character: `%%%c'" char))))) + ;; Signal an error on bogus format strings. + ((not ignore-missing) + (error "Invalid format string")))) (buffer-string))) -(defun format-spec--pad (text total-length modifiers) - (if (> (length text) total-length) - ;; The text is longer than the specified length; do nothing. - text - (let ((padding (make-string (- total-length (length text)) - (if (memq :zero-pad modifiers) - ?0 - ?\s)))) - (if (memq :right-pad modifiers) - (concat text padding) - (concat padding text))))) - -(defun format-spec--parse-modifiers (modifiers) +(defun format-spec--do-flags (str flags width trunc) + "Return STR formatted according to FLAGS, WIDTH, and TRUNC. +FLAGS is a list of keywords as returned by +`format-spec--parse-flags'. WIDTH and TRUNC are either nil or +string widths corresponding to `format-spec' modifiers." + (let (diff str-width) + ;; Truncate original string first, like `format' does. + (when trunc + (setq str-width (string-width str)) + (when (> (setq diff (- str-width trunc)) 0) + (setq str (if (memq :chop-left flags) + (truncate-string-to-width str str-width diff) + (format (format "%%.%ds" trunc) str)) + ;; We know the new width so save it for later. + str-width trunc))) + ;; Pad or chop to width. + (when width + (setq str-width (or str-width (string-width str)) + diff (- width str-width)) + (cond ((zerop diff)) + ((> diff 0) + (let ((pad (make-string diff (if (memq :pad-zero flags) ?0 ?\s)))) + (setq str (if (memq :pad-right flags) + (concat str pad) + (concat pad str))))) + ((memq :chop-left flags) + (setq str (truncate-string-to-width str str-width (- diff)))) + ((memq :chop-right flags) + (setq str (format (format "%%.%ds" width) str)))))) + ;; Fiddle case. + (cond ((memq :upcase flags) + (upcase str)) + ((memq :downcase flags) + (downcase str)) + (str))) + +(defun format-spec--parse-flags (flags) + "Convert sequence of FLAGS to list of human-readable keywords." (mapcan (lambda (char) - (when-let ((modifier - (pcase char - (?0 :zero-pad) - (?\s :space-pad) - (?^ :uppercase) - (?_ :lowercase) - (?- :right-pad) - (?< :chop-left) - (?> :chop-right)))) - (list modifier))) - modifiers)) + (pcase char + (?0 (list :pad-zero)) + (?- (list :pad-right)) + (?< (list :chop-left)) + (?> (list :chop-right)) + (?^ (list :upcase)) + (?_ (list :downcase)))) + flags)) (defun format-spec-make (&rest pairs) "Return an alist suitable for use in `format-spec' based on PAIRS. -PAIRS is a list where every other element is a character and a value, -starting with a character." +PAIRS is a property list with characters as keys." (let (alist) (while pairs (unless (cdr pairs) diff --git a/lisp/frame.el b/lisp/frame.el index 16ee7580f89..081d3010e9b 100644 --- a/lisp/frame.el +++ b/lisp/frame.el @@ -713,6 +713,18 @@ The optional argument PARAMETERS specifies additional frame parameters." (x-display-list)))) (make-frame (cons (cons 'display display) parameters))) +(defun make-frame-on-current-monitor (&optional parameters) + "Make a frame on the currently selected monitor. +Like `make-frame-on-monitor' and with the same PARAMETERS as in `make-frame'." + (interactive) + (let* ((monitor-workarea + (cdr (assq 'workarea (frame-monitor-attributes)))) + (geometry-parameters + (when monitor-workarea + `((top . ,(nth 1 monitor-workarea)) + (left . ,(nth 0 monitor-workarea)))))) + (make-frame (append geometry-parameters parameters)))) + (defun make-frame-on-monitor (monitor &optional display parameters) "Make a frame on monitor MONITOR. The optional argument DISPLAY can be a display name, and the optional @@ -1058,6 +1070,23 @@ that variable should be nil." (setq arg (1+ arg))) (select-frame-set-input-focus frame))) +(defun other-frame-prefix () + "Display the buffer of the next command in a new frame. +The next buffer is the buffer displayed by the next command invoked +immediately after this command (ignoring reading from the minibuffer). +Creates a new frame before displaying the buffer. +When `switch-to-buffer-obey-display-actions' is non-nil, +`switch-to-buffer' commands are also supported." + (interactive) + (display-buffer-override-next-command + (lambda (buffer alist) + (cons (display-buffer-pop-up-frame + buffer (append '((inhibit-same-window . t)) + alist)) + 'frame)) + nil "[other-frame]") + (message "Display next command buffer in a new frame...")) + (defun iconify-or-deiconify-frame () "Iconify the selected frame, or deiconify if it's currently an icon." (interactive) @@ -2676,11 +2705,7 @@ See also `toggle-frame-maximized'." (set-frame-parameter frame 'fullscreen fullscreen-restore) (set-frame-parameter frame 'fullscreen nil))) (modify-frame-parameters - frame `((fullscreen . fullboth) (fullscreen-restore . ,fullscreen)))) - ;; Manipulating a frame without waiting for the fullscreen - ;; animation to complete can cause a crash, or other unexpected - ;; behavior, on macOS (bug#28496). - (when (featurep 'cocoa) (sleep-for 0.5)))) + frame `((fullscreen . fullboth) (fullscreen-restore . ,fullscreen)))))) ;;;; Key bindings @@ -2689,6 +2714,7 @@ See also `toggle-frame-maximized'." (define-key ctl-x-5-map "1" 'delete-other-frames) (define-key ctl-x-5-map "0" 'delete-frame) (define-key ctl-x-5-map "o" 'other-frame) +(define-key ctl-x-5-map "5" 'other-frame-prefix) (define-key global-map [f11] 'toggle-frame-fullscreen) (define-key global-map [(meta f10)] 'toggle-frame-maximized) (define-key esc-map [f10] 'toggle-frame-maximized) diff --git a/lisp/frameset.el b/lisp/frameset.el index 10c6914f52d..0462d776c0e 100644 --- a/lisp/frameset.el +++ b/lisp/frameset.el @@ -396,17 +396,17 @@ Properties can be set with ;; or, if you're only changing a few items, ;; ;; (defvar my-filter-alist -;; (nconc '((my-param1 . :never) -;; (my-param2 . my-filtering-function)) -;; frameset-filter-alist) +;; (append '((my-param1 . :never) +;; (my-param2 . my-filtering-function)) +;; frameset-filter-alist) ;; "My brief customized parameter filter alist.") ;; ;; and pass it to the FILTER arg of the save/restore functions, ;; ALWAYS taking care of not modifying the original lists; if you're ;; going to do any modifying of my-filter-alist, please use ;; -;; (nconc '((my-param1 . :never) ...) -;; (copy-sequence frameset-filter-alist)) +;; (append '((my-param1 . :never) ...) +;; (copy-sequence frameset-filter-alist)) ;; ;; One thing you shouldn't forget is that they are alists, so searching ;; in them is sequential. If you just want to change the default of @@ -445,7 +445,7 @@ DO NOT MODIFY. See `frameset-filter-alist' for a full description.") ;;;###autoload (defvar frameset-persistent-filter-alist - (nconc + (append '((background-color . frameset-filter-sanitize-color) (buffer-list . :never) (buffer-predicate . :never) diff --git a/lisp/generic-x.el b/lisp/generic-x.el index cd24f497c96..48ac1232051 100644 --- a/lisp/generic-x.el +++ b/lisp/generic-x.el @@ -643,7 +643,7 @@ like an INI file. You can add this hook to `find-file-hook'." ("\\([^ =\n\r]+\\)=\\([^ \n\r]*\\)" (1 font-lock-variable-name-face) (2 font-lock-keyword-face))) - '("inventory") + '("inventory\\'") (list (function (lambda () diff --git a/lisp/gnus/deuglify.el b/lisp/gnus/deuglify.el index 82dbbab5e0d..647f643c962 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 @@ -403,9 +403,9 @@ NODISPLAY is non-nil, don't redisplay the article buffer." (gnus-with-article-buffer (article-goto-body) (when (re-search-forward - (concat "^[" cite-marks " \t]*--* ?[^-]+ [^-]+ ?--*\\s *\n" + (concat "^[" cite-marks " \t]*--*[^-]+ [^-]+--*\\s *\n" "[^\n:]+:[ \t]*\\([^\n]+\\)\n" - "\\([^\n:]+:[ \t]*[^\n]+\n\\)+") + "\\([^\n:]+:[^\n]+\n\\)+") nil t) (gnus-kill-all-overlays) (replace-match "\\1 wrote:\n") diff --git a/lisp/gnus/gmm-utils.el b/lisp/gnus/gmm-utils.el index 2df098bc0bf..6d24b409ed0 100644 --- a/lisp/gnus/gmm-utils.el +++ b/lisp/gnus/gmm-utils.el @@ -168,9 +168,9 @@ ARGS are passed to `message'." (defcustom gmm-tool-bar-style (if (and (boundp 'tool-bar-mode) tool-bar-mode - (memq (display-visual-class) - (list 'static-gray 'gray-scale - 'static-color 'pseudo-color))) + (not (memq (display-visual-class) + (list 'static-gray 'gray-scale + 'static-color 'pseudo-color)))) 'gnome 'retro) "Preferred tool bar style." diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el index cf705ae5dc1..88873f47bd5 100644 --- a/lisp/gnus/gnus-agent.el +++ b/lisp/gnus/gnus-agent.el @@ -603,11 +603,22 @@ manipulated as follows: (gnus)) ;;;###autoload +(defun gnus-child-unplugged (&optional arg) + "Read news as a child unplugged." + (interactive "P") + (setq gnus-plugged nil) + (gnus arg nil 'child)) + +;;;###autoload (defun gnus-slave-unplugged (&optional arg) - "Read news as a slave unplugged." + "Read news as a child unplugged." (interactive "P") (setq gnus-plugged nil) - (gnus arg nil 'slave)) + (gnus arg nil 'child)) +(make-obsolete 'gnus-slave-unplugged 'gnus-child-unplugged "28.1") + + + ;;;###autoload (defun gnus-agentize () @@ -799,7 +810,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-art.el b/lisp/gnus/gnus-art.el index 6b9610d3121..e0339cc1f32 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -2303,21 +2303,27 @@ long lines if and only if arg is positive." "\n") (put-text-property start (point) 'gnus-decoration 'header))))) -(defun article-fill-long-lines () - "Fill lines that are wider than the window width." - (interactive) +(defun article-fill-long-lines (&optional width) + "Fill lines that are wider than the window width or `fill-column'. +If WIDTH (interactively, the numeric prefix), use that as the +fill width." + (interactive "P") (save-excursion - (let ((inhibit-read-only t) - (width (window-width (get-buffer-window (current-buffer))))) + (let* ((inhibit-read-only t) + (window-width (window-width (get-buffer-window (current-buffer)))) + (width (if width + (prefix-numeric-value width) + (min fill-column window-width)))) (save-restriction (article-goto-body) (let ((adaptive-fill-mode nil)) ;Why? -sm (while (not (eobp)) (end-of-line) - (when (>= (current-column) (min fill-column width)) + (when (>= (current-column) width) (narrow-to-region (min (1+ (point)) (point-max)) (point-at-bol)) - (let ((goback (point-marker))) + (let ((goback (point-marker)) + (fill-column width)) (fill-paragraph nil) (goto-char (marker-position goback))) (widen)) @@ -4406,6 +4412,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is "e" gnus-article-read-summary-keys "\C-d" gnus-article-read-summary-keys + "\C-c\C-f" gnus-summary-mail-forward "\M-*" gnus-article-read-summary-keys "\M-#" gnus-article-read-summary-keys "\M-^" gnus-article-read-summary-keys @@ -5833,6 +5840,7 @@ all parts." "" "...")) (gnus-tmp-length (with-current-buffer (mm-handle-buffer handle) (buffer-size))) + (help-echo "mouse-2: toggle the MIME part; down-mouse-3: more options") gnus-tmp-type-long b e) (when (string-match ".*/" gnus-tmp-name) (setq gnus-tmp-name (replace-match "" t t gnus-tmp-name))) @@ -5841,6 +5849,19 @@ all parts." (concat "; " gnus-tmp-name)))) (unless (equal gnus-tmp-description "") (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long))) + (when (and (zerop gnus-tmp-length) + ;; Only nnimap supports partial fetches so far. + nnimap-fetch-partial-articles + (string-match "^nnimap\\+" gnus-newsgroup-name)) + (setq gnus-tmp-type-long + (concat + gnus-tmp-type-long + (substitute-command-keys + (concat "\\<gnus-summary-mode-map> (not downloaded, " + "\\[gnus-summary-show-complete-article] to fetch.)")))) + (setq help-echo + (concat "Type \\[gnus-summary-show-complete-article] " + "to download complete article. " help-echo))) (setq b (point)) (gnus-eval-format gnus-mime-button-line-format gnus-mime-button-line-format-alist @@ -5859,8 +5880,7 @@ all parts." 'keymap gnus-mime-button-map 'face gnus-article-button-face 'follow-link t - 'help-echo - "mouse-2: toggle the MIME part; down-mouse-3: more options"))) + 'help-echo help-echo))) (defvar gnus-displaying-mime nil) @@ -6001,6 +6021,7 @@ If nil, don't show those extra buttons." (defun gnus-mime-display-single (handle) (let ((type (mm-handle-media-type handle)) (ignored gnus-ignored-mime-types) + (mm-inline-font-lock (gnus-visual-p 'article-highlight 'highlight)) (not-attachment t) display text) (catch 'ignored @@ -6664,7 +6685,7 @@ not have a face in `gnus-article-boring-faces'." (interactive "P") (gnus-article-check-buffer) (let ((nosaves - '("q" "Q" "r" "\C-c\C-f" "m" "a" "f" "WDD" "WDW" + '("q" "Q" "r" "m" "a" "f" "WDD" "WDW" "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP" "=" "^" "\M-^" "|")) (nosave-but-article @@ -7708,6 +7729,15 @@ positives are possible." 0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-variable 1) ("M-x[ \t\n]+apropos-documentation[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET\\>" 0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-documentation 1) + ;; This is how URLs _should_ be embedded in text (RFC 1738, RFC 2396)... + ("<URL: *\\([^\n<>]*\\)>" + 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1) + ;; RFC 2396 (2.4.3., delims) ... + ("\"URL: *\\([^\n\"]*\\)\"" + 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1) + ;; Raw URLs. + (gnus-button-url-regexp + 0 (>= gnus-button-browse-level 0) browse-url-button-open-url 0) ;; The following entries may lead to many false positives so don't enable ;; them by default (use a high button level). ("/\\([a-z][-a-z0-9]+\\.el\\)\\>[^.?]" @@ -7731,15 +7761,6 @@ positives are possible." ;; Unlike the other regexps we really have to require quoting ;; here to determine where it ends. 1 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-key 3) - ;; This is how URLs _should_ be embedded in text (RFC 1738, RFC 2396)... - ("<URL: *\\([^\n<>]*\\)>" - 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1) - ;; RFC 2396 (2.4.3., delims) ... - ("\"URL: *\\([^\n\"]*\\)\"" - 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1) - ;; Raw URLs. - (gnus-button-url-regexp - 0 (>= gnus-button-browse-level 0) browse-url-button-open-url 0) ;; man pages ("\\b\\([a-z][a-z]+([1-9])\\)\\W" 0 (and (>= gnus-button-man-level 1) (< gnus-button-man-level 3)) @@ -8323,6 +8344,7 @@ url is put as the `gnus-button-url' overlay property on the button." (and (match-end 6) (list (string-to-number (match-string 6 address)))))))) (defun gnus-url-parse-query-string (query &optional downcase) + (declare (obsolete message-parse-mailto-url "28.1")) (let (retval pairs cur key val) (setq pairs (split-string query "&")) (while pairs @@ -8342,31 +8364,8 @@ url is put as the `gnus-button-url' overlay property on the button." (defun gnus-url-mailto (url) ;; Send mail to someone - (setq url (replace-regexp-in-string "\n" " " url)) - (when (string-match "mailto:/*\\(.*\\)" url) - (setq url (substring url (match-beginning 1) nil))) - (let* ((args (gnus-url-parse-query-string - (if (string-match "^\\?" url) - (substring url 1) - (if (string-match "^\\([^?]+\\)\\?\\(.*\\)" url) - (concat "to=" (match-string 1 url) "&" - (match-string 2 url)) - (concat "to=" url))))) - (subject (cdr-safe (assoc "subject" args))) - func) - (gnus-msg-mail) - (while args - (setq func (intern-soft (concat "message-goto-" (downcase (caar args))))) - (if (fboundp func) - (funcall func) - (message-position-on-field (caar args))) - (insert (replace-regexp-in-string - "\r\n" "\n" - (mapconcat #'identity (reverse (cdar args)) ", ") nil t)) - (setq args (cdr args))) - (if subject - (message-goto-body) - (message-goto-subject)))) + (gnus-msg-mail) + (message-mailto-1 url)) (defun gnus-button-embedded-url (address) "Activate ADDRESS with `browse-url'." 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..673a4d22988 100644 --- a/lisp/gnus/gnus-cloud.el +++ b/lisp/gnus/gnus-cloud.el @@ -223,13 +223,10 @@ easy interactive way to set this from the Server buffer." (t (gnus-message 1 "Unknown type %s; ignoring" type)))))) -(defun gnus-cloud-update-newsrc-data (group elem &optional force-older) - "Update the newsrc data for GROUP from ELEM. -Use old data if FORCE-OLDER is not nil." +(defun gnus-cloud-update-newsrc-data (group elem) + "Update the newsrc data for GROUP from ELEM." (let* ((contents (plist-get elem :contents)) (date (or (plist-get elem :timestamp) "0")) - (now (gnus-cloud-timestamp nil)) - (newer (string-lessp date now)) (group-info (gnus-get-info group))) (if (and contents (stringp (nth 0 contents)) @@ -238,15 +235,13 @@ Use old data if FORCE-OLDER is not nil." (if (equal (format "%S" group-info) (format "%S" contents)) (gnus-message 3 "Skipping cloud update of group %s, the info is the same" group) - (if (and newer (not force-older)) - (gnus-message 3 "Skipping outdated cloud info for group %s, the info is from %s (now is %s)" group date now) - (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))) + (when (or (not gnus-cloud-interactive) + (gnus-y-or-n-p + (format "%s has different info in the cloud from %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))) (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)))) @@ -285,8 +280,8 @@ Use old data if FORCE-OLDER is not nil." (insert new-contents) (when (file-exists-p file-name) (rename-file file-name (car (find-backup-file-name file-name)))) - (write-region (point-min) (point-max) file-name) - (set-file-times file-name (parse-iso8601-time-string date)))) + (write-region (point-min) (point-max) file-name nil nil nil 'excl) + (set-file-times file-name (parse-iso8601-time-string date) 'nofollow))) (defun gnus-cloud-file-covered-p (file-name) (let ((matched nil)) @@ -380,8 +375,9 @@ When FULL is t, upload everything, not just a difference from the last full." (gnus-cloud-files-to-upload full) (gnus-cloud-collect-full-newsrc))) (group (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method))) + (setq gnus-cloud-sequence (1+ (or gnus-cloud-sequence 0))) (insert (format "Subject: (sequence: %s type: %s storage-method: %s)\n" - (or gnus-cloud-sequence "UNKNOWN") + gnus-cloud-sequence (if full :full :partial) gnus-cloud-storage-method)) (insert "From: nobody@gnus.cloud.invalid\n") @@ -390,7 +386,6 @@ When FULL is t, upload everything, not just a difference from the last full." (if (gnus-request-accept-article gnus-cloud-group-name gnus-cloud-method t t) (progn - (setq gnus-cloud-sequence (1+ (or gnus-cloud-sequence 0))) (gnus-cloud-add-timestamps elems) (gnus-message 3 "Uploaded Gnus Cloud data successfully to %s" group) (gnus-group-refresh-group group)) @@ -459,18 +454,21 @@ instead of `gnus-cloud-sequence'. When UPDATE is t, returns the result of calling `gnus-cloud-update-all'. Otherwise, returns the Gnus Cloud data chunks." (let ((articles nil) + (highest-sequence-seen gnus-cloud-sequence) chunks) (dolist (header (gnus-cloud-available-chunks)) - (when (> (gnus-cloud-chunk-sequence (mail-header-subject header)) - (or sequence-override gnus-cloud-sequence -1)) - - (if (string-match (format "storage-method: %s" gnus-cloud-storage-method) - (mail-header-subject header)) - (push (mail-header-number header) articles) - (gnus-message 1 "Skipping article %s because it didn't match the Gnus Cloud method %s: %s" - (mail-header-number header) - gnus-cloud-storage-method - (mail-header-subject header))))) + (let ((this-sequence (gnus-cloud-chunk-sequence (mail-header-subject header)))) + (when (> this-sequence (or sequence-override gnus-cloud-sequence -1)) + + (if (string-match (format "storage-method: %s" gnus-cloud-storage-method) + (mail-header-subject header)) + (progn + (push (mail-header-number header) articles) + (setq highest-sequence-seen (max highest-sequence-seen this-sequence))) + (gnus-message 1 "Skipping article %s because it didn't match the Gnus Cloud method %s: %s" + (mail-header-number header) + gnus-cloud-storage-method + (mail-header-subject header)))))) (when articles (nnimap-request-articles (nreverse articles) gnus-cloud-group-name) (with-current-buffer nntp-server-buffer @@ -480,7 +478,8 @@ Otherwise, returns the Gnus Cloud data chunks." (push (gnus-cloud-parse-chunk) chunks) (forward-line 1)))) (if update - (mapcar #'gnus-cloud-update-all chunks) + (prog1 (mapcar #'gnus-cloud-update-all chunks) + (setq gnus-cloud-sequence highest-sequence-seen)) chunks))) (defun gnus-cloud-server-p (server) diff --git a/lisp/gnus/gnus-delay.el b/lisp/gnus/gnus-delay.el index 8dae4ef5c17..63e938e7453 100644 --- a/lisp/gnus/gnus-delay.el +++ b/lisp/gnus/gnus-delay.el @@ -75,7 +75,11 @@ DELAY is a string, giving the length of the time. Possible values are: variable `gnus-delay-default-hour', minute and second are zero. * hh:mm for a specific time. Use 24h format. If it is later than this - time, then the deadline is tomorrow, else today." + time, then the deadline is tomorrow, else today. + +The value of `message-draft-headers' determines which headers are +generated when the article is delayed. Remaining headers are +generated when the article is sent." (interactive (list (read-string "Target date (YYYY-MM-DD), time (hh:mm), or length of delay (units in [mhdwMY]): " 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-eform.el b/lisp/gnus/gnus-eform.el index 54118aad1e6..1bc1261ee8f 100644 --- a/lisp/gnus/gnus-eform.el +++ b/lisp/gnus/gnus-eform.el @@ -50,13 +50,13 @@ (defvar gnus-edit-form-buffer "*Gnus edit form*") (defvar gnus-edit-form-done-function nil) -(defvar gnus-edit-form-mode-map nil) -(unless gnus-edit-form-mode-map - (setq gnus-edit-form-mode-map (make-sparse-keymap)) - (set-keymap-parent gnus-edit-form-mode-map emacs-lisp-mode-map) - (gnus-define-keys gnus-edit-form-mode-map - "\C-c\C-c" gnus-edit-form-done - "\C-c\C-k" gnus-edit-form-exit)) +(defvar gnus-edit-form-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map emacs-lisp-mode-map) + (gnus-define-keys map + "\C-c\C-c" gnus-edit-form-done + "\C-c\C-k" gnus-edit-form-exit) + map)) (defun gnus-edit-form-make-menu-bar () (unless (boundp 'gnus-edit-form-menu) @@ -67,9 +67,9 @@ ["Exit" gnus-edit-form-exit t])) (gnus-run-hooks 'gnus-edit-form-menu-hook))) -(define-derived-mode gnus-edit-form-mode fundamental-mode "Edit Form" +(define-derived-mode gnus-edit-form-mode lisp-data-mode "Edit Form" "Major mode for editing forms. -It is a slightly enhanced emacs-lisp-mode. +It is a slightly enhanced `lisp-data-mode'. \\{gnus-edit-form-mode-map}" (when (gnus-visual-p 'group-menu 'menu) 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-gravatar.el b/lisp/gnus/gnus-gravatar.el index e2bd4ed860c..9c24de44cd6 100644 --- a/lisp/gnus/gnus-gravatar.el +++ b/lisp/gnus/gnus-gravatar.el @@ -109,14 +109,16 @@ callback for `gravatar-retrieve'." ;; If we're on the " quoting the name, go backward. (when (looking-at-p "[\"<]") (goto-char (1- (point)))) - ;; Do not do anything if there's already a gravatar. This can - ;; happen if the buffer has been regenerated in the mean time, for - ;; example we were fetching someaddress, and then we change to - ;; another mail with the same someaddress. - (unless (get-text-property (point) 'gnus-gravatar) + ;; Do not do anything if there's already a gravatar. + ;; This can happen if the buffer has been regenerated in + ;; the mean time, for example we were fetching + ;; someaddress, and then we change to another mail with + ;; the same someaddress. + (unless (get-text-property (1- (point)) 'gnus-gravatar) (let ((pos (point))) (setq gravatar (append gravatar gnus-gravatar-properties)) - (gnus-put-image gravatar (buffer-substring pos (1+ pos)) category) + (gnus-put-image gravatar (buffer-substring pos (1+ pos)) + category) (put-text-property pos (point) 'gnus-gravatar address) (gnus-add-wash-type category) (gnus-add-image category gravatar))))) diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index b89f040b435..97e10a37a21 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -1129,8 +1129,8 @@ The following commands are available: (gnus-update-group-mark-positions) (when gnus-use-undo (gnus-undo-mode 1)) - (when gnus-slave - (gnus-slave-mode))) + (when gnus-child + (gnus-child-mode))) (defun gnus-update-group-mark-positions () (save-excursion @@ -1768,7 +1768,7 @@ already. If INFO-UNCHANGED is non-nil, dribble buffer is not updated." (get-text-property (point-at-bol) 'gnus-unread)) (defun gnus-group-new-mail (group) - (if (nnmail-new-mail-p (gnus-group-real-name group)) + (if (nnmail-new-mail-p group) gnus-new-mail-mark ?\s)) @@ -3600,7 +3600,7 @@ or nil if no action could be taken." (marks (gnus-info-marks (nth 1 entry))) (unread (gnus-sequence-of-unread-articles group))) ;; Remove entries for this group. - (nnmail-purge-split-history (gnus-group-real-name group)) + (nnmail-purge-split-history group) ;; Do the updating only if the newsgroup isn't killed. (if (not (numberp (car entry))) (gnus-message 1 "Can't catch up %s; non-active group" group) @@ -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) @@ -4024,9 +4024,9 @@ otherwise all levels below ARG will be scanned too." (gnus-run-hooks 'gnus-get-top-new-news-hook) (gnus-run-hooks 'gnus-get-new-news-hook) - ;; Read any slave files. - (unless gnus-slave - (gnus-master-read-slave-newsrc)) + ;; Read any child files. + (unless gnus-child + (gnus-parent-read-child-newsrc)) (gnus-get-unread-articles (gnus-group-default-level arg t) nil one-level) diff --git a/lisp/gnus/gnus-icalendar.el b/lisp/gnus/gnus-icalendar.el index ee556a32080..29d3e30780f 100644 --- a/lisp/gnus/gnus-icalendar.el +++ b/lisp/gnus/gnus-icalendar.el @@ -312,7 +312,8 @@ status will be retrieved from the first matching attendee record." (unless (gnus-icalendar-find-if (lambda (x) (string-match "^ATTENDEE" x)) reply-event-lines) - (error "Could not find an event attendee matching given identity")) + (lwarn 'gnus-icalendar :warning + "Could not find an event attendee matching given identity")) (mapconcat #'identity `("BEGIN:VEVENT" ,@(nreverse reply-event-lines) @@ -814,7 +815,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-kill.el b/lisp/gnus/gnus-kill.el index 5edbaaf201b..a772281d4c3 100644 --- a/lisp/gnus/gnus-kill.el +++ b/lisp/gnus/gnus-kill.el @@ -653,7 +653,7 @@ Usage: emacs -batch -l ~/.emacs -l gnus -f gnus-batch-score" gnus-options-not-subscribe) ;; Eat all arguments. (setq command-line-args-left nil) - (gnus-slave) + (gnus-child) ;; Apply kills to specified newsgroups in command line arguments. (setq newsrc (cdr gnus-newsrc-alist)) (while (setq info (pop newsrc)) diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el index daaea3980b5..cdfbf16db5e 100644 --- a/lisp/gnus/gnus-msg.el +++ b/lisp/gnus/gnus-msg.el @@ -1510,7 +1510,11 @@ If YANK is non-nil, include the original article." (gnus-inews-yank-articles (list (cdr gnus-article-current))))))) (defun gnus-bug (subject) - "Send a bug report to the Emacs maintainers." + "Send a bug report to the Emacs maintainers. + +Already submitted bugs can be found in the Emacs bug tracker: + + https://debbugs.gnu.org/cgi/pkgreport.cgi?package=emacs;max-bugs=100;base-order=1;bug-rev=1" (interactive "sBug Subject: ") (report-emacs-bug subject) (save-excursion diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el index fd2b44f7424..1ac1d05e033 100644 --- a/lisp/gnus/gnus-registry.el +++ b/lisp/gnus/gnus-registry.el @@ -1,4 +1,4 @@ -;;; gnus-registry.el --- article registry for Gnus +;;; gnus-registry.el --- article registry for Gnus -*- lexical-binding: t; -*- ;; Copyright (C) 2002-2020 Free Software Foundation, Inc. @@ -62,10 +62,10 @@ ;; show the marks as single characters (see the :char property in ;; `gnus-registry-marks'): -;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-chars) +;; (defalias 'gnus-user-format-function-M #'gnus-registry-article-marks-to-chars) ;; show the marks by name (see `gnus-registry-marks'): -;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-names) +;; (defalias 'gnus-user-format-function-M #'gnus-registry-article-marks-to-names) ;; TODO: @@ -449,19 +449,21 @@ This is not required after changing `gnus-registry-cache-file'." to subject sender recipients))) (defun gnus-registry-spool-action (id group &optional subject sender recipients) - (let ((to (gnus-group-guess-full-name-from-command-method group)) - (recipients (or recipients - (gnus-registry-sort-addresses - (or (message-fetch-field "cc") "") - (or (message-fetch-field "to") "")))) - (subject (or subject (message-fetch-field "subject"))) - (sender (or sender (message-fetch-field "from")))) - (when (and (stringp id) (string-match "\r$" id)) - (setq id (substring id 0 -1))) - (gnus-message 7 "Gnus registry: article %s spooled to %s" - id - to) - (gnus-registry-handle-action id nil to subject sender recipients))) + (save-restriction + (message-narrow-to-headers-or-head) + (let ((to (gnus-group-guess-full-name-from-command-method group)) + (recipients (or recipients + (gnus-registry-sort-addresses + (or (message-fetch-field "cc") "") + (or (message-fetch-field "to") "")))) + (subject (or subject (message-fetch-field "subject"))) + (sender (or sender (message-fetch-field "from")))) + (when (and (stringp id) (string-match "\r$" id)) + (setq id (substring id 0 -1))) + (gnus-message 7 "Gnus registry: article %s spooled to %s" + id + to) + (gnus-registry-handle-action id nil to subject sender recipients)))) (defun gnus-registry-handle-action (id from to subject sender &optional recipients) @@ -485,23 +487,25 @@ This is not required after changing `gnus-registry-cache-file'." (when from (setq entry (cons (delete from (assoc 'group entry)) (assq-delete-all 'group entry)))) - - (dolist (kv `((group ,to) - (sender ,sender) - (recipient ,@recipients) - (subject ,subject))) - (when (cadr kv) - (let ((new (or (assq (car kv) entry) - (list (car kv))))) - (dolist (toadd (cdr kv)) - (unless (member toadd new) - (setq new (append new (list toadd))))) - (setq entry (cons new - (assq-delete-all (car kv) entry)))))) - (gnus-message 10 "Gnus registry: new entry for %s is %S" - id - entry) - (gnus-registry-insert db id entry))) + ;; Only keep the entry if the message is going to a new group, or + ;; it's still in some previous group. + (when (or to (alist-get 'group entry)) + (dolist (kv `((group ,to) + (sender ,sender) + (recipient ,@recipients) + (subject ,subject))) + (when (cadr kv) + (let ((new (or (assq (car kv) entry) + (list (car kv))))) + (dolist (toadd (cdr kv)) + (unless (member toadd new) + (setq new (append new (list toadd))))) + (setq entry (cons new + (assq-delete-all (car kv) entry)))))) + (gnus-message 10 "Gnus registry: new entry for %s is %S" + id + entry) + (gnus-registry-insert db id entry)))) ;; Function for nn{mail|imap}-split-fancy: look up all references in ;; the cache and if a match is found, return that group. @@ -588,7 +592,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." subject (< gnus-registry-minimum-subject-length (length subject))) (let ((groups (apply - 'append + #'append (mapcar (lambda (reference) (gnus-registry-get-id-key reference 'group)) @@ -615,7 +619,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." sender gnus-registry-unfollowed-addresses))) (let ((groups (apply - 'append + #'append (mapcar (lambda (reference) (gnus-registry-get-id-key reference 'group)) @@ -644,7 +648,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (not (gnus-grep-in-list recp gnus-registry-unfollowed-addresses))) - (let ((groups (apply 'append + (let ((groups (apply #'append (mapcar (lambda (reference) (gnus-registry-get-id-key reference 'group)) @@ -663,7 +667,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." ;; filter the found groups and return them ;; the found groups are NOT the full groups (setq found (gnus-registry-post-process-groups - "recipients" (mapconcat 'identity recipients ", ") found))) + "recipients" (mapconcat #'identity recipients ", ") found))) ;; after the (cond) we extract the actual value safely (car-safe found))) @@ -791,7 +795,8 @@ Consults `gnus-registry-ignored-groups' and ((stringp g) g) ((and (listp g) (nth 1 g)) (nth 0 g)) - (t nil))) gnus-registry-ignored-groups))) + (t nil))) + gnus-registry-ignored-groups))) ;; only use `gnus-parameter-registry-ignore' if ;; `gnus-registry-ignored-groups' is a list of lists ;; (it can be a list of regexes) @@ -871,7 +876,7 @@ Addresses without a name will say \"noname\"." (defun gnus-registry-sort-addresses (&rest addresses) "Return a normalized and sorted list of ADDRESSES." - (sort (mapcan 'gnus-registry-extract-addresses addresses) 'string-lessp)) + (sort (mapcan #'gnus-registry-extract-addresses addresses) 'string-lessp)) (defun gnus-registry-simplify-subject (subject) (if (stringp subject) @@ -961,16 +966,15 @@ Uses `gnus-registry-marks' to find what shortcuts to install." (intern (format function-format variant-name))) (shortcut (format "%c" (if remove (upcase data) data)))) (defalias function-name - ;; If it weren't for the function's docstring, we could - ;; use a closure, with lexical-let :-( - `(lambda (&rest articles) - ,(format - "%s the %s mark over process-marked ARTICLES." - (upcase-initials variant-name) - mark) - (interactive - (gnus-summary-work-articles current-prefix-arg)) - (gnus-registry--set/remove-mark ',mark ',remove articles))) + (lambda (&rest articles) + (:documentation + (format + "%s the %s mark over process-marked ARTICLES." + (upcase-initials variant-name) + mark)) + (interactive + (gnus-summary-work-articles current-prefix-arg)) + (gnus-registry--set/remove-mark mark remove articles))) (push function-name keys-plist) (push shortcut keys-plist) (push (vector (format "%s %s" @@ -990,14 +994,11 @@ Uses `gnus-registry-marks' to find what shortcuts to install." nil (cons "Registry Marks" gnus-registry-misc-menus)))))) -(make-obsolete 'gnus-registry-user-format-function-M - 'gnus-registry-article-marks-to-chars "24.1") ? - -(defalias 'gnus-registry-user-format-function-M - 'gnus-registry-article-marks-to-chars) +(define-obsolete-function-alias 'gnus-registry-user-format-function-M + #'gnus-registry-article-marks-to-chars "24.1") ;; use like this: -;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-chars) +;; (defalias 'gnus-user-format-function-M #'gnus-registry-article-marks-to-chars) (defun gnus-registry-article-marks-to-chars (headers) "Show the marks for an article by the :char property." (if gnus-registry-enabled @@ -1013,20 +1014,20 @@ Uses `gnus-registry-marks' to find what shortcuts to install." "")) ;; use like this: -;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-names) +;; (defalias 'gnus-user-format-function-M #'gnus-registry-article-marks-to-names) (defun gnus-registry-article-marks-to-names (headers) "Show the marks for an article by name." (if gnus-registry-enabled (let* ((id (mail-header-message-id headers)) (marks (when id (gnus-registry-get-id-key id 'mark)))) - (mapconcat (lambda (mark) (symbol-name mark)) marks ",")) + (mapconcat #'symbol-name marks ",")) "")) (defun gnus-registry-read-mark () "Read a mark name from the user with completion." (let ((mark (gnus-completing-read "Label" - (mapcar 'symbol-name (mapcar 'car gnus-registry-marks)) + (mapcar #'symbol-name (mapcar #'car gnus-registry-marks)) nil nil nil (symbol-name gnus-registry-default-mark)))) (when (stringp mark) @@ -1050,7 +1051,7 @@ Uses `gnus-registry-marks' to find what shortcuts to install." show-message) "Apply or remove MARK across a list of ARTICLES." (let ((article-id-list - (mapcar 'gnus-registry-fetch-message-id-fast articles))) + (mapcar #'gnus-registry-fetch-message-id-fast articles))) (dolist (id article-id-list) (let* ((marks (delq mark (gnus-registry-get-id-key id 'mark))) (marks (if remove marks (cons mark marks)))) @@ -1173,34 +1174,34 @@ only the last one's marks are returned." (gnus-registry-install-shortcuts) (if (gnus-alive-p) (gnus-registry-load) - (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-load))) + (add-hook 'gnus-read-newsrc-el-hook #'gnus-registry-load))) (defun gnus-registry-install-hooks () "Install the registry hooks." (setq gnus-registry-enabled t) - (add-hook 'gnus-summary-article-move-hook 'gnus-registry-action) - (add-hook 'gnus-summary-article-delete-hook 'gnus-registry-action) - (add-hook 'gnus-summary-article-expire-hook 'gnus-registry-action) - (add-hook 'nnmail-spool-hook 'gnus-registry-spool-action) + (add-hook 'gnus-summary-article-move-hook #'gnus-registry-action) + (add-hook 'gnus-summary-article-delete-hook #'gnus-registry-action) + (add-hook 'gnus-summary-article-expire-hook #'gnus-registry-action) + (add-hook 'nnmail-spool-hook #'gnus-registry-spool-action) - (add-hook 'gnus-save-newsrc-hook 'gnus-registry-save) + (add-hook 'gnus-save-newsrc-hook #'gnus-registry-save) - (add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids)) + (add-hook 'gnus-summary-prepare-hook #'gnus-registry-register-message-ids)) (defun gnus-registry-unload-hook () "Uninstall the registry hooks." - (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action) - (remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action) - (remove-hook 'gnus-summary-article-expire-hook 'gnus-registry-action) - (remove-hook 'nnmail-spool-hook 'gnus-registry-spool-action) + (remove-hook 'gnus-summary-article-move-hook #'gnus-registry-action) + (remove-hook 'gnus-summary-article-delete-hook #'gnus-registry-action) + (remove-hook 'gnus-summary-article-expire-hook #'gnus-registry-action) + (remove-hook 'nnmail-spool-hook #'gnus-registry-spool-action) - (remove-hook 'gnus-save-newsrc-hook 'gnus-registry-save) - (remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-load) + (remove-hook 'gnus-save-newsrc-hook #'gnus-registry-save) + (remove-hook 'gnus-read-newsrc-el-hook #'gnus-registry-load) - (remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids) + (remove-hook 'gnus-summary-prepare-hook #'gnus-registry-register-message-ids) (setq gnus-registry-enabled nil)) -(add-hook 'gnus-registry-unload-hook 'gnus-registry-unload-hook) +(add-hook 'gnus-registry-unload-hook #'gnus-registry-unload-hook) (defun gnus-registry-install-p () "Return non-nil if the registry is enabled (and maybe enable it first). @@ -1234,7 +1235,7 @@ data stored in the registry." (seen-groups (list (gnus-group-group-name)))) (catch 'found - (dolist (group (mapcar 'gnus-simplify-group-name groups)) + (dolist (group (mapcar #'gnus-simplify-group-name groups)) ;; skip over any groups we really don't want to warp to. (unless (or (member group seen-groups) @@ -1270,7 +1271,7 @@ EXTRA is a list of symbols. Valid symbols are those contained in the docs of `gnus-registry-track-extra'. This command is useful when you stop tracking some extra data and now want to purge it from your existing entries." - (interactive (list (mapcar 'intern + (interactive (list (mapcar #'intern (completing-read-multiple "Extra data: " '("subject" "sender" "recipient"))))) diff --git a/lisp/gnus/gnus-sieve.el b/lisp/gnus/gnus-sieve.el index 278e3a5d6f3..5d8f9b55deb 100644 --- a/lisp/gnus/gnus-sieve.el +++ b/lisp/gnus/gnus-sieve.el @@ -29,8 +29,6 @@ (require 'gnus) (require 'gnus-sum) -(require 'format-spec) -(autoload 'sieve-mode "sieve-mode") (eval-when-compile (require 'sieve)) @@ -88,10 +86,10 @@ See the documentation for these variables and functions for details." (save-buffer) (shell-command (format-spec gnus-sieve-update-shell-command - (format-spec-make ?f gnus-sieve-file - ?s (or (cadr (gnus-server-get-method - nil gnus-sieve-select-method)) - ""))))) + `((?f . ,gnus-sieve-file) + (?s . ,(or (cadr (gnus-server-get-method + nil gnus-sieve-select-method)) + "")))))) ;;;###autoload (defun gnus-sieve-generate () 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..ba8b91be5c5 100644 --- a/lisp/gnus/gnus-start.el +++ b/lisp/gnus/gnus-start.el @@ -730,7 +730,7 @@ the first newsgroup." ;; Remove Gnus frames. (gnus-kill-gnus-frames)) -(defun gnus-no-server-1 (&optional arg slave) +(defun gnus-no-server-1 (&optional arg child) "Read network news. If ARG is a positive number, Gnus will use that as the startup level. If ARG is nil, Gnus will be started at level 2 @@ -739,11 +739,11 @@ and not a positive number, Gnus will prompt the user for the name of an NNTP server to use. As opposed to \\[gnus], this command will not connect to the local server." (let ((val (or arg (1- gnus-level-default-subscribed)))) - (gnus val t slave) + (gnus val t child) (make-local-variable 'gnus-group-use-permanent-levels) (setq gnus-group-use-permanent-levels val))) -(defun gnus-1 (&optional arg dont-connect slave) +(defun gnus-1 (&optional arg dont-connect child) "Read network news. If ARG is non-nil and a positive number, Gnus will use that as the startup level. If ARG is non-nil and not a positive number, Gnus will @@ -761,7 +761,7 @@ prompt the user for the name of an NNTP server to use." (gnus-splash) (gnus-run-hooks 'gnus-before-startup-hook) (nnheader-init-server-buffer) - (setq gnus-slave slave) + (setq gnus-child child) (gnus-read-init-file) ;; Add "native" to gnus-predefined-server-alist just to have a @@ -790,7 +790,7 @@ prompt the user for the name of an NNTP server to use." (gnus-make-newsrc-file gnus-startup-file)) ;; Read the dribble file. - (when (or gnus-slave gnus-use-dribble-file) + (when (or gnus-child gnus-use-dribble-file) (gnus-dribble-read-file)) ;; Do the actual startup. @@ -1008,11 +1008,11 @@ If LEVEL is non-nil, the news will be set up at level LEVEL." ;; Possibly eval the dribble file. (and init - (or gnus-use-dribble-file gnus-slave) + (or gnus-use-dribble-file gnus-child) (gnus-dribble-eval-file)) - ;; Slave Gnusii should then clear the dribble buffer. - (when (and init gnus-slave) + ;; Child Gnusii should then clear the dribble buffer. + (when (and init gnus-child) (gnus-dribble-clear)) (gnus-update-format-specifications) @@ -1030,7 +1030,7 @@ If LEVEL is non-nil, the news will be set up at level LEVEL." ;; Find new newsgroups and treat them. (when (and init gnus-check-new-newsgroups (not level) (gnus-check-server gnus-select-method) - (not gnus-slave) + (not gnus-child) gnus-plugged) (gnus-find-new-newsgroups)) @@ -1040,8 +1040,8 @@ If LEVEL is non-nil, the news will be set up at level LEVEL." (gnus-server-opened gnus-select-method)) (gnus-check-bogus-newsgroups)) - ;; Read any slave files. - (gnus-master-read-slave-newsrc) + ;; Read any child files. + (gnus-parent-read-child-newsrc) ;; Find the number of unread articles in each non-dead group. (let ((gnus-read-active-file (and (not level) gnus-read-active-file))) @@ -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) @@ -2111,6 +2111,7 @@ The info element is shared with the same element of ((string= gnus-ignored-newsgroups "") (delete-matching-lines "^to\\.")) (t + ;; relint suppression: Duplicated alternative branch (delete-matching-lines (concat "^to\\.\\|" gnus-ignored-newsgroups)))) (goto-char (point-min)) @@ -2737,15 +2738,15 @@ values from `gnus-newsrc-hashtb', and write a new value of (gnus-agent-save-local force)) (save-excursion - (if (and (or gnus-use-dribble-file gnus-slave) + (if (and (or gnus-use-dribble-file gnus-child) (not force) (or (not (buffer-live-p gnus-dribble-buffer)) (zerop (with-current-buffer gnus-dribble-buffer (buffer-size))))) (gnus-message 4 "(No changes need to be saved)") (gnus-run-hooks 'gnus-save-newsrc-hook) - (if gnus-slave - (gnus-slave-save-newsrc) + (if gnus-child + (gnus-child-save-newsrc) ;; Save .newsrc only if the select method is an NNTP method. ;; The .newsrc file is for interoperability with other ;; newsreaders, so saving non-NNTP groups there doesn't make @@ -2812,7 +2813,7 @@ values from `gnus-newsrc-hashtb', and write a new value of (file-exists-p working-file))) (unwind-protect - (progn + (with-file-modes (file-modes startup-file) (gnus-with-output-to-file working-file (gnus-gnus-to-quick-newsrc-format) (gnus-run-hooks 'gnus-save-quick-newsrc-hook)) @@ -2822,14 +2823,12 @@ values from `gnus-newsrc-hashtb', and write a new value of ;; file. (let ((buffer-backed-up nil) (buffer-file-name startup-file) - (file-precious-flag t) - (setmodes (file-modes startup-file))) + (file-precious-flag t)) ;; Backup the current version of the startup file. (backup-buffer) ;; Replace the existing startup file with the temp file. (rename-file working-file startup-file t) - (gnus-set-file-modes startup-file setmodes) (setq gnus-save-newsrc-file-last-timestamp (file-attribute-modification-time (file-attributes startup-file))))) @@ -2990,55 +2989,61 @@ SPECIFIC-VARIABLES, or those in `gnus-variable-list'." ;;; -;;; Slave functions. +;;; Child functions. ;;; -(defvar gnus-slave-mode nil) +(defvar gnus-child-mode nil) -(defun gnus-slave-mode () - "Minor mode for slave Gnusae." - ;; FIXME: gnus-slave-mode appears to never be set (i.e. it'll always be nil): +(defun gnus-child-mode () + "Minor mode for child Gnusae." + ;; FIXME: gnus-child-mode appears to never be set (i.e. it'll always be nil): ;; Remove, or fix and use define-minor-mode. - (add-minor-mode 'gnus-slave-mode " Slave" (make-sparse-keymap)) - (gnus-run-hooks 'gnus-slave-mode-hook)) + (add-minor-mode 'gnus-child-mode " Child" (make-sparse-keymap)) + (gnus-run-hooks 'gnus-child-mode-hook)) -(defun gnus-slave-save-newsrc () +(define-obsolete-function-alias 'gnus-slave-mode #'gnus-child-mode "28.1") +(define-obsolete-variable-alias 'gnus-slave-mode-hook 'gnus-child-mode-hook + "28.1") + +(defun gnus-child-save-newsrc () (with-current-buffer gnus-dribble-buffer - (let ((slave-name - (make-temp-file (concat gnus-current-startup-file "-slave-"))) - (modes (ignore-errors - (file-modes (concat gnus-current-startup-file ".eld"))))) - (let ((coding-system-for-write gnus-ding-file-coding-system)) - (gnus-write-buffer slave-name)) - (when modes - (gnus-set-file-modes slave-name modes))))) - -(defun gnus-master-read-slave-newsrc () - (let ((slave-files + (with-file-modes (or (ignore-errors + (file-modes + (concat gnus-current-startup-file ".eld"))) + (default-file-modes)) + (let ((child-name + (make-temp-file (concat gnus-current-startup-file "-child-")))) + (let ((coding-system-for-write gnus-ding-file-coding-system)) + (gnus-write-buffer child-name)))))) + +(defun gnus-parent-read-child-newsrc () + (let ((child-files (directory-files (file-name-directory gnus-current-startup-file) t (concat "^" (regexp-quote - (concat - (file-name-nondirectory gnus-current-startup-file) - "-slave-"))) + (file-name-nondirectory gnus-current-startup-file)) + ;; When the obsolete variables like + ;; `gnus-slave-mode-hook' etc are removed, the "slave" + ;; bit of this regexp should also be removed. + "\\(-child-\\|-slave-\\)") t)) file) - (if (not slave-files) - () ; There are no slave files to read. - (gnus-message 7 "Reading slave newsrcs...") - (with-current-buffer (gnus-get-buffer-create " *gnus slave*") - (setq slave-files + (if (not child-files) + () ; There are no child files to read. + (gnus-message 7 "Reading child newsrcs...") + (with-current-buffer (gnus-get-buffer-create " *gnus child*") + (setq child-files (sort (mapcar (lambda (file) (list (file-attribute-modification-time (file-attributes file)) file)) - slave-files) + child-files) (lambda (f1 f2) (time-less-p (car f1) (car f2))))) - (while slave-files + (while child-files (erase-buffer) - (setq file (nth 1 (car slave-files))) + (setq file (nth 1 (car child-files))) (nnheader-insert-file-contents file) (when (condition-case () (progn @@ -3047,12 +3052,12 @@ SPECIFIC-VARIABLES, or those in `gnus-variable-list'." (error (gnus-error 3.2 "Possible error in %s" file) nil)) - (unless gnus-slave ; Slaves shouldn't delete these files. + (unless gnus-child ; Children shouldn't delete these files. (ignore-errors (delete-file file)))) - (setq slave-files (cdr slave-files)))) + (setq child-files (cdr child-files)))) (gnus-dribble-touch) - (gnus-message 7 "Reading slave newsrcs...done")))) + (gnus-message 7 "Reading child newsrcs...done")))) ;;; diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index 9b11d5878d9..4363860eac8 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -1501,9 +1501,9 @@ the type of the variable (string, integer, character, etc).") ;; This is here rather than in gnus-art for compilation reasons. (defvar gnus-article-mode-line-format-alist - (nconc '((?w (gnus-article-wash-status) ?s) - (?m (gnus-article-mime-part-status) ?s)) - gnus-summary-mode-line-format-alist)) + (append '((?w (gnus-article-wash-status) ?s) + (?m (gnus-article-mime-part-status) ?s)) + gnus-summary-mode-line-format-alist)) (defvar gnus-last-search-regexp nil "Default regexp for article search command.") @@ -5352,7 +5352,8 @@ or a straight list of headers." ;; We remember that we probably want to output a dummy ;; root. (setq gnus-tmp-dummy-line gnus-tmp-header) - (setq gnus-tmp-prev-subject gnus-tmp-header)) + (setq gnus-tmp-prev-subject + (gnus-simplify-subject-fully gnus-tmp-header))) (t ;; We do not make a root for the gathered ;; sub-threads at all. @@ -5937,7 +5938,9 @@ If SELECT-ARTICLES, only select those articles from GROUP." (initial (gnus-parameter-large-newsgroup-initial gnus-newsgroup-name)) (default (if only-read-p - (or initial gnus-large-newsgroup) + (if (eq initial 'all) + nil + (or initial gnus-large-newsgroup)) number)) (input (read-string @@ -7310,7 +7313,7 @@ If FORCE (the prefix), also save the .newsrc file(s)." (when gnus-use-cache (gnus-cache-write-active)) ;; Remove entries for this group. - (nnmail-purge-split-history (gnus-group-real-name group)) + (nnmail-purge-split-history group) ;; Make all changes in this group permanent. (unless quit-config (gnus-run-hooks 'gnus-exit-group-hook) @@ -7331,6 +7334,8 @@ If FORCE (the prefix), also save the .newsrc file(s)." (gnus-group-next-unread-group 1)) (setq group-point (point)) (gnus-article-stop-animations) + (unless leave-hidden + (gnus-configure-windows 'group 'force)) (if temporary nil ;Nothing to do. (set-buffer buf) @@ -7350,8 +7355,6 @@ If FORCE (the prefix), also save the .newsrc file(s)." (if quit-config (gnus-handle-ephemeral-exit quit-config) (goto-char group-point) - (unless leave-hidden - (gnus-configure-windows 'group 'force)) ;; If gnus-group-buffer is already displayed, make sure we also move ;; the cursor in the window that displays it. (let ((win (get-buffer-window (current-buffer) 0))) @@ -9493,16 +9496,6 @@ The 1st element is the button named by `gnus-collect-urls-primary-text'." (push primary urls)) (delete-dups urls))) -;; cf. `ediff-truncate-string-left', to become `string-truncate-left' -;; in Emacs 28 -(defun gnus--string-truncate-left (string length) - "Truncate STRING to LENGTH, replacing initial surplus with \"...\"." - (let ((strlen (length string))) - (if (<= strlen length) - string - (setq length (max 0 (- length 3))) - (concat "..." (substring string (max 0 (- strlen 1 length))))))) - (defun gnus-shorten-url (url max) "Return an excerpt from URL not exceeding MAX characters." (if (<= (length url) max) @@ -9512,7 +9505,7 @@ The 1st element is the button named by `gnus-collect-urls-primary-text'." (rest (concat (url-filename parsed) (when-let ((target (url-target parsed))) (concat "#" target))))) - (concat host (gnus--string-truncate-left rest (- max (length host))))))) + (concat host (string-truncate-left rest (- max (length host))))))) (defun gnus-summary-browse-url (&optional external) "Scan the current article body for links, and offer to browse them. @@ -12291,7 +12284,7 @@ no matter what the properties `:decode' and `:headers' are." (interactive (gnus-interactive "P\ny")) (require 'gnus-art) (let* ((articles (gnus-summary-work-articles n)) - (result-buffer "*Shell Command Output*") + (result-buffer shell-command-buffer-name) (all-headers (not (memq sym '(nil r)))) (gnus-save-all-headers (or all-headers gnus-save-all-headers)) (raw (eq sym 'r)) @@ -12320,7 +12313,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 @@ -12508,7 +12501,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) @@ -12518,10 +12511,15 @@ save those articles instead." "Save parts matching TYPE to DIR. If REVERSE, save parts that do not match TYPE." (interactive - (list (read-string "Save parts of type: " - (or (car gnus-summary-save-parts-type-history) - gnus-summary-save-parts-default-mime) - 'gnus-summary-save-parts-type-history) + (list (completing-read "Save parts of type: " + (progn + (gnus-summary-select-article nil t) + (gnus-eval-in-buffer-window gnus-article-buffer + (delete-dups + (mapcar (lambda (h) + (mm-handle-media-type (cdr h))) + gnus-article-mime-handle-alist)))) + nil nil nil 'gnus-summary-save-parts-type-history) (setq gnus-summary-save-parts-last-directory (read-directory-name "Save to directory: " gnus-summary-save-parts-last-directory @@ -13169,10 +13167,13 @@ If ALL is a number, fetch this number of articles." (t (when (and (numberp gnus-large-newsgroup) (> len gnus-large-newsgroup)) - (let* ((cursor-in-echo-area nil) - (initial (gnus-parameter-large-newsgroup-initial - gnus-newsgroup-name)) - (input + (let ((cursor-in-echo-area nil) + (initial (gnus-parameter-large-newsgroup-initial + gnus-newsgroup-name)) + input) + (when (eq initial 'all) + (setq initial len)) + (setq input (read-string (format "How many articles from %s (%s %d): " @@ -13181,7 +13182,7 @@ If ALL is a number, fetch this number of articles." len) nil nil (and initial - (number-to-string initial))))) + (number-to-string initial)))) (unless (string-match "^[ \t]*$" input) (setq all (string-to-number input)) (if (< all len) diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index 3429d6560b7..4876715ae6a 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -455,9 +455,7 @@ displayed in the echo area." (> message-log-max 0) (/= (length str) 0)) (setq time (current-time)) - (with-current-buffer (if (fboundp 'messages-buffer) - (messages-buffer) - (get-buffer-create "*Messages*")) + (with-current-buffer (messages-buffer) (goto-char (point-max)) (let ((inhibit-read-only t)) (insert ,timestamp str "\n") @@ -768,7 +766,7 @@ nil. See also `gnus-bind-print-variables'." If there's no subdirectory, delete DIRECTORY as well." (when (file-directory-p directory) (let ((files (directory-files - directory t (rx (or (not ".") "...")))) + directory t directory-files-no-dot-files-regexp)) file dir) (while files (setq file (pop files)) @@ -950,7 +948,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 +1034,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 +1455,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) @@ -1601,10 +1599,10 @@ empty directories from OLD-PATH." (file-truename (concat old-dir ".."))))))))) -(defun gnus-set-file-modes (filename mode) +(defun gnus-set-file-modes (filename mode &optional flag) "Wrapper for set-file-modes." (ignore-errors - (set-file-modes filename mode))) + (set-file-modes filename mode flag))) (defun gnus-rescale-image (image size) "Rescale IMAGE to SIZE if possible. @@ -1654,6 +1652,7 @@ The first found will be returned if a file has hard or symbolic links." "To each element of LIST apply PREDICATE. Return nil if LIST is no list or is empty or some test returns nil; otherwise, return t." + (declare (obsolete nil "28.1")) (when (and list (listp list)) (let ((result (mapcar predicate list))) (not (memq nil result))))) diff --git a/lisp/gnus/gnus-uu.el b/lisp/gnus/gnus-uu.el index 5902f2b37a7..70aeac00d7f 100644 --- a/lisp/gnus/gnus-uu.el +++ b/lisp/gnus/gnus-uu.el @@ -1674,7 +1674,7 @@ Gnus might fail to display all of it.") did-unpack)) (defun gnus-uu-dir-files (dir) - (let ((dirs (directory-files dir t (rx (or (not ".") "...")))) + (let ((dirs (directory-files dir t directory-files-no-dot-files-regexp)) files file) (while dirs (if (file-directory-p (setq file (car dirs))) @@ -1781,8 +1781,8 @@ Gnus might fail to display all of it.") gnus-uu-tmp-dir))) (setq gnus-uu-work-dir - (make-temp-file (concat gnus-uu-tmp-dir "gnus") 'dir)) - (gnus-set-file-modes gnus-uu-work-dir 448) + (with-file-modes #o700 + (make-temp-file (concat gnus-uu-tmp-dir "gnus") 'dir))) (setq gnus-uu-work-dir (file-name-as-directory gnus-uu-work-dir)) (push (cons gnus-newsgroup-name gnus-uu-work-dir) gnus-uu-tmp-alist)))) diff --git a/lisp/gnus/gnus-win.el b/lisp/gnus/gnus-win.el index 36b28350362..baa3146e64e 100644 --- a/lisp/gnus/gnus-win.el +++ b/lisp/gnus/gnus-win.el @@ -142,7 +142,7 @@ used to display Gnus windows." (pipe (vertical 1.0 (summary 0.25 point) - ("*Shell Command Output*" 1.0))) + (shell-command-buffer-name 1.0))) (bug (vertical 1.0 (if gnus-bug-create-help-buffer '("*Gnus Help Bug*" 0.5)) diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index 6df26b4af8c..cecf4d4fb49 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." @@ -1029,8 +1029,7 @@ Check the NNTPSERVER environment variable and the ;; `M-x customize-variable RET gnus-select-method RET' should work without ;; starting or even loading Gnus. -;;;###autoload(when (fboundp 'custom-autoload) -;;;###autoload (custom-autoload 'gnus-select-method "gnus")) +;;;###autoload(custom-autoload 'gnus-select-method "gnus") (defcustom gnus-select-method (list 'nntp (or (gnus-getenv-nntpserver) @@ -1591,7 +1590,7 @@ posting an article." "Alist of group regexps and its initial input of the number of articles." :variable-group gnus-group-parameter :parameter-type '(choice :tag "Initial Input for Large Newsgroup" - (const :tag "All" nil) + (const :tag "All" 'all) (integer)) :parameter-document "\ @@ -2226,8 +2225,8 @@ Disabling the agent may result in noticeable loss of performance." :group 'gnus-start :type '(choice (function-item gnus) (function-item gnus-no-server) - (function-item gnus-slave) - (function-item gnus-slave-no-server))) + (function-item gnus-child) + (function-item gnus-child-no-server))) (declare-function gnus-group-get-new-news "gnus-group") @@ -2238,8 +2237,8 @@ Disabling the agent may result in noticeable loss of performance." :type '(choice (function-item gnus) (function-item gnus-group-get-new-news) (function-item gnus-no-server) - (function-item gnus-slave) - (function-item gnus-slave-no-server))) + (function-item gnus-child) + (function-item gnus-child-no-server))) (defcustom gnus-other-frame-parameters nil "Frame parameters used by `gnus-other-frame' to create a Gnus frame." @@ -2417,8 +2416,8 @@ such as a mark that says whether an article is stored in the cache (defvar gnus-article-buffer "*Article*") (defvar gnus-server-buffer "*Server*") -(defvar gnus-slave nil - "Whether this Gnus is a slave or not.") +(defvar gnus-child nil + "Whether this Gnus is a child or not.") (defvar gnus-batch-mode nil "Whether this Gnus is running in batch mode or not.") @@ -4034,13 +4033,20 @@ Allow completion over sensible values." ;;; User-level commands. ;;;###autoload +(defun gnus-child-no-server (&optional arg) + "Read network news as a child, without connecting to the local server." + (interactive "P") + (gnus-no-server arg t)) + +;;;###autoload (defun gnus-slave-no-server (&optional arg) - "Read network news as a slave, without connecting to the local server." + "Read network news as a child, without connecting to the local server." (interactive "P") (gnus-no-server arg t)) +(make-obsolete 'gnus-slave-no-server 'gnus-child-no-server "28.1") ;;;###autoload -(defun gnus-no-server (&optional arg slave) +(defun gnus-no-server (&optional arg child) "Read network news. If ARG is a positive number, Gnus will use that as the startup level. If ARG is nil, Gnus will be started at level 2. If ARG is non-nil @@ -4049,13 +4055,20 @@ an NNTP server to use. As opposed to `gnus', this command will not connect to the local server." (interactive "P") - (gnus-no-server-1 arg slave)) + (gnus-no-server-1 arg child)) + +;;;###autoload +(defun gnus-child (&optional arg) + "Read news as a child." + (interactive "P") + (gnus arg nil 'child)) ;;;###autoload (defun gnus-slave (&optional arg) - "Read news as a slave." + "Read news as a child." (interactive "P") - (gnus arg nil 'slave)) + (gnus arg nil 'child)) +(make-obsolete 'gnus-slave 'gnus-child "28.1") (defun gnus-delete-gnus-frame () "Delete gnus frame unless it is the only one. @@ -4116,7 +4129,7 @@ current display is used." (add-hook 'gnus-suspend-gnus-hook #'gnus-delete-gnus-frame))))) ;;;###autoload -(defun gnus (&optional arg dont-connect slave) +(defun gnus (&optional arg dont-connect child) "Read network news. If ARG is non-nil and a positive number, Gnus will use that as the startup level. If ARG is non-nil and not a positive number, Gnus will @@ -4130,7 +4143,7 @@ prompt the user for the name of an NNTP server to use." (message "You should byte-compile Gnus") (sit-for 2)) (let ((gnus-action-message-log (list nil))) - (gnus-1 arg dont-connect slave) + (gnus-1 arg dont-connect child) (gnus-final-warning))) (declare-function debbugs-gnu "ext:debbugs-gnu" diff --git a/lisp/gnus/gssapi.el b/lisp/gnus/gssapi.el index 218a1542e3a..485d58ad94e 100644 --- a/lisp/gnus/gssapi.el +++ b/lisp/gnus/gssapi.el @@ -25,8 +25,6 @@ ;;; Code: -(require 'format-spec) - (defcustom gssapi-program (list (concat "gsasl %s %p " "--mechanism GSSAPI " @@ -53,12 +51,9 @@ tried until a successful connection is made." (coding-system-for-write 'binary) (process (start-process name buffer shell-file-name shell-command-switch - (format-spec - cmd - (format-spec-make - ?s server - ?p (number-to-string port) - ?l user)))) + (format-spec cmd `((?s . ,server) + (?p . ,(number-to-string port)) + (?l . ,user))))) response) (when process (while (and (memq (process-status process) '(open run)) diff --git a/lisp/gnus/mail-source.el b/lisp/gnus/mail-source.el index 52343d4fa37..43180726c45 100644 --- a/lisp/gnus/mail-source.el +++ b/lisp/gnus/mail-source.el @@ -24,7 +24,6 @@ ;;; Code: -(require 'format-spec) (eval-when-compile (require 'cl-lib) (require 'imap)) @@ -695,7 +694,7 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) mail-source-movemail-program nil errors nil from to))))) (when (file-exists-p to) - (set-file-modes to mail-source-default-file-modes)) + (set-file-modes to mail-source-default-file-modes 'nofollow)) (if (and (or (not (buffer-modified-p errors)) (zerop (buffer-size errors))) (and (numberp result) @@ -740,9 +739,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)) @@ -767,14 +768,14 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) "Fetcher for single-file sources." (mail-source-bind (file source) (mail-source-run-script - prescript (format-spec-make ?t mail-source-crash-box) + prescript `((?t . ,mail-source-crash-box)) prescript-delay) (let ((mail-source-string (format "file:%s" path))) (if (mail-source-movemail path mail-source-crash-box) (prog1 (mail-source-callback callback path) (mail-source-run-script - postscript (format-spec-make ?t mail-source-crash-box)) + postscript `((?t . ,mail-source-crash-box))) (mail-source-delete-crash-box)) 0)))) @@ -782,7 +783,7 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) "Fetcher for directory sources." (mail-source-bind (directory source) (mail-source-run-script - prescript (format-spec-make ?t path) prescript-delay) + prescript `((?t . ,path)) prescript-delay) (let ((found 0) (mail-source-string (format "directory:%s" path))) (dolist (file (directory-files @@ -791,7 +792,7 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) (funcall predicate file) (mail-source-movemail file mail-source-crash-box)) (cl-incf found (mail-source-callback callback file)) - (mail-source-run-script postscript (format-spec-make ?t path)) + (mail-source-run-script postscript `((?t . ,path))) (mail-source-delete-crash-box))) found))) @@ -801,8 +802,8 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) ;; fixme: deal with stream type in format specs (mail-source-run-script prescript - (format-spec-make ?p password ?t mail-source-crash-box - ?s server ?P port ?u user) + `((?p . ,password) (?t . ,mail-source-crash-box) + (?s . ,server) (?P . ,port) (?u . ,user)) prescript-delay) (let ((from (format "%s:%s:%s" server user port)) (mail-source-string (format "pop:%s@%s" user server)) @@ -823,8 +824,8 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) (mail-source-fetch-with-program (format-spec program - (format-spec-make ?p password ?t mail-source-crash-box - ?s server ?P port ?u user)))) + `((?p . ,password) (?t . ,mail-source-crash-box) + (?s . ,server) (?P . ,port) (?u . ,user))))) (function (funcall function mail-source-crash-box)) ;; The default is to use pop3.el. @@ -861,8 +862,8 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) (setq mail-source-new-mail-available nil)) (mail-source-run-script postscript - (format-spec-make ?p password ?t mail-source-crash-box - ?s server ?P port ?u user)) + `((?p . ,password) (?t . ,mail-source-crash-box) + (?s . ,server) (?P . ,port) (?u . ,user))) (mail-source-delete-crash-box))) ;; We nix out the password in case the error ;; was because of a wrong password being given. @@ -1075,8 +1076,9 @@ This only works when `display-time' is enabled." "Fetcher for imap sources." (mail-source-bind (imap source) (mail-source-run-script - prescript (format-spec-make ?p password ?t mail-source-crash-box - ?s server ?P port ?u user) + prescript + `((?p . ,password) (?t . ,mail-source-crash-box) + (?s . ,server) (?P . ,port) (?u . ,user)) prescript-delay) (let ((from (format "%s:%s:%s" server user port)) (found 0) @@ -1141,8 +1143,8 @@ This only works when `display-time' is enabled." (kill-buffer buf) (mail-source-run-script postscript - (format-spec-make ?p password ?t mail-source-crash-box - ?s server ?P port ?u user)) + `((?p . ,password) (?t . ,mail-source-crash-box) + (?s . ,server) (?P . ,port) (?u . ,user))) found))) (provide 'mail-source) diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index cbdd329f3ec..ab625be9e37 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -42,13 +42,12 @@ (require 'mail-parse) (require 'mml) (require 'rfc822) -(require 'format-spec) (require 'dired) (require 'mm-util) (require 'rfc2047) (require 'puny) -(require 'rmc) ; read-multiple-choice -(eval-when-compile (require 'subr-x)) ; when-let* +(require 'rmc) ; read-multiple-choice +(eval-when-compile (require 'subr-x)) (autoload 'mailclient-send-it "mailclient") @@ -215,9 +214,9 @@ Also see `message-required-news-headers' and :link '(custom-manual "(message)Message Headers") :type '(repeat sexp)) -(defcustom message-draft-headers '(References From Date) +(defcustom message-draft-headers '(References From) "Headers to be generated when saving a draft message." - :version "22.1" + :version "28.1" :group 'message-news :group 'message-headers :link '(custom-manual "(message)Message Headers") @@ -304,6 +303,13 @@ any confusion." :link '(custom-manual "(message)Message Headers") :type 'regexp) +(defcustom message-screenshot-command '("import" "png:-") + "Command to take a screenshot. +The command should insert a PNG in the current buffer." + :group 'message-various + :type '(list string) + :version "28.1") + ;;; Start of variables adopted from `message-utils.el'. (defcustom message-subject-trailing-was-query t @@ -322,7 +328,7 @@ used." :group 'message-various) (defcustom message-subject-trailing-was-ask-regexp - "[ \t]*\\([[(]+[Ww][Aa][Ss]:?[ \t]*.*[])]+\\)" + "[ \t]*\\([[(]+[Ww][Aa][Ss].*[])]+\\)" "Regexp matching \"(was: <old subject>)\" in the subject line. The function `message-strip-subject-trailing-was' uses this regexp if @@ -337,7 +343,7 @@ It is okay to create some false positives here, as the user is asked." :type 'regexp) (defcustom message-subject-trailing-was-regexp - "[ \t]*\\((*[Ww][Aa][Ss]:[ \t]*.*)\\)" + "[ \t]*\\((*[Ww][Aa][Ss]:.*)\\)" "Regexp matching \"(was: <old subject>)\" in the subject line. If `message-subject-trailing-was-query' is set to t, the subject is @@ -440,8 +446,8 @@ whitespace)." (defcustom message-elide-ellipsis "\n[...]\n\n" "The string which is inserted for elided text. -This is a format-spec string, and you can use %l to say how many -lines were removed, and %c to say how many characters were +This is a `format-spec' string, and you can use %l to say how +many lines were removed, and %c to say how many characters were removed." :type 'string :link '(custom-manual "(message)Various Commands") @@ -1986,6 +1992,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") @@ -2730,6 +2737,64 @@ systematically send encrypted emails when possible." (when (message-all-epg-keys-available-p) (mml-secure-message-sign-encrypt))) +(defcustom message-openpgp-header nil + "Specification for the \"OpenPGP\" header of outgoing messages. + +The value must be a list of three elements, all strings: +- Key ID, in hexadecimal form; +- Key URL or ASCII armoured key; and +- Protection preference, one of: \"unprotected\", \"sign\", + \"encrypt\" or \"signencrypt\". + +Each of the elements may be nil, in which case its part in the +OpenPGP header will be left out. If all the values are nil, +or `message-openpgp-header' is itself nil, the OpenPGP header +will not be inserted." + :type '(choice + (const nil :tag "Don't add OpenPGP header") + (list (choice (string :tag "ID") + (const nil :tag "No ID")) + (choice (string :tag "Key") + (const nil :tag "No Key")) + (choice (other nil :tag "None") + (const "unprotected" :tag "Unprotected") + (const "sign" :tag "Sign") + (const "encrypt" :tag "Encrypt") + (const "signencrypt" :tag "Sign and Encrypt")))) + :version "28.1") + +(defun message-add-openpgp-header () + "Add OpenPGP header to point to public key. + +Header will be constructed as specified in `message-openpgp-header'. + +Consider adding this function to `message-send-hook'." + ;; See https://tools.ietf.org/html/draft-josefsson-openpgp-mailnews-header + (when (and message-openpgp-header + (or (nth 0 message-openpgp-header) + (nth 1 message-openpgp-header) + (nth 2 message-openpgp-header))) + (with-temp-buffer + (insert "OpenPGP: ") + ;; add ID + (let (need-sep) + (when (nth 0 message-openpgp-header) + (insert "id=" (nth 0 message-openpgp-header)) + (setq need-sep t)) + ;; add URL + (when (nth 1 message-openpgp-header) + (when need-sep (insert "; ")) + (if (string-match-p ";") + (insert "url=\"" (nth 1 message-openpgp-header) "\"") + (insert "url=\"" (nth 1 message-openpgp-header) "\"")) + (setq need-sep t)) + ;; add preference + (when (nth 2 message-openpgp-header) + (when need-sep (insert "; ")) + (insert "preference=" (nth 2 message-openpgp-header)))) + ;; insert header + (message-add-header (buffer-string))))) + ;;; @@ -2810,6 +2875,7 @@ systematically send encrypted emails when possible." (define-key message-mode-map [remap split-line] 'message-split-line) (define-key message-mode-map "\C-c\C-a" 'mml-attach-file) + (define-key message-mode-map "\C-c\C-p" 'message-insert-screenshot) (define-key message-mode-map "\C-a" 'message-beginning-of-line) (define-key message-mode-map "\t" 'message-tab) @@ -2839,6 +2905,8 @@ systematically send encrypted emails when possible." :active (message-mark-active-p) :help "Mark region with enclosing tags"] ["Insert File Marked..." message-mark-insert-file :help "Insert file at point marked with enclosing tags"] + ["Attach File..." mml-attach-file t] + ["Insert Screenshot" message-insert-screenshot t] "----" ["Send Message" message-send-and-exit :help "Send this message"] ["Postpone Message" message-dont-send @@ -3976,7 +4044,6 @@ This function uses `mail-citation-hook' if that is non-nil." "Cite function in the standard Message manner." (message-cite-original-1 nil)) -(autoload 'format-spec "format-spec") (autoload 'gnus-date-get-time "gnus-util") (defun message-insert-formatted-citation-line (&optional from date tz) @@ -4001,20 +4068,18 @@ See `message-citation-line-format'." (when (or message-reply-headers (and from date)) (unless from (setq from (mail-header-from message-reply-headers))) - (let* ((data (condition-case () - (funcall (if (boundp 'gnus-extract-address-components) - gnus-extract-address-components - 'mail-extract-address-components) - from) - (error nil))) + (let* ((data (ignore-errors + (funcall (or (bound-and-true-p + gnus-extract-address-components) + #'mail-extract-address-components) + from))) (name (car data)) (fname name) (lname name) - (net (car (cdr data))) - (name-or-net (or (car data) - (car (cdr data)) from)) + (net (cadr data)) + (name-or-net (or name net from)) (time - (when (string-match "%[^fnNFL]" message-citation-line-format) + (when (string-match-p "%[^FLNfn]" message-citation-line-format) (cond ((numberp (car-safe date)) date) ;; backward compatibility (date (gnus-date-get-time date)) (t @@ -4023,68 +4088,53 @@ See `message-citation-line-format'." (tz (or tz (when (stringp date) (nth 8 (parse-time-string date))))) - (flist - (let ((i ?A) lst) - (when (stringp name) - ;; Guess first name and last name: - (let* ((names (delq - nil - (mapcar - (lambda (x) - (if (string-match "\\`\\(\\w\\|[-.]\\)+\\'" - x) - x - nil)) - (split-string name "[ \t]+")))) - (count (length names))) - (cond ((= count 1) - (setq fname (car names) - lname "")) - ((or (= count 2) (= count 3)) - (setq fname (car names) - lname (mapconcat 'identity (cdr names) " "))) - ((> count 3) - (setq fname (mapconcat 'identity - (butlast names (- count 2)) - " ") - lname (mapconcat 'identity - (nthcdr 2 names) - " ")))) - (when (string-match "\\(.*\\),\\'" fname) - (let ((newlname (match-string 1 fname))) - (setq fname lname lname newlname))))) - ;; The following letters are not used in `format-time-string': - (push ?E lst) (push "<E>" lst) - (push ?F lst) (push (or fname name-or-net) lst) - ;; We might want to use "" instead of "<X>" later. - (push ?J lst) (push "<J>" lst) - (push ?K lst) (push "<K>" lst) - (push ?L lst) (push lname lst) - (push ?N lst) (push name-or-net lst) - (push ?O lst) (push "<O>" lst) - (push ?P lst) (push "<P>" lst) - (push ?Q lst) (push "<Q>" lst) - (push ?f lst) (push from lst) - (push ?i lst) (push "<i>" lst) - (push ?n lst) (push net lst) - (push ?o lst) (push "<o>" lst) - (push ?q lst) (push "<q>" lst) - (push ?t lst) (push "<t>" lst) - (push ?v lst) (push "<v>" lst) - ;; Delegate the rest to `format-time-string': - (while (<= i ?z) - (when (and (not (memq i lst)) - ;; Skip (Z,a) - (or (<= i ?Z) - (>= i ?a))) - (push i lst) - (push (condition-case nil - (format-time-string (format "%%%c" i) time tz) - (error (format ">%c<" i))) - lst)) - (setq i (1+ i))) - (reverse lst))) - (spec (apply 'format-spec-make flist))) + spec) + (when (stringp name) + ;; Guess first name and last name: + (let* ((names (seq-filter + (lambda (s) + (string-match-p (rx bos (+ (in word ?. ?-)) eos) s)) + (split-string name "[ \t]+"))) + (count (length names))) + (cond ((= count 1) + (setq fname (car names) + lname "")) + ((or (= count 2) (= count 3)) + (setq fname (car names) + lname (string-join (cdr names) " "))) + ((> count 3) + (setq fname (string-join (butlast names (- count 2)) + " ") + lname (string-join (nthcdr 2 names) " ")))) + (when (string-match "\\(.*\\),\\'" fname) + (let ((newlname (match-string 1 fname))) + (setq fname lname lname newlname))))) + ;; The following letters are not used in `format-time-string': + (push (cons ?E "<E>") spec) + (push (cons ?F (or fname name-or-net)) spec) + ;; We might want to use "" instead of "<X>" later. + (push (cons ?J "<J>") spec) + (push (cons ?K "<K>") spec) + (push (cons ?L lname) spec) + (push (cons ?N name-or-net) spec) + (push (cons ?O "<O>") spec) + (push (cons ?P "<P>") spec) + (push (cons ?Q "<Q>") spec) + (push (cons ?f from) spec) + (push (cons ?i "<i>") spec) + (push (cons ?n net) spec) + (push (cons ?o "<o>") spec) + (push (cons ?q "<q>") spec) + (push (cons ?t "<t>") spec) + (push (cons ?v "<v>") spec) + ;; Delegate the rest to `format-time-string': + (dolist (c (nconc (number-sequence ?A ?Z) + (number-sequence ?a ?z))) + (unless (assq c spec) + (push (cons c (condition-case nil + (format-time-string (format "%%%c" c) time tz) + (error (format ">%c<" c)))) + spec))) (insert (format-spec message-citation-line-format spec))) (newline))) @@ -7006,15 +7056,28 @@ want to get rid of this query permanently."))) ;; Build the header alist. Allow the user to be asked whether ;; or not to reply to all recipients in a wide reply. - (setq follow-to (list (cons 'To (cdr (pop recipients))))) - (when (and recipients - (or (not message-wide-reply-confirm-recipients) - (y-or-n-p "Reply to all recipients? "))) - (setq recipients (mapconcat - (lambda (addr) (cdr addr)) recipients ", ")) - (if (string-match "^ +" recipients) - (setq recipients (substring recipients (match-end 0)))) - (push (cons 'Cc recipients) follow-to))) + (when (or (< (length recipients) 2) + (not message-wide-reply-confirm-recipients) + (y-or-n-p "Reply to all recipients? ")) + (if never-mct + ;; The author has requested never to get a (wide) + ;; response, so put everybody else into the To header. + ;; This avoids looking as if we're To-in somebody else in + ;; specific, and just Cc-in the rest. + (setq follow-to (list + (cons 'To + (mapconcat + (lambda (addr) + (cdr addr)) recipients ", ")))) + ;; Put the first recipient in the To header. + (setq follow-to (list (cons 'To (cdr (pop recipients))))) + ;; Put the rest of the recipients in Cc. + (when recipients + (setq recipients (mapconcat + (lambda (addr) (cdr addr)) recipients ", ")) + (if (string-match "^ +" recipients) + (setq recipients (substring recipients (match-end 0)))) + (push (cons 'Cc recipients) follow-to))))) follow-to)) (defun message-prune-recipients (recipients) @@ -7310,7 +7373,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 +7794,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) @@ -7983,7 +8046,7 @@ See `gmm-tool-bar-from-list' for details on the format of the list." (defcustom message-tool-bar-retro '(;; Old Emacs 21 icon for consistency. - (message-send-and-exit "gnus/mail-send") + (message-send-and-exit "mail/send") (message-kill-buffer "close") (message-dont-send "cancel") (mml-attach-file "attach" mml-mode-map) @@ -8670,6 +8733,108 @@ Used in `message-simplify-recipients'." (* 0.5 (- (nth 3 edges) (nth 1 edges))))) string))))))) +(defun message-insert-screenshot (delay) + "Take a screenshot and insert in the current buffer. +DELAY (the numeric prefix) says how many seconds to wait before +starting the screenshotting process. + +The `message-screenshot-command' variable says what command is +used to take the screenshot." + (interactive "p") + (unless (executable-find (car message-screenshot-command)) + (error "Can't find %s to take the screenshot" + (car message-screenshot-command))) + (cl-decf delay) + (unless (zerop delay) + (dotimes (i delay) + (message "Sleeping %d second%s..." + (- delay i) + (if (= (- delay i) 1) + "" + "s")) + (sleep-for 1))) + (message "Take screenshot") + (let ((image + (with-temp-buffer + (set-buffer-multibyte nil) + (apply #'call-process + (car message-screenshot-command) nil (current-buffer) nil + (cdr message-screenshot-command)) + (buffer-string)))) + (set-mark (point)) + (insert-image + (create-image image 'png t + :max-width (truncate (* (frame-pixel-width) 0.8)) + :max-height (truncate (* (frame-pixel-height) 0.8)) + :scale 1) + (format "<#part type=\"image/png\" disposition=inline data-encoding=base64 raw=t>\n%s\n<#/part>" + ;; Get a base64 version of the image -- this avoids later + ;; complications if we're auto-saving the buffer and + ;; restoring from a file. + (with-temp-buffer + (set-buffer-multibyte nil) + (insert image) + (base64-encode-region (point-min) (point-max) t) + (buffer-string)))) + (insert "\n\n") + (message ""))) + +(declare-function gnus-url-unhex-string "gnus-util") + +(defun message-parse-mailto-url (url) + "Parse a mailto: url." + (setq url (replace-regexp-in-string "\n" " " url)) + (when (string-match "mailto:/*\\(.*\\)" url) + (setq url (substring url (match-beginning 1) nil))) + (setq url (if (string-match "^\\?" url) + (substring url 1) + (if (string-match "^\\([^?]+\\)\\?\\(.*\\)" url) + (concat "to=" (match-string 1 url) "&" + (match-string 2 url)) + (concat "to=" url)))) + (let (retval pairs cur key val) + (setq pairs (split-string url "&")) + (while pairs + (setq cur (car pairs) + pairs (cdr pairs)) + (if (not (string-match "=" cur)) + nil ; Grace + (setq key (downcase (gnus-url-unhex-string + (substring cur 0 (match-beginning 0)))) + val (gnus-url-unhex-string (substring cur (match-end 0) nil) t)) + (setq cur (assoc key retval)) + (if cur + (setcdr cur (cons val (cdr cur))) + (setq retval (cons (list key val) retval))))) + retval)) + +;;;###autoload +(defun message-mailto () + "Command to parse command line mailto: links. +This is meant to be used for MIME handlers: Setting the handler +for \"x-scheme-handler/mailto;\" to \"emacs -f message-mailto %u\" +will then start up Emacs ready to compose mail." + (interactive) + ;; <a href="mailto:someone@example.com?subject=This%20is%20the%20subject&cc=someone_else@example.com&body=This%20is%20the%20body">Send email</a> + (message-mail) + (message-mailto-1 (pop command-line-args-left))) + +(defun message-mailto-1 (url) + (let ((args (message-parse-mailto-url url))) + (dolist (arg args) + (unless (equal (car arg) "body") + (message-position-on-field (capitalize (car arg))) + (insert (replace-regexp-in-string + "\r\n" "\n" + (mapconcat #'identity (reverse (cdr arg)) ", ") nil t)))) + (when (assoc "body" args) + (message-goto-body) + (dolist (body (cdr (assoc "body" args))) + (insert body "\n"))) + (if (assoc "subject" args) + (message-goto-body) + (message-goto-subject)))) + (provide 'message) (run-hooks 'message-load-hook) diff --git a/lisp/gnus/mm-archive.el b/lisp/gnus/mm-archive.el index 6b4308e9790..56253afa193 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 @@ -41,8 +42,9 @@ dir) (unless decoder (error "No decoder found for %s" type)) - (setq dir (make-temp-file (expand-file-name "emm." mm-tmp-directory) 'dir)) - (set-file-modes dir #o700) + (with-file-modes #o700 + (setq dir (make-temp-file (expand-file-name "emm." mm-tmp-directory) + 'dir))) (unwind-protect (progn (mm-with-unibyte-buffer @@ -56,7 +58,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-decode.el b/lisp/gnus/mm-decode.el index a340418507f..7f8ab5f9ef5 100644 --- a/lisp/gnus/mm-decode.el +++ b/lisp/gnus/mm-decode.el @@ -602,11 +602,10 @@ files left at the next time." (push temp fails))) (if fails ;; Schedule the deletion of the files left at the next time. - (progn + (with-file-modes #o600 (write-region (concat (mapconcat 'identity (nreverse fails) "\n") "\n") - nil cache-file nil 'silent) - (set-file-modes cache-file #o600)) + nil cache-file nil 'silent)) (when (file-exists-p cache-file) (ignore-errors (delete-file cache-file)))) (setq mm-temp-files-to-be-deleted nil))) @@ -911,8 +910,10 @@ external if displayed external." ;; The function is a string to be executed. (mm-insert-part handle) (mm-add-meta-html-tag handle) - (let* ((dir (make-temp-file - (expand-file-name "emm." mm-tmp-directory) 'dir)) + ;; We create a private sub-directory where we store our files. + (let* ((dir (with-file-modes #o700 + (make-temp-file + (expand-file-name "emm." mm-tmp-directory) 'dir))) (filename (or (mail-content-type-get (mm-handle-disposition handle) 'filename) @@ -924,8 +925,6 @@ external if displayed external." (assoc "needsterminal" mime-info))) (copiousoutput (assoc "copiousoutput" mime-info)) file buffer) - ;; We create a private sub-directory where we store our files. - (set-file-modes dir #o700) (if filename (setq file (expand-file-name (gnus-map-function mm-file-name-rewrite-functions @@ -941,14 +940,15 @@ external if displayed external." ;; `mailcap-mime-extensions'. (setq suffix (car (rassoc (mm-handle-media-type handle) mailcap-mime-extensions)))) - (setq file (make-temp-file (expand-file-name "mm." dir) - nil suffix)))) + (setq file (with-file-modes #o600 + (make-temp-file (expand-file-name "mm." dir) + nil suffix))))) (let ((coding-system-for-write mm-binary-coding-system)) (write-region (point-min) (point-max) file nil 'nomesg)) ;; The file is deleted after the viewer exists. If the users edits ;; the file, changes will be lost. Set file to read-only to make it ;; clear. - (set-file-modes file #o400) + (set-file-modes file #o400 'nofollow) (message "Viewing with %s" method) (cond (needsterm @@ -1680,6 +1680,12 @@ If RECURSIVE, search recursively." (t (y-or-n-p (format "Decrypt (S/MIME) part? ")))) (mm-view-pkcs7 parts from)) + (goto-char (point-min)) + ;; The encrypted document is a MIME part, and may use either + ;; CRLF (Outlook and the like) or newlines for end-of-line + ;; markers. Translate from CRLF. + (while (search-forward "\r\n" nil t) + (replace-match "\n")) ;; Normally there will be a Content-type header here, but ;; some mailers don't add that to the encrypted part, which ;; makes the subsequent re-dissection fail here. diff --git a/lisp/gnus/mm-util.el b/lisp/gnus/mm-util.el index 7629d5cb151..282465722de 100644 --- a/lisp/gnus/mm-util.el +++ b/lisp/gnus/mm-util.el @@ -131,10 +131,6 @@ is not available." (cond ((null charset) charset) - ;; Running in a non-MULE environment. - ((or (null (mm-get-coding-system-list)) - (not (fboundp 'coding-system-get))) - charset) ;; Check override list quite early. Should only used for decoding, not for ;; encoding! ((and allow-override @@ -295,77 +291,16 @@ superset of iso-8859-1." (defvar mm-universal-coding-system mm-auto-save-coding-system "The universal coding system.") -;; Fixme: some of the cars here aren't valid MIME charsets. That -;; should only matter with XEmacs, though. (defvar mm-mime-mule-charset-alist - '((us-ascii ascii) - (iso-8859-1 latin-iso8859-1) - (iso-8859-2 latin-iso8859-2) - (iso-8859-3 latin-iso8859-3) - (iso-8859-4 latin-iso8859-4) - (iso-8859-5 cyrillic-iso8859-5) - ;; Non-mule (X)Emacs uses the last mule-charset for 8bit characters. - ;; The fake mule-charset, gnus-koi8-r, tells Gnus that the default - ;; charset is koi8-r, not iso-8859-5. - (koi8-r cyrillic-iso8859-5 gnus-koi8-r) - (iso-8859-6 arabic-iso8859-6) - (iso-8859-7 greek-iso8859-7) - (iso-8859-8 hebrew-iso8859-8) - (iso-8859-9 latin-iso8859-9) - (iso-8859-14 latin-iso8859-14) - (iso-8859-15 latin-iso8859-15) - (viscii vietnamese-viscii-lower) - (iso-2022-jp latin-jisx0201 japanese-jisx0208 japanese-jisx0208-1978) - (euc-kr korean-ksc5601) - (gb2312 chinese-gb2312) - (gbk chinese-gbk) - (gb18030 gb18030-2-byte - gb18030-4-byte-bmp gb18030-4-byte-smp - gb18030-4-byte-ext-1 gb18030-4-byte-ext-2) - (big5 chinese-big5-1 chinese-big5-2) - (tibetan tibetan) - (thai-tis620 thai-tis620) - (windows-1251 cyrillic-iso8859-5) - (iso-2022-7bit ethiopic arabic-1-column arabic-2-column) - (iso-2022-jp-2 latin-iso8859-1 greek-iso8859-7 - latin-jisx0201 japanese-jisx0208-1978 - chinese-gb2312 japanese-jisx0208 - korean-ksc5601 japanese-jisx0212) - (iso-2022-int-1 latin-iso8859-1 greek-iso8859-7 - latin-jisx0201 japanese-jisx0208-1978 - chinese-gb2312 japanese-jisx0208 - korean-ksc5601 japanese-jisx0212 - chinese-cns11643-1 chinese-cns11643-2) - (iso-2022-int-1 latin-iso8859-1 latin-iso8859-2 - cyrillic-iso8859-5 greek-iso8859-7 - latin-jisx0201 japanese-jisx0208-1978 - chinese-gb2312 japanese-jisx0208 - korean-ksc5601 japanese-jisx0212 - chinese-cns11643-1 chinese-cns11643-2 - chinese-cns11643-3 chinese-cns11643-4 - chinese-cns11643-5 chinese-cns11643-6 - chinese-cns11643-7) - (iso-2022-jp-3 latin-jisx0201 japanese-jisx0208-1978 japanese-jisx0208 - japanese-jisx0213-1 japanese-jisx0213-2) - (shift_jis latin-jisx0201 katakana-jisx0201 japanese-jisx0208) - (utf-8)) - "Alist of MIME-charset/MULE-charsets.") - -;; Correct by construction, but should be unnecessary for Emacs: -(when (and (fboundp 'coding-system-list) - (fboundp 'sort-coding-systems)) - (let ((css (sort-coding-systems (coding-system-list 'base-only))) - cs mime mule alist) - (while css - (setq cs (pop css) - mime (or (coding-system-get cs :mime-charset) ; Emacs 23 (unicode) - (coding-system-get cs 'mime-charset))) + (let (mime mule alist) + (dolist (cs (sort-coding-systems (coding-system-list 'base-only))) + (setq mime (coding-system-get cs 'mime-charset)) (when (and mime - (not (eq t (setq mule - (coding-system-get cs 'safe-charsets)))) + (not (eq t (setq mule (coding-system-get cs 'safe-charsets)))) (not (assq mime alist))) (push (cons mime (delq 'ascii mule)) alist))) - (setq mm-mime-mule-charset-alist (nreverse alist)))) + (nreverse alist)) + "Alist of MIME-charset/MULE-charsets.") (defvar mm-hack-charsets '(iso-8859-15 iso-2022-jp-2) "A list of special charsets. diff --git a/lisp/gnus/mm-uu.el b/lisp/gnus/mm-uu.el index e6fdc93da24..aedd6c948c2 100644 --- a/lisp/gnus/mm-uu.el +++ b/lisp/gnus/mm-uu.el @@ -192,7 +192,7 @@ This can be either \"inline\" or \"attachment\".") ,(lambda () (mm-uu-verbatim-marks-extract 0 0)) nil) (LaTeX - "^\\([\\\\%][^\n]+\n\\)*\\\\documentclass.*[[{%]" + "^\\([\\%][^\n]+\n\\)*\\\\documentclass.*[[{%]" "^\\\\end{document}" ,#'mm-uu-latex-extract nil @@ -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/mm-view.el b/lisp/gnus/mm-view.el index 828ac633dc5..bd5960c18b2 100644 --- a/lisp/gnus/mm-view.el +++ b/lisp/gnus/mm-view.el @@ -59,11 +59,16 @@ "The attributes of renderer types for text/html.") (defcustom mm-fill-flowed t - "If non-nil a format=flowed article will be displayed flowed." + "If non-nil, format=flowed articles will be displayed flowed." :type 'boolean :version "22.1" :group 'mime-display) +;; Not a defcustom, since it's usually overridden by the callers of +;; the mm functions. +(defvar mm-inline-font-lock t + "If non-nil, do font locking of inline media types that support it.") + (defcustom mm-inline-large-images-proportion 0.9 "Maximum proportion large images can occupy in the buffer. This is only used if `mm-inline-large-images' is set to @@ -502,7 +507,8 @@ If MODE is not set, try to find mode automatically." (delay-mode-hooks (set-auto-mode)) (setq mode major-mode))) ;; Do not fontify if the guess mode is fundamental. - (unless (eq major-mode 'fundamental-mode) + (when (and (not (eq major-mode 'fundamental-mode)) + mm-inline-font-lock) (font-lock-ensure)))) (setq text (buffer-string)) (when (eq mode 'diff-mode) diff --git a/lisp/gnus/mml-sec.el b/lisp/gnus/mml-sec.el index 740e1d2b722..69852c381d6 100644 --- a/lisp/gnus/mml-sec.el +++ b/lisp/gnus/mml-sec.el @@ -665,8 +665,9 @@ The passphrase is read and cached." (epg-user-id-string uid)))) (equal (downcase (car (mail-header-parse-address (epg-user-id-string uid)))) - (downcase (car (mail-header-parse-address - recipient)))) + (downcase (or (car (mail-header-parse-address + recipient)) + recipient))) (not (memq (epg-user-id-validity uid) '(revoked expired)))) (throw 'break t)))))) @@ -937,6 +938,10 @@ If no one is selected, symmetric encryption will be performed. " (signal (car error) (cdr error)))) cipher)) +;; Should probably be removed and the interface should be different. +(defvar mml-secure-allow-signing-with-unknown-recipient nil + "Variable to bind to allow automatic recipient selection.") + (defun mml-secure-epg-sign (protocol mode) ;; Based on code appearing inside mml2015-epg-sign. (let* ((context (epg-make-context protocol)) @@ -953,7 +958,8 @@ If no one is selected, symmetric encryption will be performed. " ;; then there's no point advising the user to examine it. If ;; there are any other variables worth examining, please ;; improve this error message by having it mention them. - (error "Couldn't find any signer names%s" maybe-msg))) + (unless mml-secure-allow-signing-with-unknown-recipient + (error "Couldn't find any signer names%s" maybe-msg)))) (when (eq 'OpenPGP protocol) (setf (epg-context-armor context) t) (setf (epg-context-textmode context) t) 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/mml.el b/lisp/gnus/mml.el index 556cf0804a5..ef8aa6ac019 100644 --- a/lisp/gnus/mml.el +++ b/lisp/gnus/mml.el @@ -295,6 +295,17 @@ part. This is for the internal use, you should never modify the value.") (t (mm-find-mime-charset-region point (point) mm-hack-charsets)))) + ;; We have a part that already has a transfer encoding. Undo + ;; that so that we don't double-encode later. + (when (and raw + (cdr (assq 'data-encoding tag))) + (with-temp-buffer + (set-buffer-multibyte nil) + (insert contents) + (mm-decode-content-transfer-encoding + (intern (cdr (assq 'data-encoding tag))) + (cdr (assq 'type tag))) + (setq contents (buffer-string)))) (when (and (not raw) (memq nil charsets)) (if (or (memq 'unknown-encoding mml-confirmation-set) (message-options-get 'unknown-encoding) @@ -313,8 +324,8 @@ Message contains characters with unknown encoding. Really send? ") (eq 'mml (car tag)) (< (length charsets) 2)) (if (or (not no-markup-p) + ;; Don't create blank parts. (string-match "[^ \t\r\n]" contents)) - ;; Don't create blank parts. (push (nconc tag (list (cons 'contents contents))) struct)) (let ((nstruct (mml-parse-singlepart-with-multiple-charsets @@ -487,11 +498,8 @@ type detected." (= (length cont) 1) content-type) (setcdr (assq 'type (cdr (car cont))) content-type)) - (when (and (consp (car cont)) - (= (length cont) 1) - (fboundp 'libxml-parse-html-region) - (equal (cdr (assq 'type (car cont))) "text/html")) - (setq cont (mml-expand-html-into-multipart-related (car cont)))) + (when (fboundp 'libxml-parse-html-region) + (setq cont (mapcar 'mml-expand-all-html-into-multipart-related cont))) (prog1 (with-temp-buffer (set-buffer-multibyte nil) @@ -510,6 +518,18 @@ type detected." (buffer-string)) (setq message-options options))))) +(defun mml-expand-all-html-into-multipart-related (cont) + (cond ((and (eq (car cont) 'part) + (equal (cdr (assq 'type cont)) "text/html")) + (mml-expand-html-into-multipart-related cont)) + ((eq (car cont) 'multipart) + (let ((cur (cdr cont))) + (while (consp cur) + (setcar cur (mml-expand-all-html-into-multipart-related (car cur))) + (setf cur (cdr cur)))) + cont) + (t cont))) + (defun mml-expand-html-into-multipart-related (cont) (let ((new-parts nil) (cid 1)) @@ -538,8 +558,7 @@ type detected." new-parts)) (setq cid (1+ cid))))))) ;; We have local images that we want to include. - (if (not new-parts) - (list cont) + (when new-parts (setcdr (assq 'contents cont) (buffer-string)) (setq cont (nconc (list 'multipart (cons 'type "related")) @@ -552,8 +571,8 @@ type detected." (nth 1 new-part) (nth 2 new-part)) (id . ,(concat "<" (nth 0 new-part) - ">"))))))) - cont)))) + ">")))))))) + cont))) (autoload 'image-property "image") 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..480d794b9ac 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) @@ -544,7 +544,7 @@ (setq buffer-file-name nnbabyl-mbox-file) (insert "BABYL OPTIONS:\n\n\^_") (nnmail-write-region - (point-min) (point-max) nnbabyl-mbox-file t 'nomesg)))) + (point-min) (point-max) nnbabyl-mbox-file t 'nomesg nil 'excl)))) (defun nnbabyl-read-mbox () (nnmail-activate 'nnbabyl) diff --git a/lisp/gnus/nndiary.el b/lisp/gnus/nndiary.el index 24a3df1e27a..945ef0351e5 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 @@ -1115,7 +1115,7 @@ all. This may very well take some time.") (widen)) (setq files (cdr files))) (with-current-buffer nov-buffer - (nnmail-write-region 1 (point-max) nov nil 'nomesg) + (nnmail-write-region 1 (point-max) nov nil 'nomesg nil 'excl) (kill-buffer (current-buffer)))))) (defun nndiary-nov-delete-article (group article) 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 a1337e8d7fa..a3c26ea4ac0 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..c27af1742d8 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) @@ -735,7 +735,7 @@ deleted. Point is left where the deleted region was." (or nnfolder-file-coding-system-for-write nnfolder-file-coding-system-for-write))) (nnmail-write-region (point-min) (point-min) - file t 'nomesg))) + file t 'nomesg nil 'excl))) (when (setq nnfolder-current-buffer (nnfolder-read-folder group)) (set-buffer nnfolder-current-buffer) (push (list group nnfolder-current-buffer) @@ -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..be8ad9a6723 100644 --- a/lisp/gnus/nnimap.el +++ b/lisp/gnus/nnimap.el @@ -1670,8 +1670,7 @@ If LIMIT, first try to limit the search to the N last articles." (when (and active recent (> (car (last recent)) (cdr active))) - (push (list (cons (gnus-group-real-name group) 0)) - nnmail-split-history))) + (push (list (cons group 0)) nnmail-split-history))) ;; Note the active level for the next run-through. (gnus-group-set-parameter info 'active (gnus-active group)) (gnus-group-set-parameter info 'uidvalidity uidvalidity) @@ -1937,7 +1936,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 f1e31a0cd10..722969c21ba 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..b6308140fc9 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)) @@ -1749,7 +1749,15 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (nreverse (nnmail-article-group artnum-func)))))) ;; Add the group-art list to the history list. (if group-art - (push group-art nnmail-split-history) + ;; We need to get the unique Gnus group name for this article + ;; -- there may be identically named groups from several + ;; backends. + (push (mapcar + (lambda (ga) + (cons (gnus-group-prefixed-name (car ga) gnus-command-method) + (cdr ga))) + group-art) + nnmail-split-history) (delete-region (point-min) (point-max))))) ;;; Get new mail. @@ -1953,12 +1961,14 @@ If TIME is nil, then return the cutoff time for oldness instead." (unless (re-search-forward "^Message-ID[ \t]*:" nil t) (insert "Message-ID: " (nnmail-message-id) "\n"))))) -(defun nnmail-write-region (start end filename &optional append visit lockname) +(defun nnmail-write-region (start end filename + &optional append visit lockname mustbenew) "Do a `write-region', and then set the file modes." (let ((coding-system-for-write nnmail-file-coding-system) (file-name-coding-system nnmail-pathname-coding-system)) - (write-region start end filename append visit lockname) - (set-file-modes filename nnmail-default-file-modes))) + (write-region start end filename append visit lockname mustbenew) + (set-file-modes filename nnmail-default-file-modes + (when (eq mustbenew 'excl) 'nofollow)))) ;;; ;;; Status functions @@ -2065,7 +2075,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..8b3d80266e7 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) @@ -613,7 +613,7 @@ (dir (file-name-directory nnmbox-mbox-file))) (and dir (gnus-make-directory dir)) (nnmail-write-region (point-min) (point-min) - nnmbox-mbox-file t 'nomesg)))) + nnmbox-mbox-file t 'nomesg nil 'excl)))) (defun nnmbox-read-mbox () (nnmail-activate 'nnmbox) diff --git a/lisp/gnus/nnmh.el b/lisp/gnus/nnmh.el index 8e7f0565e67..581a408009d 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..baf5d54b74d 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. @@ -902,7 +901,7 @@ Unless no-active is non-nil, update the active file too." (nnheader-insert-nov headers))) (widen)))) (with-current-buffer nov-buffer - (nnmail-write-region (point-min) (point-max) nov nil 'nomesg) + (nnmail-write-region (point-min) (point-max) nov nil 'nomesg nil 'excl) (kill-buffer (current-buffer)))))) (defun nnml-nov-delete-article (group article) 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..a5c82447926 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"))) @@ -1247,8 +1247,8 @@ If SEND-IF-FORCE, only send authinfo to the server if the (and nntp-connection-timeout (run-at-time nntp-connection-timeout nil - `(lambda () - (nntp-kill-buffer ,pbuffer))))) + (lambda () + (nntp-kill-buffer pbuffer))))) (process (condition-case err (let ((coding-system-for-read 'binary) @@ -1263,7 +1263,17 @@ If SEND-IF-FORCE, only send authinfo to the server if the "nntpd" pbuffer nntp-address nntp-port-number :type (cadr (assoc nntp-open-connection-function map)) :end-of-command "^\\([2345]\\|[.]\\).*\n" - :capability-command "HELP\r\n" + :capability-command + (lambda (greeting) + (if (and greeting + (string-match "Typhoon" greeting)) + ;; Certain versions of the Typhoon server + ;; doesn't understand the CAPABILITIES + ;; command, but includes the capability + ;; data in the HELP command instead. + "HELP\r\n" + ;; Use the correct command for everything else. + "CAPABILITIES\r\n")) :success "^3" :starttls-function (lambda (capabilities) 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/smime.el b/lisp/gnus/smime.el index fe6daf6b037..5500148e518 100644 --- a/lisp/gnus/smime.el +++ b/lisp/gnus/smime.el @@ -185,6 +185,9 @@ and the files themselves should be in PEM format." :version "22.1" :type '(choice (const :tag "Triple DES" "-des3") (const :tag "DES" "-des") + (const :tag "AES 256 bits" "-aes256") + (const :tag "AES 192 bits" "-aes192") + (const :tag "AES 128 bits" "-aes128") (const :tag "RC2 40 bits" "-rc2-40") (const :tag "RC2 64 bits" "-rc2-64") (const :tag "RC2 128 bits" "-rc2-128")) 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 c7d0112cb61..a137c504888 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -364,6 +364,7 @@ suitable file is found, return nil." (help-C-file-name type 'subr) 'C-source)) ((and (not file-name) (symbolp object) + (eq type 'defvar) (integerp (get object 'variable-documentation))) ;; A variable defined in C. The form is from `describe-variable'. (if (get-buffer " *DOC*") @@ -647,8 +648,7 @@ FILE is the file where FUNCTION was probably defined." (setq place (list f pos)) (setq first version))))))))) (when first - (make-text-button first nil 'type 'help-news 'help-args place)) - first)) + (make-text-button first nil 'type 'help-news 'help-args place)))) (add-hook 'help-fns-describe-function-functions #'help-fns--mention-first-release) @@ -893,7 +893,7 @@ If ANY-SYMBOL is non-nil, don't insist the symbol be bound." (output nil)) (if custom-version (setq output - (format "This %s was introduced, or its default value was changed, in\nversion %s of Emacs.\n" + (format " This %s was introduced, or its default value was changed, in\n version %s of Emacs.\n" type custom-version)) (when cpv (let* ((package (car-safe cpv)) @@ -904,7 +904,7 @@ If ANY-SYMBOL is non-nil, don't insist the symbol be bound." (emacsv (cdr (assoc version pkg-versions)))) (if (and package version) (setq output - (format (concat "This %s was introduced, or its default value was changed, in\nversion %s of the %s package" + (format (concat " This %s was introduced, or its default value was changed, in\n version %s of the %s package" (if emacsv (format " that is part of Emacs %s" emacsv)) ".\n") @@ -944,7 +944,7 @@ it is displayed along with the global value." (unless (buffer-live-p buffer) (setq buffer (current-buffer))) (unless (frame-live-p frame) (setq frame (selected-frame))) (if (not (symbolp variable)) - (message "You did not specify a variable") + (user-error "You didn't specify a variable") (save-excursion (let ((valvoid (not (with-current-buffer buffer (boundp variable)))) val val-start-pos locus) @@ -968,7 +968,7 @@ it is displayed along with the global value." " is a variable defined in `%s'.\n" (if (eq file-name 'C-source) "C source code" - (file-name-nondirectory file-name)))) + (help-fns-short-filename file-name)))) (with-current-buffer standard-output (save-excursion (re-search-backward (substitute-command-keys @@ -1125,8 +1125,8 @@ it is displayed along with the global value." ;; Note variable's version or package version. (let ((output (describe-variable-custom-version-info variable))) (when output - (terpri) - (terpri) + ;; (terpri) + ;; (terpri) (princ output))))) (add-hook 'help-fns-describe-variable-functions #'help-fns--var-safe-local) @@ -1352,7 +1352,7 @@ If FRAME is omitted or nil, use the selected frame." (setq file-name (find-lisp-object-file-name f 'defface)) (when file-name (princ (substitute-command-keys "Defined in `")) - (princ (file-name-nondirectory file-name)) + (princ (help-fns-short-filename file-name)) (princ (substitute-command-keys "'")) ;; Make a hyperlink to the library. (save-excursion @@ -1435,7 +1435,7 @@ current buffer and the selected frame, respectively." t nil nil (if found (symbol-name v-or-f))))) (list (if (equal val "") - v-or-f (intern val))))) + (or v-or-f "") (intern val))))) (if (not (symbolp symbol)) (user-error "You didn't specify a function or variable")) (unless (buffer-live-p buffer) (setq buffer (current-buffer))) @@ -1564,7 +1564,256 @@ 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" + (help-fns-short-filename 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)))) +;;;###autoload +(defun describe-mode (&optional buffer) + "Display documentation of current major mode and minor modes. +A brief summary of the minor modes comes first, followed by the +major mode description. This is followed by detailed +descriptions of the minor modes, each on a separate page. + +For this to work correctly for a minor mode, the mode's indicator +variable \(listed in `minor-mode-alist') must also be a function +whose documentation describes the minor mode. + +If called from Lisp with a non-nil BUFFER argument, display +documentation for the major and minor modes of that buffer." + (interactive "@") + (unless buffer (setq buffer (current-buffer))) + (help-setup-xref (list #'describe-mode buffer) + (called-interactively-p 'interactive)) + ;; For the sake of help-do-xref and help-xref-go-back, + ;; don't switch buffers before calling `help-buffer'. + (with-help-window (help-buffer) + (with-current-buffer buffer + (let (minor-modes) + ;; Older packages do not register in minor-mode-list but only in + ;; minor-mode-alist. + (dolist (x minor-mode-alist) + (setq x (car x)) + (unless (memq x minor-mode-list) + (push x minor-mode-list))) + ;; Find enabled minor mode we will want to mention. + (dolist (mode minor-mode-list) + ;; Document a minor mode if it is listed in minor-mode-alist, + ;; non-nil, and has a function definition. + (let ((fmode (or (get mode :minor-mode-function) mode))) + (and (boundp mode) (symbol-value mode) + (fboundp fmode) + (let ((pretty-minor-mode + (if (string-match "\\(\\(-minor\\)?-mode\\)?\\'" + (symbol-name fmode)) + (capitalize + (substring (symbol-name fmode) + 0 (match-beginning 0))) + fmode))) + (push (list fmode pretty-minor-mode + (format-mode-line (assq mode minor-mode-alist))) + minor-modes))))) + ;; Narrowing is not a minor mode, but its indicator is part of + ;; mode-line-modes. + (when (buffer-narrowed-p) + (push '(narrow-to-region "Narrow" " Narrow") minor-modes)) + (setq minor-modes + (sort minor-modes + (lambda (a b) (string-lessp (cadr a) (cadr b))))) + (when minor-modes + (princ "Enabled minor modes:\n") + (make-local-variable 'help-button-cache) + (with-current-buffer standard-output + (dolist (mode minor-modes) + (let ((mode-function (nth 0 mode)) + (pretty-minor-mode (nth 1 mode)) + (indicator (nth 2 mode))) + (save-excursion + (goto-char (point-max)) + (princ "\n\f\n") + (push (point-marker) help-button-cache) + ;; Document the minor modes fully. + (insert-text-button + pretty-minor-mode 'type 'help-function + 'help-args (list mode-function) + 'button '(t)) + (princ (format " minor mode (%s):\n" + (if (zerop (length indicator)) + "no indicator" + (format "indicator%s" + indicator)))) + (princ (help-split-fundoc (documentation mode-function) + nil 'doc))) + (insert-button pretty-minor-mode + 'action (car help-button-cache) + 'follow-link t + 'help-echo "mouse-2, RET: show full information") + (newline))) + (forward-line -1) + (fill-paragraph nil) + (forward-line 1)) + + (princ "\n(Information about these minor modes follows the major mode info.)\n\n")) + ;; Document the major mode. + (let ((mode mode-name)) + (with-current-buffer standard-output + (let ((start (point))) + (insert (format-mode-line mode nil nil buffer)) + (add-text-properties start (point) '(face bold))))) + (princ " mode") + (let* ((mode major-mode) + (file-name (find-lisp-object-file-name mode nil))) + (when file-name + (princ (format-message " defined in `%s'" + (help-fns-short-filename file-name))) + ;; Make a hyperlink to the library. + (with-current-buffer standard-output + (save-excursion + (re-search-backward (substitute-command-keys "`\\([^`']+\\)'") + nil t) + (help-xref-button 1 'help-function-def mode file-name))))) + (princ ":\n") + (princ (help-split-fundoc (documentation major-mode) nil 'doc))))) + ;; For the sake of IELM and maybe others + nil) + +;; Widgets. + +(defvar describe-widget-functions + '(button-describe widget-describe) + "A list of functions for `describe-widget' to call. +Each function should take one argument, a buffer position, and return +non-nil if it described a widget at that position.") + +;;;###autoload +(defun describe-widget (&optional pos) + "Display a buffer with information about a widget. +You can use this command to describe buttons (e.g., the links in a *Help* +buffer), editable fields of the customization buffers, etc. + +Interactively, click on a widget to describe it, or hit RET to describe the +widget at point. + +When called from Lisp, POS may be a buffer position or a mouse position list. + +Calls each function of the list `describe-widget-functions' in turn, until +one of them returns non-nil." + (interactive + (list + (let ((key + (read-key + "Click on a widget, or hit RET to describe the widget at point"))) + (cond ((eq key ?\C-m) (point)) + ((and (mouse-event-p key) + (eq (event-basic-type key) 'mouse-1) + (equal (event-modifiers key) '(click))) + (event-end key)) + ((eq key ?\C-g) (signal 'quit nil)) + (t (user-error "You didn't specify a widget")))))) + (let (buf) + ;; Allow describing a widget in a different window. + (when (posnp pos) + (setq buf (window-buffer (posn-window pos)) + pos (posn-point pos))) + (with-current-buffer (or buf (current-buffer)) + (unless (cl-some (lambda (fun) (when (fboundp fun) (funcall fun pos))) + describe-widget-functions) + (message "No widget found at that position"))))) + + ;;; Replacements for old lib-src/ programs. Don't seem especially useful. ;; Replaces lib-src/digest-doc.c. diff --git a/lisp/help-mode.el b/lisp/help-mode.el index bae8281147a..9c2d1d72275 100644 --- a/lisp/help-mode.el +++ b/lisp/help-mode.el @@ -1,4 +1,4 @@ -;;; help-mode.el --- `help-mode' used by *Help* buffers +;;; help-mode.el --- `help-mode' used by *Help* buffers -*- lexical-binding: t; -*- ;; Copyright (C) 1985-1986, 1993-1994, 1998-2020 Free Software ;; Foundation, Inc. @@ -47,10 +47,10 @@ (define-key map "\C-c\C-c" 'help-follow-symbol) (define-key map "\r" 'help-follow) map) - "Keymap for help mode.") + "Keymap for Help mode.") (easy-menu-define help-mode-menu help-mode-map - "Menu for Help Mode." + "Menu for Help mode." '("Help-Mode" ["Show Help for Symbol" help-follow-symbol :help "Show the docs for the symbol at point"] @@ -327,13 +327,13 @@ Commands: ;;;###autoload (defun help-mode-setup () - "Enter Help Mode in the current buffer." + "Enter Help mode in the current buffer." (help-mode) (setq buffer-read-only nil)) ;;;###autoload (defun help-mode-finish () - "Finalize Help Mode setup in current buffer." + "Finalize Help mode setup in current buffer." (when (derived-mode-p 'help-mode) (setq buffer-read-only t) (help-make-xrefs (current-buffer)))) @@ -719,7 +719,8 @@ a proper [back] button." ;; There is a reference at point. Follow it. (let ((help-xref-following t)) (apply function (if (eq function 'info) - (append args (list (generate-new-buffer-name "*info*"))) args)))) + (append args (list (generate-new-buffer-name "*info*"))) + args)))) ;; The doc string is meant to explain what buttons do. (defun help-follow-mouse () diff --git a/lisp/help.el b/lisp/help.el index 0f1991e3185..b7d867eb70e 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -879,114 +879,6 @@ current buffer." (princ ", which is ") (describe-function-1 defn))))))) -(defun describe-mode (&optional buffer) - "Display documentation of current major mode and minor modes. -A brief summary of the minor modes comes first, followed by the -major mode description. This is followed by detailed -descriptions of the minor modes, each on a separate page. - -For this to work correctly for a minor mode, the mode's indicator -variable \(listed in `minor-mode-alist') must also be a function -whose documentation describes the minor mode. - -If called from Lisp with a non-nil BUFFER argument, display -documentation for the major and minor modes of that buffer." - (interactive "@") - (unless buffer (setq buffer (current-buffer))) - (help-setup-xref (list #'describe-mode buffer) - (called-interactively-p 'interactive)) - ;; For the sake of help-do-xref and help-xref-go-back, - ;; don't switch buffers before calling `help-buffer'. - (with-help-window (help-buffer) - (with-current-buffer buffer - (let (minor-modes) - ;; Older packages do not register in minor-mode-list but only in - ;; minor-mode-alist. - (dolist (x minor-mode-alist) - (setq x (car x)) - (unless (memq x minor-mode-list) - (push x minor-mode-list))) - ;; Find enabled minor mode we will want to mention. - (dolist (mode minor-mode-list) - ;; Document a minor mode if it is listed in minor-mode-alist, - ;; non-nil, and has a function definition. - (let ((fmode (or (get mode :minor-mode-function) mode))) - (and (boundp mode) (symbol-value mode) - (fboundp fmode) - (let ((pretty-minor-mode - (if (string-match "\\(\\(-minor\\)?-mode\\)?\\'" - (symbol-name fmode)) - (capitalize - (substring (symbol-name fmode) - 0 (match-beginning 0))) - fmode))) - (push (list fmode pretty-minor-mode - (format-mode-line (assq mode minor-mode-alist))) - minor-modes))))) - ;; Narrowing is not a minor mode, but its indicator is part of - ;; mode-line-modes. - (when (buffer-narrowed-p) - (push '(narrow-to-region "Narrow" " Narrow") minor-modes)) - (setq minor-modes - (sort minor-modes - (lambda (a b) (string-lessp (cadr a) (cadr b))))) - (when minor-modes - (princ "Enabled minor modes:\n") - (make-local-variable 'help-button-cache) - (with-current-buffer standard-output - (dolist (mode minor-modes) - (let ((mode-function (nth 0 mode)) - (pretty-minor-mode (nth 1 mode)) - (indicator (nth 2 mode))) - (save-excursion - (goto-char (point-max)) - (princ "\n\f\n") - (push (point-marker) help-button-cache) - ;; Document the minor modes fully. - (insert-text-button - pretty-minor-mode 'type 'help-function - 'help-args (list mode-function) - 'button '(t)) - (princ (format " minor mode (%s):\n" - (if (zerop (length indicator)) - "no indicator" - (format "indicator%s" - indicator)))) - (princ (help-split-fundoc (documentation mode-function) - nil 'doc))) - (insert-button pretty-minor-mode - 'action (car help-button-cache) - 'follow-link t - 'help-echo "mouse-2, RET: show full information") - (newline))) - (forward-line -1) - (fill-paragraph nil) - (forward-line 1)) - - (princ "\n(Information about these minor modes follows the major mode info.)\n\n")) - ;; Document the major mode. - (let ((mode mode-name)) - (with-current-buffer standard-output - (let ((start (point))) - (insert (format-mode-line mode nil nil buffer)) - (add-text-properties start (point) '(face bold))))) - (princ " mode") - (let* ((mode major-mode) - (file-name (find-lisp-object-file-name mode nil))) - (when file-name - (princ (format-message " defined in `%s'" - (file-name-nondirectory file-name))) - ;; Make a hyperlink to the library. - (with-current-buffer standard-output - (save-excursion - (re-search-backward (substitute-command-keys "`\\([^`']+\\)'") - nil t) - (help-xref-button 1 'help-function-def mode file-name))))) - (princ ":\n") - (princ (help-split-fundoc (documentation major-mode) nil 'doc))))) - ;; For the sake of IELM and maybe others - nil) - (defun search-forward-help-for-help () "Search forward \"help window\"." (interactive) diff --git a/lisp/hexl.el b/lisp/hexl.el index 2535d581db4..38eca77e260 100644 --- a/lisp/hexl.el +++ b/lisp/hexl.el @@ -367,8 +367,8 @@ You can use \\[hexl-find-file] to visit a file in Hexl mode. (add-hook 'change-major-mode-hook #'hexl-maybe-dehexlify-buffer nil t) ;; Set a callback function for eldoc. - (add-function :before-until (local 'eldoc-documentation-function) - #'hexl-print-current-point-info) + (add-hook 'eldoc-documentation-functions + #'hexl-print-current-point-info nil t) (eldoc-add-command-completions "hexl-") (eldoc-remove-command "hexl-save-buffer" "hexl-current-address") @@ -455,6 +455,8 @@ and edit the file in `hexl-mode'." ;; 2. reset change-major-mode-hook in case that `hexl-mode' ;; previously added hexl-maybe-dehexlify-buffer to it. (remove-hook 'change-major-mode-hook #'hexl-maybe-dehexlify-buffer t) + (remove-hook 'eldoc-documentation-functions + #'hexl-print-current-point-info t) (setq major-mode 'fundamental-mode) (hexl-mode))) @@ -513,7 +515,7 @@ Ask the user for confirmation." (message "Current address is %d/0x%08x" hexl-address hexl-address)) hexl-address)) -(defun hexl-print-current-point-info () +(defun hexl-print-current-point-info (&rest _ignored) "Return current hexl-address in string. This function is intended to be used as eldoc callback." (let ((addr (hexl-current-address))) @@ -701,10 +703,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 +748,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 +759,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 +934,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/hi-lock.el b/lisp/hi-lock.el index 0f685464cdd..33ca40f8dec 100644 --- a/lisp/hi-lock.el +++ b/lisp/hi-lock.el @@ -102,7 +102,7 @@ of functions `hi-lock-mode' and `hi-lock-find-patterns'." :type 'integer :group 'hi-lock) -(defcustom hi-lock-highlight-range 200000 +(defcustom hi-lock-highlight-range 2000000 "Size of area highlighted by hi-lock when font-lock not active. Font-lock is not active in buffers that do their own highlighting, such as the buffer created by `list-colors-display'. In those buffers @@ -233,6 +233,10 @@ Instead, each hi-lock command will cycle through the faces in "Patterns provided to hi-lock by user. Should not be changed.") (put 'hi-lock-interactive-patterns 'permanent-local t) +(defvar-local hi-lock-interactive-lighters nil + "Human-readable lighters for `hi-lock-interactive-patterns'.") +(put 'hi-lock-interactive-lighters 'permanent-local t) + (define-obsolete-variable-alias 'hi-lock-face-history 'hi-lock-face-defaults "23.1") (defvar hi-lock-face-defaults @@ -406,7 +410,8 @@ versions before 22 use the following in your init file: hi-lock-file-patterns) (when hi-lock-interactive-patterns (font-lock-remove-keywords nil hi-lock-interactive-patterns) - (setq hi-lock-interactive-patterns nil)) + (setq hi-lock-interactive-patterns nil + hi-lock-interactive-lighters nil)) (when hi-lock-file-patterns (font-lock-remove-keywords nil hi-lock-file-patterns) (setq hi-lock-file-patterns nil)) @@ -437,6 +442,9 @@ of text in those lines. Interactively, prompt for REGEXP using `read-regexp', then FACE. Use the global history list for FACE. +If REGEXP contains upper case characters (excluding those preceded by `\\') +and `search-upper-case' is non-nil, the matching is case-sensitive. + Use Font lock mode, if enabled, to highlight REGEXP. Otherwise, use overlays for highlighting. If overlays are used, the highlighting will not update as you type." @@ -450,19 +458,29 @@ highlighting will not update as you type." (hi-lock-set-pattern ;; The \\(?:...\\) grouping construct ensures that a leading ^, +, * or ? ;; or a trailing $ in REGEXP will be interpreted correctly. - (concat "^.*\\(?:" regexp "\\).*\\(?:$\\)\n?") face)) + (concat "^.*\\(?:" regexp "\\).*\\(?:$\\)\n?") face nil nil + (if (and case-fold-search search-upper-case) + (isearch-no-upper-case-p regexp t) + case-fold-search))) ;;;###autoload (defalias 'highlight-regexp 'hi-lock-face-buffer) ;;;###autoload -(defun hi-lock-face-buffer (regexp &optional face subexp) +(defun hi-lock-face-buffer (regexp &optional face subexp lighter) "Set face of each match of REGEXP to FACE. Interactively, prompt for REGEXP using `read-regexp', then FACE. Use the global history list for FACE. Limit face setting to the corresponding SUBEXP (interactively, the prefix argument) of REGEXP. If SUBEXP is omitted or nil, the entire REGEXP is highlighted. +LIGHTER is a human-readable string that can be used to select +a regexp to unhighlight by its name instead of selecting a possibly +complex regexp or closure. + +If REGEXP contains upper case characters (excluding those preceded by `\\') +and `search-upper-case' is non-nil, the matching is case-sensitive. + Use Font lock mode, if enabled, to highlight REGEXP. Otherwise, use overlays for highlighting. If overlays are used, the highlighting will not update as you type. The Font Lock mode @@ -477,7 +495,12 @@ the major mode specifies support for Font Lock." current-prefix-arg)) (or (facep face) (setq face 'hi-yellow)) (unless hi-lock-mode (hi-lock-mode 1)) - (hi-lock-set-pattern regexp face subexp)) + (hi-lock-set-pattern + regexp face subexp lighter + (if (and case-fold-search search-upper-case) + (isearch-no-upper-case-p regexp t) + case-fold-search) + search-spaces-regexp)) ;;;###autoload (defalias 'highlight-phrase 'hi-lock-face-phrase-buffer) @@ -487,9 +510,9 @@ the major mode specifies support for Font Lock." Interactively, prompt for REGEXP using `read-regexp', then FACE. Use the global history list for FACE. -When called interactively, replace whitespace in user-provided -regexp with arbitrary whitespace, and make initial lower-case -letters case-insensitive, before highlighting with `hi-lock-set-pattern'. +If REGEXP contains upper case characters (excluding those preceded by `\\') +and `search-upper-case' is non-nil, the matching is case-sensitive. +Also set `search-spaces-regexp' to the value of `search-whitespace-regexp'. Use Font lock mode, if enabled, to highlight REGEXP. Otherwise, use overlays for highlighting. If overlays are used, the @@ -500,12 +523,16 @@ the major mode specifies support for Font Lock." (interactive (list (hi-lock-regexp-okay - (hi-lock-process-phrase - (read-regexp "Phrase to highlight" 'regexp-history-last))) + (read-regexp "Phrase to highlight" 'regexp-history-last)) (hi-lock-read-face-name))) (or (facep face) (setq face 'hi-yellow)) (unless hi-lock-mode (hi-lock-mode 1)) - (hi-lock-set-pattern regexp face)) + (hi-lock-set-pattern + regexp face nil nil + (if (and case-fold-search search-upper-case) + (isearch-no-upper-case-p regexp t) + case-fold-search) + search-whitespace-regexp)) ;;;###autoload (defalias 'highlight-symbol-at-point 'hi-lock-face-symbol-at-point) @@ -516,6 +543,9 @@ Uses the next face from `hi-lock-face-defaults' without prompting, unless you use a prefix argument. Uses `find-tag-default-as-symbol-regexp' to retrieve the symbol at point. +If REGEXP contains upper case characters (excluding those preceded by `\\') +and `search-upper-case' is non-nil, the matching is case-sensitive. + This uses Font lock mode if it is enabled; otherwise it uses overlays, in which case the highlighting will not update as you type. The Font Lock mode is considered \"enabled\" in a buffer if its `major-mode' @@ -528,7 +558,11 @@ the major mode specifies support for Font Lock." (face (hi-lock-read-face-name))) (or (facep face) (setq face 'hi-yellow)) (unless hi-lock-mode (hi-lock-mode 1)) - (hi-lock-set-pattern regexp face))) + (hi-lock-set-pattern + regexp face nil nil + (if (and case-fold-search search-upper-case) + (isearch-no-upper-case-p regexp t) + case-fold-search)))) (defun hi-lock-keyword->face (keyword) (cadr (cadr (cadr keyword)))) ; Keyword looks like (REGEXP (0 'FACE) ...). @@ -542,13 +576,16 @@ the major mode specifies support for Font Lock." (let ((regexp (get-char-property (point) 'hi-lock-overlay-regexp))) (when regexp (push regexp regexps))) ;; With font-locking on, check if the cursor is on a highlighted text. - (let ((face-after (get-text-property (point) 'face)) - (face-before - (unless (bobp) (get-text-property (1- (point)) 'face))) - (faces (mapcar #'hi-lock-keyword->face - hi-lock-interactive-patterns))) - (unless (memq face-before faces) (setq face-before nil)) - (unless (memq face-after faces) (setq face-after nil)) + (let* ((faces-after (get-text-property (point) 'face)) + (faces-before + (unless (bobp) (get-text-property (1- (point)) 'face))) + ;; Use proper-list-p to handle faces like (foreground-color . "red3") + (faces-after (if (proper-list-p faces-after) faces-after (list faces-after))) + (faces-before (if (proper-list-p faces-before) faces-before (list faces-before))) + (faces (mapcar #'hi-lock-keyword->face + hi-lock-interactive-patterns)) + (face-after (seq-some (lambda (face) (car (memq face faces))) faces-after)) + (face-before (seq-some (lambda (face) (car (memq face faces))) faces-before))) (when (and face-before face-after (not (eq face-before face-after))) (setq face-before nil)) (when (or face-after face-before) @@ -566,7 +603,8 @@ the major mode specifies support for Font Lock." ;; highlighted text at point. Use this later in ;; during completing-read. (dolist (hi-lock-pattern hi-lock-interactive-patterns) - (let ((regexp (car hi-lock-pattern))) + (let ((regexp (or (car (rassq hi-lock-pattern hi-lock-interactive-lighters)) + (car hi-lock-pattern)))) (if (string-match regexp hi-text) (push regexp regexps))))))) regexps)) @@ -598,12 +636,15 @@ then remove all hi-lock highlighting." 'keymap (cons "Select Pattern to Unhighlight" (mapcar (lambda (pattern) - (list (car pattern) - (format - "%s (%s)" (car pattern) - (hi-lock-keyword->face pattern)) - (cons nil nil) - (car pattern))) + (let ((lighter + (or (car (rassq pattern hi-lock-interactive-lighters)) + (car pattern)))) + (list lighter + (format + "%s (%s)" lighter + (hi-lock-keyword->face pattern)) + (cons nil nil) + lighter))) hi-lock-interactive-patterns)))) ;; If the user clicks outside the menu, meaning that they ;; change their mind, x-popup-menu returns nil, and @@ -614,17 +655,28 @@ then remove all hi-lock highlighting." (t ;; Un-highlighting triggered via keyboard action. (unless hi-lock-interactive-patterns - (error "No highlighting to remove")) + (user-error "No highlighting to remove")) ;; Infer the regexp to un-highlight based on cursor position. (let* ((defaults (or (hi-lock--regexps-at-point) - (mapcar #'car hi-lock-interactive-patterns)))) + (mapcar (lambda (pattern) + (or (car (rassq pattern hi-lock-interactive-lighters)) + (car pattern))) + hi-lock-interactive-patterns)))) (list (completing-read (if (null defaults) "Regexp to unhighlight: " (format "Regexp to unhighlight (default %s): " (car defaults))) - hi-lock-interactive-patterns + (mapcar (lambda (pattern) + (cons (or (car (rassq pattern hi-lock-interactive-lighters)) + (car pattern)) + (cdr pattern))) + hi-lock-interactive-patterns) nil t nil nil defaults)))))) + + (when (assoc regexp hi-lock-interactive-lighters) + (setq regexp (cadr (assoc regexp hi-lock-interactive-lighters)))) + (dolist (keyword (if (eq regexp t) hi-lock-interactive-patterns (list (assoc regexp hi-lock-interactive-patterns)))) (when keyword @@ -641,7 +693,11 @@ then remove all hi-lock highlighting." (setq hi-lock-interactive-patterns (delq keyword hi-lock-interactive-patterns)) (remove-overlays - nil nil 'hi-lock-overlay-regexp (hi-lock--hashcons (car keyword))) + nil nil 'hi-lock-overlay-regexp + (or (car (rassq keyword hi-lock-interactive-lighters)) + (hi-lock--hashcons (car keyword)))) + (setq hi-lock-interactive-lighters + (rassq-delete-all keyword hi-lock-interactive-lighters)) (font-lock-flush)))) ;;;###autoload @@ -653,7 +709,7 @@ Interactively added patterns are those normally specified using be found in variable `hi-lock-interactive-patterns'." (interactive) (if (null hi-lock-interactive-patterns) - (error "There are no interactive patterns")) + (user-error "There are no interactive patterns")) (let ((beg (point))) (mapc (lambda (pattern) @@ -667,25 +723,6 @@ be found in variable `hi-lock-interactive-patterns'." ;; Implementation Functions -(defun hi-lock-process-phrase (phrase) - "Convert regexp PHRASE to a regexp that matches phrases. - -Blanks in PHRASE replaced by regexp that matches arbitrary whitespace -and initial lower-case letters made case insensitive." - (let ((mod-phrase nil)) - ;; FIXME fragile; better to just bind case-fold-search? (Bug#7161) - (setq mod-phrase - (replace-regexp-in-string - "\\(^\\|\\s-\\)\\([a-z]\\)" - (lambda (m) (format "%s[%s%s]" - (match-string 1 m) - (upcase (match-string 2 m)) - (match-string 2 m))) phrase)) - ;; FIXME fragile; better to use search-spaces-regexp? - (setq mod-phrase - (replace-regexp-in-string - "\\s-+" "[ \t\n]+" mod-phrase nil t)))) - (defun hi-lock-regexp-okay (regexp) "Return REGEXP if it appears suitable for a font-lock pattern. @@ -725,19 +762,27 @@ with completion and history." (add-to-list 'hi-lock-face-defaults face t)) (intern face))) -(defun hi-lock-set-pattern (regexp face &optional subexp) +(defun hi-lock-set-pattern (regexp face &optional subexp lighter case-fold spaces-regexp) "Highlight SUBEXP of REGEXP with face FACE. If omitted or nil, SUBEXP defaults to zero, i.e. the entire -REGEXP is highlighted." +REGEXP is highlighted. LIGHTER is a human-readable string to +display instead of a regexp. Non-nil CASE-FOLD ignores case. +SPACES-REGEXP is a regexp to substitute spaces in font-lock search." ;; Hashcons the regexp, so it can be passed to remove-overlays later. (setq regexp (hi-lock--hashcons regexp)) (setq subexp (or subexp 0)) - (let ((pattern (list regexp (list subexp (list 'quote face) 'prepend))) + (let ((pattern (list (lambda (limit) + (let ((case-fold-search case-fold) + (search-spaces-regexp spaces-regexp)) + (re-search-forward regexp limit t))) + (list subexp (list 'quote face) 'prepend))) (no-matches t)) ;; Refuse to highlight a text that is already highlighted. - (if (assoc regexp hi-lock-interactive-patterns) + (if (or (assoc regexp hi-lock-interactive-patterns) + (assoc (or lighter regexp) hi-lock-interactive-lighters)) (add-to-list 'hi-lock--unused-faces (face-name face)) (push pattern hi-lock-interactive-patterns) + (push (cons (or lighter regexp) pattern) hi-lock-interactive-lighters) (if (and font-lock-mode (font-lock-specified-p major-mode)) (progn (font-lock-add-keywords nil (list pattern) t) @@ -749,7 +794,9 @@ REGEXP is highlighted." (- range-min (max 0 (- range-max (point-max)))))) (search-end (min (point-max) - (+ range-max (max 0 (- (point-min) range-min)))))) + (+ range-max (max 0 (- (point-min) range-min))))) + (case-fold-search case-fold) + (search-spaces-regexp spaces-regexp)) (save-excursion (goto-char search-start) (while (re-search-forward regexp search-end t) @@ -757,13 +804,17 @@ REGEXP is highlighted." (let ((overlay (make-overlay (match-beginning subexp) (match-end subexp)))) (overlay-put overlay 'hi-lock-overlay t) - (overlay-put overlay 'hi-lock-overlay-regexp regexp) + (overlay-put overlay 'hi-lock-overlay-regexp (or lighter regexp)) (overlay-put overlay 'face face)) (goto-char (match-end 0))) (when no-matches (add-to-list 'hi-lock--unused-faces (face-name face)) (setq hi-lock-interactive-patterns - (cdr hi-lock-interactive-patterns))))))))) + (cdr hi-lock-interactive-patterns) + hi-lock-interactive-lighters + (cdr hi-lock-interactive-lighters)))) + (when (or (> search-start (point-min)) (< search-end (point-max))) + (message "Hi-lock added only in range %d-%d" search-start search-end))))))) (defun hi-lock-set-file-patterns (patterns) "Replace file patterns list with PATTERNS and refontify." diff --git a/lisp/hippie-exp.el b/lisp/hippie-exp.el index 98edacd6ec0..ce5fc585c81 100644 --- a/lisp/hippie-exp.el +++ b/lisp/hippie-exp.el @@ -4,7 +4,7 @@ ;; Author: Anders Holst <aho@sans.kth.se> ;; Maintainer: emacs-devel@gnu.org -;; Version: 1.6 +;; Old-Version: 1.6 ;; Keywords: abbrev convenience ;; This file is part of GNU Emacs. diff --git a/lisp/htmlfontify.el b/lisp/htmlfontify.el index 08e52d63a26..6265537e885 100644 --- a/lisp/htmlfontify.el +++ b/lisp/htmlfontify.el @@ -11,9 +11,6 @@ ;; Created: 2002-01-05 ;; Description: htmlize a buffer/source tree with optional hyperlinks ;; URL: http://rtfm.etla.org/emacs/htmlfontify/ -;; Compatibility: Emacs23, Emacs22 -;; Incompatibility: Emacs19, Emacs20, Emacs21 -;; Last Updated: Thu 2009-11-19 01:31:21 +0000 ;; This file is part of GNU Emacs. @@ -136,8 +133,8 @@ main-content <=MAIN_CONTENT;\\n\" rtfm-section file style rtfm-section file)) \"s section[eg- emacs / p4-blame]:\\nD source-dir: \\nD output-dir: \") (require \\='htmlfontify) (hfy-load-tags-cache srcdir) - (let ((hfy-page-header \\='rtfm-build-page-header) - (hfy-page-footer \\='rtfm-build-page-footer) + (let ((hfy-page-header #\\='rtfm-build-page-header) + (hfy-page-footer #\\='rtfm-build-page-footer) (rtfm-section section) (hfy-index-file \"index\")) (htmlfontify-run-etags srcdir) @@ -151,7 +148,7 @@ main-content <=MAIN_CONTENT;\\n\" rtfm-section file style rtfm-section file)) :link '(info-link "(htmlfontify) Customization") :prefix "hfy-") -(defcustom hfy-page-header 'hfy-default-header +(defcustom hfy-page-header #'hfy-default-header "Function called to build the header of the HTML source. This is called with two arguments (the filename relative to the top level source directory being etag'd and fontified), and a string containing @@ -159,7 +156,6 @@ the <style>...</style> text to embed in the document. It should return a string that will be used as the header for the htmlfontified version of the source file.\n See also `hfy-page-footer'." - :group 'htmlfontify ;; FIXME: Why place such a :tag everywhere? Isn't it imposing your ;; own Custom preference on your users? --Stef :tag "page-header" @@ -170,66 +166,57 @@ See also `hfy-page-footer'." If non-nil, the index is split on the first letter of each tag. Useful when the index would otherwise be large and take a long time to render or be difficult to navigate." - :group 'htmlfontify :tag "split-index" :type '(boolean)) -(defcustom hfy-page-footer 'hfy-default-footer +(defcustom hfy-page-footer #'hfy-default-footer "As `hfy-page-header', but generates the output footer. It takes only one argument, the filename." - :group 'htmlfontify :tag "page-footer" :type '(function)) (defcustom hfy-extn ".html" "File extension used for output files." - :group 'htmlfontify :tag "extension" :type '(string)) (defcustom hfy-src-doc-link-style "text-decoration: underline;" "String to add to the `<style> a' variant of an htmlfontify CSS class." - :group 'htmlfontify :tag "src-doc-link-style" :type '(string)) (defcustom hfy-src-doc-link-unstyle " text-decoration: none;" "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. Useful where the htmlfontify output files are going to be processed again, with a resulting change in file extension. If nil, then any code using this should fall back to `hfy-extn'." - :group 'htmlfontify :tag "link-extension" :type '(choice string (const nil))) -(defcustom hfy-link-style-fun 'hfy-link-style-string +(defcustom hfy-link-style-fun #'hfy-link-style-string "Function to customize the appearance of hyperlinks. Set this to a function, which will be called with one argument \(a \"{ foo: bar; ...}\" CSS style-string) - it should return a copy of its argument, altered so as to make any changes you want made for text which is a hyperlink, in addition to being in the class to which that style would normally be applied." - :group 'htmlfontify :tag "link-style-function" :type '(function)) (defcustom hfy-index-file "hfy-index" "Name (sans extension) of the tag definition index file produced during fontification-and-hyperlinking." - :group 'htmlfontify :tag "index-file" :type '(string)) (defcustom hfy-instance-file "hfy-instance" "Name (sans extension) of the tag usage index file produced during fontification-and-hyperlinking." - :group 'htmlfontify :tag "instance-file" :type '(string)) @@ -237,25 +224,13 @@ fontification-and-hyperlinking." "Regex to match (with a single back-reference per match) strings in HTML which should be quoted with `hfy-html-quote' (and `hfy-html-quote-map') to make them safe." - :group 'htmlfontify :tag "html-quote-regex" :type '(regexp)) -(define-obsolete-variable-alias 'hfy-init-kludge-hooks 'hfy-init-kludge-hook - "23.2") -(defcustom hfy-init-kludge-hook '(hfy-kludge-cperl-mode) - "List of functions to call when starting `htmlfontify-buffer' to do any -kludging necessary to get highlighting modes to behave as you want, even -when not running under a window system." - :group 'htmlfontify - :tag "init-kludge-hooks" - :type '(hook)) - (define-obsolete-variable-alias 'hfy-post-html-hooks 'hfy-post-html-hook "24.3") (defcustom hfy-post-html-hook nil "List of functions to call after creating and filling the HTML buffer. These functions will be called with the HTML buffer as the current buffer." - :group 'htmlfontify :tag "post-html-hooks" :options '(set-auto-mode) :type '(hook)) @@ -267,7 +242,6 @@ potentially non-current face information doesn't necessarily work for `default').\n Example: I customize this to:\n \((t :background \"black\" :foreground \"white\" :family \"misc-fixed\"))" - :group 'htmlfontify :tag "default-face-definition" :type '(alist)) @@ -281,7 +255,6 @@ in order, to:\n 1 - The tag 2 - The line 3 - The char (point) at which the tag occurs." - :group 'htmlfontify :tag "etag-regex" :type '(regexp)) @@ -290,7 +263,6 @@ in order, to:\n ("&" "&" ) (">" ">" )) "Alist of char -> entity mappings used to make the text HTML-safe." - :group 'htmlfontify :tag "html-quote-map" :type '(alist :key-type (string))) (defconst hfy-e2x-etags-cmd "for src in `find . -type f`; @@ -332,7 +304,6 @@ done;") hfy-etags-cmd-alist-default "Alist of possible shell commands that will generate etags output that `htmlfontify' can use. `%s' will be replaced by `hfy-etags-bin'." - :group 'htmlfontify :tag "etags-cmd-alist" :type '(alist :key-type (string) :value-type (string))) @@ -340,13 +311,11 @@ done;") "Location of etags binary (we begin by assuming it's in your path).\n Note that if etags is not in your path, you will need to alter the shell commands in `hfy-etags-cmd-alist'." - :group 'htmlfontify :tag "etags-bin" :type '(file)) (defcustom hfy-shell-file-name "/bin/sh" "Shell (Bourne or compatible) to invoke for complex shell operations." - :group 'htmlfontify :tag "shell-file-name" :type '(file)) @@ -358,7 +327,6 @@ commands in `hfy-etags-cmd-alist'." point-entered point-left) "Properties to omit when copying a fontified buffer for HTML transformation." - :group 'htmlfontify :tag "ignored-properties" :type '(repeat symbol)) @@ -387,7 +355,6 @@ file for the whole source tree from there on down. The command should emit the etags output on stdout.\n Two canned commands are provided - they drive Emacs's etags and exuberant-ctags' etags respectively." - :group 'htmlfontify :tag "etags-command" :type (let ((clist (list '(string)))) (dolist (C hfy-etags-cmd-alist) @@ -398,14 +365,12 @@ exuberant-ctags' etags respectively." "Command to run with the name of a file, to see whether it is a text file or not. The command should emit a string containing the word `text' if the file is a text file, and a string not containing `text' otherwise." - :group 'htmlfontify :tag "istext-command" :type '(string)) (defcustom hfy-find-cmd "find . -type f \\! -name \\*~ \\! -name \\*.flc \\! -path \\*/CVS/\\*" "Find command used to harvest a list of files to attempt to fontify." - :group 'htmlfontify :tag "find-command" :type '(string)) @@ -434,7 +399,6 @@ of these values in the specification key constitutes a match, eg:\n ((type tty) (class color))\n and so on." :type '(alist :key-type (symbol) :value-type (symbol)) - :group 'htmlfontify :tag "display-class" :options '((type (choice (const :tag "X11" x-toolkit) (const :tag "Terminal" tty ) @@ -481,7 +445,6 @@ which can never slow you down, but may result in incomplete fontification." (const :tag "div-wrapper" div-wrapper ) (const :tag "keep-overlays" keep-overlays ) (const :tag "body-text-only" body-text-only )) - :group 'htmlfontify :tag "optimizations") (defvar hfy-tags-cache nil @@ -599,13 +562,14 @@ If a window system is unavailable, calls `hfy-fallback-color-values'." (x-color-values color)) ;; blarg - tty colors are no good - go fetch some X colors: (hfy-fallback-color-values color)))) -(define-obsolete-function-alias 'hfy-colour-vals 'hfy-color-vals "27.1") +(define-obsolete-function-alias 'hfy-colour-vals #'hfy-color-vals "27.1") (defvar hfy-cperl-mode-kludged-p nil) (defun hfy-kludge-cperl-mode () "CPerl mode does its damnedest not to do some of its fontification when not in a windowing system - try to trick it..." + (declare (obsolete nil "28.1")) (if (not hfy-cperl-mode-kludged-p) (progn (if (not window-system) (let ((window-system 'htmlfontify)) @@ -728,7 +692,7 @@ STYLE is the inline CSS stylesheet (or tag referring to an external sheet)." --> </script> </head> <body onload=\"stripe('index'); return true;\">\n" - (mapconcat 'hfy-html-quote (mapcar 'char-to-string file) "") style)) + (mapconcat #'hfy-html-quote (mapcar #'char-to-string file) "") style)) (defun hfy-default-footer (_file) "Default value for `hfy-page-footer'. @@ -766,24 +730,24 @@ may happen." (let ((white (mapcar (lambda (I) (float (1+ I))) (hfy-color-vals "white"))) (rgb16 (mapcar (lambda (I) (float (1+ I))) (hfy-color-vals color)))) (if rgb16 - ;;(apply 'format "rgb(%d, %d, %d)" + ;;(apply #'format "rgb(%d, %d, %d)" ;; Use #rrggbb instead, it is smaller - (apply 'format "#%02x%02x%02x" + (apply #'format "#%02x%02x%02x" (mapcar (lambda (X) (* (/ (nth X rgb16) - (nth X white)) 255)) + (nth X white)) + 255)) '(0 1 2)))))) (defun hfy-family (family) (list (cons "font-family" family))) (defun hfy-bgcol (color) (list (cons "background" (hfy-triplet color)))) (defun hfy-color (color) (list (cons "color" (hfy-triplet color)))) -(define-obsolete-function-alias 'hfy-colour 'hfy-color "27.1") +(define-obsolete-function-alias 'hfy-colour #'hfy-color "27.1") (defun hfy-width (width) (list (cons "font-stretch" (symbol-name width)))) (defcustom hfy-font-zoom 1.05 "Font scaling from Emacs to HTML." - :type 'float - :group 'htmlfontify) + :type 'float) (defun hfy-size (height) "Derive a CSS font-size specifier from an Emacs font :height attribute HEIGHT. @@ -1062,7 +1026,7 @@ haven't encountered them yet. Returns a `hfy-style-assoc'." (when (string-match "pt" (cdr css)) (setq x t))) (setq r (nconc r (list css))))) ;;(message "r: %S" r) - (setq n (apply '* m)) + (setq n (apply #'* m)) (nconc r (hfy-size (if x (round n) (* n 1.0)))) )) (defun hfy-face-resolve-face (fn) @@ -1152,9 +1116,9 @@ See also `hfy-face-to-css'." (push (car E) seen) (format " %s: %s; " (car E) (cdr E))))) css-list))) - (cons (hfy-css-name fn) (format "{%s}" (apply 'concat css-text)))) ) + (cons (hfy-css-name fn) (format "{%s}" (apply #'concat css-text)))) ) -(defvar hfy-face-to-css 'hfy-face-to-css-default +(defvar hfy-face-to-css #'hfy-face-to-css-default "Handler for mapping faces to styles. The signature of the handler is of the form \(lambda (FN) ...). FN is a font or `defface' specification (cf @@ -1510,7 +1474,7 @@ Uses `hfy-link-style-fun' to do this." ;; Fix-me: Add handling of page breaks here + scan for ^L ;; where appropriate. (format "body, pre %s\n" (cddr (assq 'default css))) - (apply 'concat + (apply #'concat (mapcar (lambda (style) (format @@ -1611,7 +1575,7 @@ Insert \"</span>\". See `hfy-end-span-handler' for more information." (insert "</span>")) -(defvar hfy-begin-span-handler 'hfy-begin-span +(defvar hfy-begin-span-handler #'hfy-begin-span "Handler to begin a span of text. The signature of the handler is \(lambda (STYLE TEXT-BLOCK TEXT-ID TEXT-BEGINS-BLOCK-P) ...). The handler must insert @@ -1640,7 +1604,7 @@ behavior. The default handler is `hfy-begin-span'.") -(defvar hfy-end-span-handler 'hfy-end-span +(defvar hfy-end-span-handler #'hfy-end-span "Handler to end a span of text. The signature of the handler is \(lambda () ...). The handler must insert appropriate tags to end a span of text. @@ -1821,33 +1785,7 @@ fontified. This is a simple convenience wrapper around (htmlfontify-buffer) (buffer-string)))) -(defun hfy-force-fontification () - "Try to force font-locking even when it is optimized away." - (run-hooks 'hfy-init-kludge-hook) - (eval-and-compile (require 'font-lock)) - (if (boundp 'font-lock-cache-position) - (or font-lock-cache-position - (setq font-lock-cache-position (make-marker)))) - (cond - (noninteractive - (message "hfy batch mode (%s:%S)" - (or (buffer-file-name) (buffer-name)) major-mode) - (if (fboundp 'font-lock-ensure) ; Emacs >= 25.1 - (font-lock-ensure) - (when font-lock-defaults - ; Silence "interactive use only" warning on Emacs >= 25.1. - (with-no-warnings (font-lock-fontify-buffer))))) - ((and (fboundp #'jit-lock-fontify-now) - (bound-and-true-p jit-lock-mode)) - (message "hfy jit-lock mode (%S %S)" window-system major-mode) - (jit-lock-fontify-now)) - (t - (message "hfy interactive mode (%S %S)" window-system major-mode) - ;; If jit-lock is not in use, then the buffer is already fontified! - ;; (when (and font-lock-defaults - ;; font-lock-mode) - ;; (font-lock-fontify-region (point-min) (point-max) nil)) - ))) +(define-obsolete-function-alias 'hfy-force-fontification #'font-lock-ensure "28.1") ;;;###autoload (defun htmlfontify-buffer (&optional srcdir file) @@ -1875,8 +1813,7 @@ hyperlinks as appropriate." (setq file (match-string 1 file)))) ) (if (not (hfy-opt 'skip-refontification)) - (save-excursion ;; Keep region - (hfy-force-fontification))) + (font-lock-ensure)) (if (called-interactively-p 'any) ;; display the buffer in interactive mode: (switch-to-buffer (hfy-fontify-buffer srcdir file)) (hfy-fontify-buffer srcdir file))) @@ -1934,7 +1871,7 @@ adding an extension of `hfy-extn'. Fontification is actually done by ;; FIXME: Shouldn't this use expand-file-name? --Stef (setq target (concat dstdir "/" file)) (hfy-make-directory (hfy-dirname target)) - (if (not (hfy-opt 'skip-refontification)) (hfy-force-fontification)) + (if (not (hfy-opt 'skip-refontification)) (font-lock-ensure)) (if (or (hfy-fontified-p) (hfy-text-p srcdir file)) (progn (setq html (hfy-fontify-buffer srcdir file)) (set-buffer html) @@ -2392,7 +2329,7 @@ You may also want to set `hfy-page-header' and `hfy-page-footer'." ;; (custom-save-delete 'hfy-set-hooks) ;; (let ((standard-output (current-buffer))) ;; (princ "(hfy-set-hooks\n;;auto-generated, only one copy allowed\n") -;; (mapatoms 'hfy-pp-hook) +;; (mapatoms #'hfy-pp-hook) ;; (insert "\n)") ;; ) ;; ) @@ -2419,7 +2356,7 @@ You may also want to set `hfy-page-header' and `hfy-page-footer'." ;; FIXME: This saving&restoring of global customization ;; variables can interfere with other customization settings for ;; those vars (in .emacs or in Customize). - (mapc 'hfy-save-initvar + (mapc #'hfy-save-initvar '(auto-mode-alist interpreter-mode-alist)) (princ ")\n") (indent-region start-pos (point) nil)) diff --git a/lisp/ibuf-ext.el b/lisp/ibuf-ext.el index bfb9787a96d..c9ca1f87424 100644 --- a/lisp/ibuf-ext.el +++ b/lisp/ibuf-ext.el @@ -504,7 +504,7 @@ format. See `ibuffer-update-saved-filters-format' and (ibuffer-forward-line 0)) (defun ibuffer--maybe-erase-shell-cmd-output () - (let ((buf (get-buffer "*Shell Command Output*"))) + (let ((buf (get-buffer shell-command-buffer-name))) (when (and (buffer-live-p buf) (not shell-command-dont-erase-buffer) (not (zerop (buffer-size buf)))) @@ -517,7 +517,7 @@ format. See `ibuffer-update-saved-filters-format' and :opstring "Shell command executed on" :before (ibuffer--maybe-erase-shell-cmd-output) :modifier-p nil) - (let ((out-buf (get-buffer-create "*Shell Command Output*"))) + (let ((out-buf (get-buffer-create shell-command-buffer-name))) (with-current-buffer out-buf (goto-char (point-max))) (call-shell-region (point-min) (point-max) command nil out-buf))) @@ -542,7 +542,7 @@ format. See `ibuffer-update-saved-filters-format' and :modifier-p nil) (let ((file (and (not (buffer-modified-p)) buffer-file-name)) - (out-buf (get-buffer-create "*Shell Command Output*"))) + (out-buf (get-buffer-create shell-command-buffer-name))) (unless (and file (file-exists-p file)) (setq file (make-temp-file 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/ido.el b/lisp/ido.el index 7198649e5a5..e834916a6da 100644 --- a/lisp/ido.el +++ b/lisp/ido.el @@ -243,7 +243,7 @@ ;; current frame are put at the end of the list. A hook exists to ;; allow other functions to order the list. For example, if you add: ;; -;; (add-hook 'ido-make-buffer-list-hook 'ido-summary-buffers-to-end) +;; (add-hook 'ido-make-buffer-list-hook #'ido-summary-buffers-to-end) ;; ;; then all files matching "Summary" are moved to the end of the ;; list. (I find this handy for keeping the INBOX Summary and so on @@ -355,8 +355,8 @@ The following values are possible: Setting this variable directly does not take effect; use either \\[customize] or the function `ido-mode'." :set #'(lambda (_symbol value) - (ido-mode value)) - :initialize 'custom-initialize-default + (ido-mode (or value 0))) + :initialize #'custom-initialize-default :require 'ido :link '(emacs-commentary-link "ido.el") :set-after '(ido-save-directory-list-file @@ -366,13 +366,11 @@ use either \\[customize] or the function `ido-mode'." :type '(choice (const :tag "Turn on only buffer" buffer) (const :tag "Turn on only file" file) (const :tag "Turn on both buffer and file" both) - (const :tag "Switch off all" nil)) - :group 'ido) + (const :tag "Switch off all" nil))) (defcustom ido-case-fold case-fold-search "Non-nil if searching of buffer and file names should ignore case." - :type 'boolean - :group 'ido) + :type 'boolean) (defcustom ido-ignore-buffers '("\\` ") @@ -380,8 +378,7 @@ use either \\[customize] or the function `ido-mode'." For example, traditional behavior is not to list buffers whose names begin with a space, for which the regexp is `\\\\=` '. See the source file for example functions that filter buffer names." - :type '(repeat (choice regexp function)) - :group 'ido) + :type '(repeat (choice regexp function))) (defcustom ido-ignore-files '("\\`CVS/" "\\`#" "\\`.#" "\\`\\.\\./" "\\`\\./") @@ -389,19 +386,16 @@ example functions that filter buffer names." For example, traditional behavior is not to list files whose names begin with a #, for which the regexp is `\\\\=`#'. See the source file for example functions that filter filenames." - :type '(repeat (choice regexp function)) - :group 'ido) + :type '(repeat (choice regexp function))) (defcustom ido-ignore-extensions t "Non-nil means ignore files in `completion-ignored-extensions' list." - :type 'boolean - :group 'ido) + :type 'boolean) (defcustom ido-show-dot-for-dired nil "Non-nil means to always put . as the first item in file name lists. This allows the current directory to be opened immediately with `dired'." - :type 'boolean - :group 'ido) + :type 'boolean) (defcustom ido-file-extensions-order nil "List of file extensions specifying preferred order of file selections. @@ -409,21 +403,18 @@ Each element is either a string with `.' as the first char, an empty string matching files without extension, or t which is the default order for files with an unlisted file extension." :type '(repeat (choice string - (const :tag "Default order" t))) - :group 'ido) + (const :tag "Default order" t)))) (defcustom ido-ignore-directories '("\\`CVS/" "\\`\\.\\./" "\\`\\./") "List of regexps or functions matching sub-directory names to ignore." - :type '(repeat (choice regexp function)) - :group 'ido) + :type '(repeat (choice regexp function))) (defcustom ido-ignore-directories-merge nil "List of regexps or functions matching directory names to ignore during merge. Directory names matched by one of the regexps in this list are not inserted in merged file and directory lists." - :type '(repeat (choice regexp function)) - :group 'ido) + :type '(repeat (choice regexp function))) ;; Examples for setting the value of ido-ignore-buffers ;;(defun ido-ignore-c-mode (name) @@ -453,8 +444,7 @@ Possible values: (const :tag "Display (no select) in other window" display) (const :tag "Visit in other frame" other-frame) (const :tag "Ask to visit in other frame" maybe-frame) - (const :tag "Raise frame if already visited" raise-frame)) - :group 'ido) + (const :tag "Raise frame if already visited" raise-frame))) (defcustom ido-default-buffer-method 'raise-frame "How to switch to new buffer when using `ido-switch-buffer'. @@ -464,38 +454,33 @@ See `ido-default-file-method' for details." (const :tag "Display (no select) in other window" display) (const :tag "Show in other frame" other-frame) (const :tag "Ask to show in other frame" maybe-frame) - (const :tag "Raise frame if already shown" raise-frame)) - :group 'ido) + (const :tag "Raise frame if already shown" raise-frame))) (defcustom ido-enable-flex-matching nil "Non-nil means that Ido will do flexible string matching. Flexible matching means that if the entered string does not match any item, any item containing the entered characters in the given sequence will match." - :type 'boolean - :group 'ido) + :type 'boolean) (defcustom ido-enable-regexp nil "Non-nil means that Ido will do regexp matching. Value can be toggled within Ido using `ido-toggle-regexp'." - :type 'boolean - :group 'ido) + :type 'boolean) (defcustom ido-enable-prefix nil "Non-nil means only match if the entered text is a prefix of file name. This behavior is like the standard Emacs completion. If nil, match if the entered text is an arbitrary substring. Value can be toggled within Ido using `ido-toggle-prefix'." - :type 'boolean - :group 'ido) + :type 'boolean) (defcustom ido-enable-dot-prefix nil "Non-nil means to match leading dot as prefix. I.e. hidden files and buffers will match only if you type a dot as first char even if `ido-enable-prefix' is nil." - :type 'boolean - :group 'ido) + :type 'boolean) ;; See https://debbugs.gnu.org/2042 for more info. (defcustom ido-buffer-disable-smart-matches t @@ -506,30 +491,29 @@ By default, Ido arranges matches in the following order: which can get in the way for buffer switching." :version "24.3" - :type 'boolean - :group 'ido) + :type 'boolean) (defcustom ido-confirm-unique-completion nil "Non-nil means that even a unique completion must be confirmed. This means that \\[ido-complete] must always be followed by \\[ido-exit-minibuffer] even when there is only one unique completion." - :type 'boolean - :group 'ido) + :type 'boolean) -(defcustom ido-cannot-complete-command 'ido-completion-help +(defcustom ido-cannot-complete-command #'ido-completion-auto-help "Command run when `ido-complete' can't complete any more. The most useful values are `ido-completion-help', which pops up a -window with completion alternatives, or `ido-next-match' or -`ido-prev-match', which cycle the buffer list." - :type 'function - :group 'ido) +window with completion alternatives; `ido-completion-auto-help', +which does the same but respects the value of +`completion-auto-help'; and `ido-next-match' or `ido-prev-match', +which cycle the buffer list." + :version "28.1" + :type 'function) (defcustom ido-record-commands t "Non-nil means that Ido will record commands in command history. Note that the non-Ido equivalent command is recorded." - :type 'boolean - :group 'ido) + :type 'boolean) (defcustom ido-max-prospects 12 "Upper limit of the prospect list if non-zero. @@ -537,8 +521,7 @@ Zero means no limit for the prospect list. For a long list of prospects, building the full list for the minibuffer can take a non-negligible amount of time; setting this variable reduces that time." - :type 'integer - :group 'ido) + :type 'integer) (defcustom ido-max-file-prompt-width 0.35 "Upper limit of the prompt string. @@ -550,8 +533,7 @@ the frame width." (integer :tag "Characters" :value 20) (restricted-sexp :tag "Fraction of frame width" :value 0.35 - :match-alternatives (ido-fractionp))) - :group 'ido) + :match-alternatives (ido-fractionp)))) (defcustom ido-max-window-height nil "Non-nil specifies a value to override `max-mini-window-height'." @@ -561,28 +543,24 @@ the frame width." (restricted-sexp :tag "Fraction of window height" :value 0.25 - :match-alternatives (ido-fractionp))) - :group 'ido) + :match-alternatives (ido-fractionp)))) (defcustom ido-enable-last-directory-history t "Non-nil means that Ido will remember latest selected directory names. See `ido-last-directory-list' and `ido-save-directory-list-file'." - :type 'boolean - :group 'ido) + :type 'boolean) (defcustom ido-max-work-directory-list 50 "Maximum number of working directories to record. This is the list of directories where files have most recently been opened. See `ido-work-directory-list' and `ido-save-directory-list-file'." - :type 'integer - :group 'ido) + :type 'integer) (defcustom ido-work-directory-list-ignore-regexps nil "List of regexps matching directories which should not be recorded. Directory names matched by one of the regexps in this list are not inserted in the `ido-work-directory-list' list." - :type '(repeat regexp) - :group 'ido) + :type '(repeat regexp)) (defcustom ido-use-filename-at-point nil @@ -592,52 +570,44 @@ If found, use that as the starting point for filename selection." :type '(choice (const :tag "Disabled" nil) (const :tag "Guess filename" guess) - (other :tag "Use literal filename" t)) - :group 'ido) + (other :tag "Use literal filename" t))) (defcustom ido-use-url-at-point nil "Non-nil means that ido shall look for a URL at point. If found, call `find-file-at-point' to visit it." - :type 'boolean - :group 'ido) + :type 'boolean) (defcustom ido-enable-tramp-completion t "Non-nil means that Ido shall perform tramp method and server name completion. A tramp file name uses the following syntax: /method:user@host:filename." - :type 'boolean - :group 'ido) + :type 'boolean) (defcustom ido-record-ftp-work-directories t "Non-nil means record FTP file names in the work directory list." - :type 'boolean - :group 'ido) + :type 'boolean) (defcustom ido-merge-ftp-work-directories nil "If nil, merging ignores FTP file names in the work directory list." - :type 'boolean - :group 'ido) + :type 'boolean) (defcustom ido-cache-ftp-work-directory-time 1.0 "Maximum time to cache contents of an FTP directory (in hours). \\<ido-file-completion-map> Use \\[ido-reread-directory] in prompt to refresh list. If zero, FTP directories are not cached." - :type 'number - :group 'ido) + :type 'number) (defcustom ido-slow-ftp-hosts nil "List of slow FTP hosts where Ido prompting should not be used. If an FTP host is on this list, Ido automatically switches to the non-Ido equivalent function, e.g. `find-file' rather than `ido-find-file'." - :type '(repeat string) - :group 'ido) + :type '(repeat string)) (defcustom ido-slow-ftp-host-regexps nil "List of regexps matching slow FTP hosts (see `ido-slow-ftp-hosts')." - :type '(repeat regexp) - :group 'ido) + :type '(repeat regexp)) (defvar ido-unc-hosts-cache t "Cached value from the function `ido-unc-hosts'.") @@ -652,66 +622,56 @@ hosts on first use of UNC path." (function :tag "Your own function")) :set #'(lambda (symbol value) (set symbol value) - (setq ido-unc-hosts-cache t)) - :group 'ido) + (setq ido-unc-hosts-cache t))) (defcustom ido-downcase-unc-hosts t "Non-nil if UNC host names should be downcased." - :type 'boolean - :group 'ido) + :type 'boolean) (defcustom ido-ignore-unc-host-regexps nil "List of regexps matching UNC hosts to ignore. Case is ignored if `ido-downcase-unc-hosts' is set." - :type '(repeat regexp) - :group 'ido) + :type '(repeat regexp)) (defcustom ido-cache-unc-host-shares-time 8.0 "Maximum time to cache shares of an UNC host (in hours). \\<ido-file-completion-map> Use \\[ido-reread-directory] in prompt to refresh list. If zero, UNC host shares are not cached." - :type 'number - :group 'ido) + :type 'number) (defcustom ido-max-work-file-list 10 "Maximum number of names of recently opened files to record. This is the list of the file names (sans directory) which have most recently been opened. See `ido-work-file-list' and `ido-save-directory-list-file'." - :type 'integer - :group 'ido) + :type 'integer) (defcustom ido-work-directory-match-only t "Non-nil means to skip non-matching directories in the directory history. When some text is already entered at the `ido-find-file' prompt, using \\[ido-prev-work-directory] or \\[ido-next-work-directory] will skip directories without any matching entries." - :type 'boolean - :group 'ido) + :type 'boolean) (defcustom ido-auto-merge-work-directories-length 0 "Automatically switch to merged work directories during file name input. The value is number of characters to type before switching to merged mode. If zero, the switch happens when no matches are found in the current directory. Automatic merging is disabled if the value is negative." - :type 'integer - :group 'ido) + :type 'integer) (defcustom ido-auto-merge-delay-time 0.70 "Delay in seconds to wait for more input before doing auto merge." - :type 'number - :group 'ido) + :type 'number) (defcustom ido-auto-merge-inhibit-characters-regexp "[][*?~]" "Regexp matching characters which should inhibit automatic merging. When a (partial) file name matches this regexp, merging is inhibited." - :type 'regexp - :group 'ido) + :type 'regexp) (defcustom ido-merged-indicator "^" "The string appended to first choice if it has multiple directory choices." - :type 'string - :group 'ido) + :type 'string) (defcustom ido-max-dir-file-cache 100 "Maximum number of working directories to be cached. @@ -723,8 +683,7 @@ modification times, so you may choose to disable caching on such systems, or explicitly refresh the cache contents using the command `ido-reread-directory' command (\\[ido-reread-directory]) in the minibuffer. See also `ido-dir-file-cache' and `ido-save-directory-list-file'." - :type 'integer - :group 'ido) + :type 'integer) (defcustom ido-max-directory-size nil "Maximum size (in bytes) for directories to use Ido completion. @@ -732,21 +691,18 @@ See also `ido-dir-file-cache' and `ido-save-directory-list-file'." If you enter a directory with a size larger than this size, Ido will not provide the normal completion. To show the completions, use \\[ido-toggle-ignore]." :type '(choice (const :tag "No limit" nil) - (integer :tag "Size in bytes" 30000)) - :group 'ido) + (integer :tag "Size in bytes" 30000))) (defcustom ido-big-directories nil "List of directory pattern strings that should be considered big. Ido won't attempt to list the contents of directories matching any of these regular expressions when completing file names." :type '(repeat regexp) - :group 'ido :version "27.1") (defcustom ido-rotate-file-list-default nil "Non-nil means that Ido will always rotate file list to get default in front." - :type 'boolean - :group 'ido) + :type 'boolean) (defcustom ido-enter-matching-directory 'only "Additional methods to enter sub-directory of first/only matching item. @@ -758,8 +714,7 @@ matching item, even without typing a slash." :type '(choice (const :tag "Never" nil) (const :tag "Slash enters first directory" first) (const :tag "Slash enters first and only directory" only) - (other :tag "Always enter unique directory" t)) - :group 'ido) + (other :tag "Always enter unique directory" t))) (defcustom ido-create-new-buffer 'prompt "Specify whether a new buffer is created if no buffer matches substring. @@ -767,21 +722,18 @@ Choices are `always' to create new buffers unconditionally, `prompt' to ask user whether to create buffer, or `never' to never create new buffer." :type '(choice (const always) (const prompt) - (const never)) - :group 'ido) + (const never))) (defcustom ido-setup-hook nil "Hook run after the Ido variables and keymap have been setup. The dynamic variable `ido-cur-item' contains the current type of item that is read by Ido; possible values are file, dir, buffer, and list. Additional keys can be defined in `ido-completion-map'." - :type 'hook - :group 'ido) + :type 'hook) (defcustom ido-separator nil "String used by Ido to separate the alternatives in the minibuffer." - :type '(choice string (const nil)) - :group 'ido) + :type '(choice string (const nil))) (make-obsolete-variable 'ido-separator "set 3rd element of `ido-decorations' instead." nil) @@ -802,8 +754,7 @@ can be completed using TAB, 11th element is displayed to confirm creating new file or buffer. 12th and 13th elements (if present) are used as brackets around the sole remaining completion. If absent, elements 5 and 6 are used instead." - :type '(repeat string) - :group 'ido) + :type '(repeat string)) (defcustom ido-use-virtual-buffers nil "If non-nil, refer to past (\"virtual\") buffers as well as existing ones. @@ -827,71 +778,60 @@ enabled if this variable is configured to a non-nil value." :version "24.1" :type '(choice (const :tag "Always" t) (const :tag "Automatic" auto) - (const :tag "Never" nil)) - :group 'ido) + (const :tag "Never" nil))) (defcustom ido-use-faces t "Non-nil means use Ido faces to highlighting first match, only match and subdirs in the alternatives." - :type 'boolean - :group 'ido) + :type 'boolean) (defface ido-first-match '((t :weight bold)) - "Face used by Ido for highlighting first match." - :group 'ido) + "Face used by Ido for highlighting first match.") (defface ido-only-match '((((class color)) :foreground "ForestGreen") (t :slant italic)) - "Face used by Ido for highlighting only match." - :group 'ido) + "Face used by Ido for highlighting only match.") (defface ido-subdir '((((min-colors 88) (class color)) :foreground "red1") (((class color)) :foreground "red") (t :underline t)) - "Face used by Ido for highlighting subdirs in the alternatives." - :group 'ido) + "Face used by Ido for highlighting subdirs in the alternatives.") (defface ido-virtual '((t :inherit font-lock-builtin-face)) "Face used by Ido for matching virtual buffer names." - :version "24.1" - :group 'ido) + :version "24.1") (defface ido-indicator '((((min-colors 88) (class color)) :foreground "yellow1" :background "red1" :width condensed) (((class color)) :foreground "yellow" :background "red" :width condensed) (t :inverse-video t)) - "Face used by Ido for highlighting its indicators." - :group 'ido) + "Face used by Ido for highlighting its indicators.") (defface ido-incomplete-regexp '((t :inherit font-lock-warning-face)) - "Ido face for indicating incomplete regexps." - :group 'ido) + "Ido face for indicating incomplete regexps.") (defcustom ido-make-file-list-hook nil "List of functions to run when the list of matching files is created. Each function on the list may modify the dynamically bound variable `ido-temp-list' which contains the current list of matching files." - :type 'hook - :group 'ido) + :type 'hook) (defcustom ido-make-dir-list-hook nil "List of functions to run when the list of matching directories is created. Each function on the list may modify the dynamically bound variable `ido-temp-list' which contains the current list of matching directories." - :type 'hook - :group 'ido) + :type 'hook) (defcustom ido-make-buffer-list-hook nil "List of functions to run when the list of matching buffers is created. Each function on the list may modify the dynamically bound variable `ido-temp-list' which contains the current list of matching buffer names." - :type 'hook - :group 'ido) + :type 'hook) (defcustom ido-rewrite-file-prompt-functions nil "List of functions to run when the find-file prompt is created. @@ -908,8 +848,7 @@ variables: The following variables are available, but should not be changed: `ido-current-directory' - the unabbreviated directory name item - equals `file' or `dir' depending on the current mode." - :type 'hook - :group 'ido) + :type 'hook) (defvar ido-rewrite-file-prompt-rules nil "Alist of rewriting rules for directory names in Ido prompts. @@ -924,14 +863,12 @@ also modify the dynamic variables described for the variable (defcustom ido-completion-buffer "*Ido Completions*" "Name of completion buffer used by Ido. Set to nil to disable completion buffers popping up." - :type 'string - :group 'ido) + :type 'string) (defcustom ido-completion-buffer-all-completions nil "Non-nil means to show all completions in completion buffer. Otherwise, only the current list of matches is shown." - :type 'boolean - :group 'ido) + :type 'boolean) (defcustom ido-all-frames 'visible "Argument to pass to `walk-windows' when Ido is finding buffers. @@ -939,8 +876,7 @@ See documentation of `walk-windows' for useful values." :type '(choice (const :tag "Selected frame only" nil) (const :tag "All existing frames" t) (const :tag "All visible frames" visible) - (const :tag "All frames on this terminal" 0)) - :group 'ido) + (const :tag "All frames on this terminal" 0))) (defcustom ido-minibuffer-setup-hook nil "Ido-specific customization of minibuffer setup. @@ -954,8 +890,7 @@ with other packages. For instance: will constrain Emacs to a maximum minibuffer height of 3 lines when Ido is running. Copied from `icomplete-minibuffer-setup-hook'." - :type 'hook - :group 'ido) + :type 'hook) (defcustom ido-save-directory-list-file (locate-user-emacs-file "ido.last" ".ido.last") @@ -964,28 +899,24 @@ Variables stored are: `ido-last-directory-list', `ido-work-directory-list', `ido-work-file-list', and `ido-dir-file-cache'. Must be set before enabling Ido mode." :version "24.4" ; added locate-user-emacs-file - :type 'string - :group 'ido) + :type 'string) (defcustom ido-read-file-name-as-directory-commands '() "List of commands which use `read-file-name' to read a directory name. When `ido-everywhere' is non-nil, the commands in this list will read the directory using `ido-read-directory-name'." - :type '(repeat symbol) - :group 'ido) + :type '(repeat symbol)) (defcustom ido-read-file-name-non-ido '() "List of commands which shall not read file names the Ido way. When `ido-everywhere' is non-nil, the commands in this list will read the file name using normal `read-file-name' style." - :type '(repeat symbol) - :group 'ido) + :type '(repeat symbol)) (defcustom ido-before-fallback-functions '() "List of functions to call before calling a fallback command. The fallback command is passed as an argument to the functions." - :type 'hook - :group 'ido) + :type 'hook) ;;;; Keymaps @@ -1071,10 +1002,10 @@ The fallback command is passed as an argument to the functions." ;;;; Persistent variables -(defvar ido-file-history nil +(defvar ido-file-history nil "History of files selected using `ido-find-file'.") -(defvar ido-buffer-history nil +(defvar ido-buffer-history nil "History of buffers selected using `ido-switch-buffer'.") (defvar ido-last-directory-list nil @@ -1583,13 +1514,12 @@ Removes badly formatted data and ignored directories." (ido-save-history)) (defun ido-common-initialization () - (add-hook 'minibuffer-setup-hook 'ido-minibuffer-setup) - (add-hook 'choose-completion-string-functions 'ido-choose-completion-string)) + (add-hook 'minibuffer-setup-hook #'ido-minibuffer-setup) + (add-hook 'choose-completion-string-functions #'ido-choose-completion-string)) (define-minor-mode ido-everywhere "Toggle use of Ido for all buffer/file reading." :global t - :group 'ido (remove-function read-file-name-function #'ido-read-file-name) (remove-function read-buffer-function #'ido-read-buffer) (when ido-everywhere @@ -1619,13 +1549,13 @@ This function also adds a hook to the minibuffer." ((> (prefix-numeric-value arg) 0) 'both) (t nil))) - (ido-everywhere (if ido-everywhere 1 -1)) + (ido-everywhere (if (and ido-mode ido-everywhere) 1 -1)) (when ido-mode (ido-common-initialization) (ido-load-history) - (add-hook 'kill-emacs-hook 'ido-kill-emacs-hook) + (add-hook 'kill-emacs-hook #'ido-kill-emacs-hook) (let ((map (make-sparse-keymap))) (when (memq ido-mode '(file both)) @@ -2445,9 +2375,9 @@ If cursor is not at the end of the user input, move to end of input." nil ido-text 'ido-enter-insert-file)) ((eq ido-exit 'dired) - (funcall (cond ((eq method 'other-window) 'dired-other-window) - ((eq method 'other-frame) 'dired-other-frame) - (t 'dired)) + (funcall (cond ((eq method 'other-window) #'dired-other-window) + ((eq method 'other-frame) #'dired-other-frame) + (t #'dired)) (concat ido-current-directory (or ido-text "")))) ((eq ido-exit 'ffap) @@ -3480,13 +3410,18 @@ instead removed from the current item list." (defun ido-make-buffer-list-1 (&optional frame visible) "Return list of non-ignored buffer names." - (delq nil - (mapcar - (lambda (x) - (let ((name (buffer-name x))) - (if (not (or (ido-ignore-item-p name ido-ignore-buffers) (member name visible))) - name))) - (buffer-list frame)))) + (with-temp-buffer + ;; Each call to ido-ignore-item-p LET-binds case-fold-search. + ;; That is slow if there's no buffer-local binding available, + ;; roughly O(number of buffers). This hack avoids it. + (setq-local case-fold-search nil) + (delq nil + (mapcar + (lambda (x) + (let ((name (buffer-name x))) + (if (not (or (ido-ignore-item-p name ido-ignore-buffers) (member name visible))) + name))) + (buffer-list frame))))) (defun ido-make-buffer-list (default) "Return the current list of buffers. @@ -3598,7 +3533,7 @@ it is put to the start of the list." ;; tramp-ftp-file-name-p is available only when tramp ;; has been loaded. (fboundp 'tramp-ftp-file-name-p) - (funcall 'tramp-ftp-file-name-p dir) + (tramp-ftp-file-name-p dir) (string-match ":\\'" dir) (file-name-all-completions "" (concat dir "./")))))) (if (and compl @@ -3698,7 +3633,8 @@ in this list." (not (ido-local-file-exists-p x))) (and (not (ido-final-slash x)) (let (file-name-handler-alist) - (get-file-buffer x)))) x)) + (get-file-buffer x)))) + x)) ido-temp-list))))) (ido-to-end ;; move . files to end (delq nil (mapcar @@ -3731,7 +3667,8 @@ If MERGED is non-nil, each subdir is cons'ed with DIR." (delq nil (mapcar (lambda (name) - (and (ido-final-slash name) (not (ido-ignore-item-p name ido-ignore-directories)) + (and (ido-final-slash name) + (not (ido-ignore-item-p name ido-ignore-directories)) (if merged (cons name dir) name))) (ido-file-name-all-completions dir))))) @@ -3997,6 +3934,14 @@ If `ido-change-word-sub' cannot be found in WORD, return nil." (when (bobp) (next-completion 1))))) +(defun ido-completion-auto-help () + "Call `ido-completion-help' if `completion-auto-help' is non-nil." + (interactive) + ;; Note: `completion-auto-help' could also be `lazy', but this value + ;; is irrelevant to ido, which is fundamentally eager, so it is + ;; treated the same as t. + (when completion-auto-help + (ido-completion-help))) (defun ido-completion-help () "Show possible completions in the `ido-completion-buffer'." @@ -4041,7 +3986,7 @@ If `ido-change-word-sub' cannot be found in WORD, return nil." (t (copy-sequence (or ido-matches ido-cur-list)))) #'ido-file-lessp))) - ;;(add-hook 'completion-setup-hook 'completion-setup-function) + ;;(add-hook 'completion-setup-hook #'completion-setup-function) (display-completion-list completion-list)))))) ;;; KILL CURRENT BUFFER @@ -4707,7 +4652,9 @@ For details of keybindings, see `ido-find-file'." (not (input-pending-p))) (ido-trace "\n*start timer*") (setq ido-auto-merge-timer - (run-with-timer ido-auto-merge-delay-time nil 'ido-initiate-auto-merge (current-buffer)))))) + (run-with-timer ido-auto-merge-delay-time nil + #'ido-initiate-auto-merge + (current-buffer)))))) (setq ido-rescan t) @@ -4830,8 +4777,8 @@ Modified from `icomplete-completions'." "Minibuffer setup hook for Ido." ;; Copied from `icomplete-minibuffer-setup-hook'. (when (ido-active) - (add-hook 'pre-command-hook 'ido-tidy nil t) - (add-hook 'post-command-hook 'ido-exhibit nil t) + (add-hook 'pre-command-hook #'ido-tidy nil t) + (add-hook 'post-command-hook #'ido-exhibit nil t) (run-hooks 'ido-minibuffer-setup-hook) (when ido-initial-position (goto-char (+ (minibuffer-prompt-end) ido-initial-position)) diff --git a/lisp/ielm.el b/lisp/ielm.el index 41675c011d8..b3654b91d37 100644 --- a/lisp/ielm.el +++ b/lisp/ielm.el @@ -44,8 +44,7 @@ (defcustom ielm-noisy t "If non-nil, IELM will beep on error." - :type 'boolean - :group 'ielm) + :type 'boolean) (defcustom ielm-prompt-read-only t "If non-nil, the IELM prompt is read only. @@ -74,7 +73,6 @@ buffers, including IELM buffers. If you sometimes use IELM on text-only terminals or with `emacs -nw', you might wish to use another binding for `comint-kill-whole-line'." :type 'boolean - :group 'ielm :version "22.1") (defcustom ielm-prompt "ELISP> " @@ -90,8 +88,7 @@ does not update the prompt of an *ielm* buffer with a running process. For IELM buffers that are not called `*ielm*', you can execute \\[inferior-emacs-lisp-mode] in that IELM buffer to update the value, for new prompts. This works even if the buffer has a running process." - :type 'string - :group 'ielm) + :type 'string) (defvar ielm-prompt-internal "ELISP> " "Stored value of `ielm-prompt' in the current IELM buffer. @@ -103,8 +100,7 @@ customizes `ielm-prompt'.") "Controls whether \\<ielm-map>\\[ielm-return] has intelligent behavior in IELM. If non-nil, \\[ielm-return] evaluates input for complete sexps, or inserts a newline and indents for incomplete sexps. If nil, always inserts newlines." - :type 'boolean - :group 'ielm) + :type 'boolean) (defcustom ielm-dynamic-multiline-inputs t "Force multiline inputs to start from column zero? @@ -112,15 +108,13 @@ If non-nil, after entering the first line of an incomplete sexp, a newline will be inserted after the prompt, moving the input to the next line. This gives more frame width for large indented sexps, and allows functions such as `edebug-defun' to work with such inputs." - :type 'boolean - :group 'ielm) + :type 'boolean) (defvaralias 'inferior-emacs-lisp-mode-hook 'ielm-mode-hook) (defcustom ielm-mode-hook nil "Hooks to be run when IELM (`inferior-emacs-lisp-mode') is started." :options '(eldoc-mode) - :type 'hook - :group 'ielm) + :type 'hook) ;; We define these symbols (that are only used buffer-locally in ielm ;; buffers) this way to avoid having them be defined in the global @@ -366,9 +360,9 @@ nonempty, then flushes the buffer." ;; that same let. To avoid problems, neither of ;; these buffers should be alive during the ;; evaluation of form. - (let* ((*1 *) - (*2 **) - (*3 ***) + (let* ((*1 (bound-and-true-p *)) + (*2 (bound-and-true-p **)) + (*3 (bound-and-true-p ***)) (active-process (ielm-process)) (old-standard-output standard-output) new-standard-output @@ -453,11 +447,12 @@ nonempty, then flushes the buffer." (if error-type (progn (when ielm-noisy (ding)) - (setq output (concat output "*** " error-type " *** ")) - (setq output (concat output result))) + (setq output (concat output + "*** " error-type " *** " + result))) ;; There was no error, so shift the *** values - (setq *** **) - (setq ** *) + (setq *** (bound-and-true-p **)) + (setq ** (bound-and-true-p *)) (setq * result)) (when (or (not for-effect) (not (equal output ""))) (setq output (concat output "\n")))) @@ -541,8 +536,10 @@ Customized bindings may be defined in `ielm-map', which currently contains: (set (make-local-variable 'completion-at-point-functions) '(comint-replace-by-expanded-history ielm-complete-filename elisp-completion-at-point)) - (add-function :before-until (local 'eldoc-documentation-function) - #'elisp-eldoc-documentation-function) + (add-hook 'eldoc-documentation-functions + #'elisp-eldoc-var-docstring nil t) + (add-hook 'eldoc-documentation-functions + #'elisp-eldoc-funcall nil t) (set (make-local-variable 'ielm-prompt-internal) ielm-prompt) (set (make-local-variable 'comint-prompt-read-only) ielm-prompt-read-only) (setq comint-get-old-input 'ielm-get-old-input) diff --git a/lisp/image-dired.el b/lisp/image-dired.el index 768e941490d..6f297672caf 100644 --- a/lisp/image-dired.el +++ b/lisp/image-dired.el @@ -149,7 +149,6 @@ ;;; Code: (require 'dired) -(require 'format-spec) (require 'image-mode) (require 'widget) @@ -771,8 +770,8 @@ Increase at own risk.") process) (when (not (file-exists-p thumbnail-dir)) (message "Creating thumbnail directory") - (make-directory thumbnail-dir t) - (set-file-modes thumbnail-dir #o700)) + (with-file-modes #o700 + (make-directory thumbnail-dir t))) ;; Thumbnail file creation processes begin here and are marshaled ;; in a queue by `image-dired-create-thumb'. diff --git a/lisp/image-file.el b/lisp/image-file.el index 89cd75d50dd..22366c89e6a 100644 --- a/lisp/image-file.el +++ b/lisp/image-file.el @@ -32,6 +32,7 @@ ;;; Code: (require 'image) +(require 'image-converter) ;;;###autoload @@ -80,10 +81,13 @@ the variable is set using \\[customize]." (let ((exts-regexp (and image-file-name-extensions (concat "\\." - (regexp-opt (nconc (mapcar #'upcase - image-file-name-extensions) - image-file-name-extensions) - t) + (regexp-opt + (append (mapcar #'upcase image-file-name-extensions) + image-file-name-extensions + (mapcar #'upcase + image-converter-file-name-extensions) + image-converter-file-name-extensions) + t) "\\'")))) (mapconcat 'identity diff --git a/lisp/image-mode.el b/lisp/image-mode.el index 1bb213c2489..948e62e10d0 100644 --- a/lisp/image-mode.el +++ b/lisp/image-mode.el @@ -40,6 +40,7 @@ (require 'image) (require 'exif) +(require 'dired) (eval-when-compile (require 'cl-lib)) ;;; Image mode window-info management. @@ -614,21 +615,23 @@ Key bindings: (if (not (image-get-display-property)) (progn (when (condition-case err - (progn - (image-toggle-display-image) - t) - (unknown-image-type - (image-mode-as-text) - (funcall - (if (called-interactively-p 'any) 'error 'message) - "Unknown image type; consider switching `image-use-external-converter' on") - nil) - (error - (image-mode-as-text) - (funcall - (if (called-interactively-p 'any) 'error 'message) - "Cannot display image: %s" (cdr err)) - nil)) + (progn + (image-toggle-display-image) + t) + (unknown-image-type + (image-mode-as-text) + (funcall + (if (called-interactively-p 'any) 'error 'message) + (if image-use-external-converter + "Unknown image type" + "Unknown image type; consider switching `image-use-external-converter' on")) + nil) + (error + (image-mode-as-text) + (funcall + (if (called-interactively-p 'any) 'error 'message) + "Cannot display image: %s" (cdr err)) + nil)) ;; If attempt to display the image fails. (if (not (image-get-display-property)) (error "Invalid image")) @@ -816,13 +819,21 @@ was inserted." (- (nth 2 edges) (nth 0 edges)))) (max-height (when edges (- (nth 3 edges) (nth 1 edges)))) - (type (if (image--imagemagick-wanted-p filename) - 'imagemagick - (image-type file-or-data nil data-p))) (inhibit-read-only t) (buffer-undo-list t) (modified (buffer-modified-p)) - props image) + props image type) + + ;; If the data in the current buffer isn't from an existing file, + ;; but we have a file name (this happens when visiting images from + ;; a zip file, for instance), provide a type hint based on the + ;; suffix. + (when (and data-p filename) + (setq data-p (intern (format "image/%s" + (file-name-extension filename))))) + (setq type (if (image--imagemagick-wanted-p filename) + 'imagemagick + (image-type file-or-data nil data-p))) ;; Get the rotation data from the file, if any. (when (zerop image-transform-rotation) ; don't reset modified value @@ -839,10 +850,13 @@ was inserted." ;; :scale 1: If we do not set this, create-image will apply ;; default scaling based on font size. (setq image (if (not edges) - (create-image file-or-data type data-p :scale 1) + (create-image file-or-data type data-p :scale 1 + :format (and filename data-p)) (create-image file-or-data type data-p :scale 1 :max-width max-width - :max-height max-height))) + :max-height max-height + ;; Type hint. + :format (and filename data-p)))) ;; Discard any stale image data before looking it up again. (image-flush image) @@ -1072,28 +1086,87 @@ replacing the current Image mode buffer." (error "The buffer is not in Image mode")) (unless buffer-file-name (error "The current image is not associated with a file")) - (let* ((file (file-name-nondirectory buffer-file-name)) - (images (image-mode--images-in-directory file)) - (idx 0)) - (catch 'image-visit-next-file - (dolist (f images) - (if (string= f file) - (throw 'image-visit-next-file (1+ idx))) - (setq idx (1+ idx)))) - (setq idx (mod (+ idx (or n 1)) (length images))) - (let ((image (nth idx images)) - (dir (file-name-directory buffer-file-name))) - (find-alternate-file image) - ;; If we have dired buffer(s) open to where this image is, then - ;; place point on it. + (let ((next (image-mode--next-file buffer-file-name n))) + (unless next + (user-error "No %s file in this directory" + (if (> n 0) + "next" + "prev"))) + (if (stringp next) + (find-alternate-file next) + (funcall next)))) + +(defun image-mode--directory-buffers (file) + "Return a alist of type/buffer for all \"parent\" buffers to image FILE. +This is normally a list of dired buffers, but can also be archive and +tar mode buffers." + (let ((buffers nil) + (dir (file-name-directory file))) + (cond + ((and (boundp 'tar-superior-buffer) + tar-superior-buffer) + (when (buffer-live-p tar-superior-buffer) + (push (cons 'tar tar-superior-buffer) buffers))) + ((and (boundp 'archive-superior-buffer) + archive-superior-buffer) + (when (buffer-live-p archive-superior-buffer) + (push (cons 'archive archive-superior-buffer) buffers))) + (t + ;; Find a dired buffer. (dolist (buffer (buffer-list)) - (with-current-buffer buffer - (when (and (derived-mode-p 'dired-mode) + (with-current-buffer buffer + (when (and (derived-mode-p 'dired-mode) (equal (file-truename dir) (file-truename default-directory))) - (save-window-excursion - (switch-to-buffer (current-buffer) t t) - (dired-goto-file (expand-file-name image dir))))))))) + (push (cons 'dired (current-buffer)) buffers)))) + ;; If we can't find any buffers to navigate in, we open a dired + ;; buffer. + (unless buffers + (push (cons 'dired (find-file-noselect dir)) buffers) + (message "Opened a dired buffer on %s" dir)))) + buffers)) + +(declare-function archive-next-file-displayer "arc-mode") +(declare-function tar-next-file-displayer "tar-mode") + +(defun image-mode--next-file (file n) + "Go to the next image file in the parent buffer of FILE. +This is typically a dired buffer, but may also be a tar/archive buffer. +Return the next image file from that buffer. +If N is negative, go to the previous file." + (let ((regexp (image-file-name-regexp)) + (buffers (image-mode--directory-buffers file)) + next) + (dolist (buffer buffers) + ;; We do this traversal for all the dired buffers open on this + ;; directory. There probably is just one, but we want to move + ;; point in all of them. + (save-window-excursion + (switch-to-buffer (cdr buffer) t t) + (cl-case (car buffer) + ('dired + (dired-goto-file file) + (let (found) + (while (and (not found) + ;; Stop if we reach the end/start of the buffer. + (if (> n 0) + (not (eobp)) + (not (bobp)))) + (dired-next-line n) + (let ((candidate (dired-get-filename nil t))) + (when (and candidate + (string-match-p regexp candidate)) + (setq found candidate)))) + (if found + (setq next found) + ;; If we didn't find a next/prev file, then restore + ;; point. + (dired-goto-file file)))) + ('archive + (setq next (archive-next-file-displayer file regexp n))) + ('tar + (setq next (tar-next-file-displayer file regexp n)))))) + next)) (defun image-previous-file (&optional n) "Visit the preceding image in the same directory as the current file. diff --git a/lisp/image.el b/lisp/image.el index 4ea8594a974..4b2faa992fc 100644 --- a/lisp/image.el +++ b/lisp/image.el @@ -784,6 +784,7 @@ number, play until that number of seconds has elapsed." (if (setq timer (image-animate-timer image)) (cancel-timer timer)) (plist-put (cdr image) :animate-buffer (current-buffer)) + (plist-put (cdr image) :animate-tardiness 0) (run-with-timer 0.2 nil #'image-animate-timeout image (or index 0) (car animation) 0 limit (+ (float-time) 0.2))))) @@ -848,9 +849,14 @@ The minimum delay between successive frames is `image-minimum-frame-delay'. If the image has a non-nil :speed property, it acts as a multiplier for the animation speed. A negative value means to animate in reverse." + ;; We keep track of "how late" image frames arrive. We decay the + ;; previous cumulative value by 10% and then add the current delay. + (plist-put (cdr image) :animate-tardiness + (+ (* (plist-get (cdr image) :animate-tardiness) 0.9) + (float-time (time-since target-time)))) (when (and (buffer-live-p (plist-get (cdr image) :animate-buffer)) - ;; Delayed more than two seconds more than expected. - (or (time-less-p (time-since target-time) 2) + ;; Cumulatively delayed two seconds more than expected. + (or (< (plist-get (cdr image) :animate-tardiness) 2) (progn (message "Stopping animation; animation possibly too big") nil))) diff --git a/lisp/image/gravatar.el b/lisp/image/gravatar.el index b8542bc3c35..d1091e57cb5 100644 --- a/lisp/image/gravatar.el +++ b/lisp/image/gravatar.el @@ -26,6 +26,7 @@ (require 'url) (require 'url-cache) +(require 'dns) (eval-when-compile (require 'subr-x)) @@ -118,9 +119,55 @@ a gravatar for a given email address." :version "27.1" :group 'gravatar) -(defconst gravatar-base-url - "https://www.gravatar.com/avatar" - "Base URL for getting gravatars.") +(defconst gravatar-service-alist + `((gravatar . ,(lambda (_addr callback) + (funcall callback "https://www.gravatar.com/avatar"))) + (unicornify . ,(lambda (_addr callback) + (funcall callback "https://unicornify.pictures/avatar/"))) + (libravatar . ,#'gravatar--service-libravatar)) + "Alist of supported gravatar services.") + +(defcustom gravatar-service 'gravatar + "Symbol denoting gravatar-like service to use. +Note that certain services might ignore other options, such as +`gravatar-default-image' or certain values as with +`gravatar-rating'. + +Note that `'libravatar' has security implications: It can be used +to track whether you're reading a specific mail." + :type `(choice ,@(mapcar (lambda (s) `(const ,(car s))) + gravatar-service-alist)) + :version "28.1" + :link '(url-link "https://www.libravatar.org/") + :link '(url-link "https://unicornify.pictures/") + :link '(url-link "https://gravatar.com/") + :group 'gravatar) + +(defun gravatar--service-libravatar (addr callback) + "Find domain that hosts avatars for email address ADDR." + ;; implements https://wiki.libravatar.org/api/ + (save-match-data + (if (not (string-match ".+@\\(.+\\)" addr)) + (funcall callback "https://seccdn.libravatar.org/avatar") + (let ((domain (match-string 1 addr)) + (records '(("_avatars-sec" . "https") + ("_avatars" . "http"))) + func) + (setq func + (lambda (result) + (cond + (result + (funcall callback (format "%s://%s/avatar" + (cdar records) result))) + ((> (length records) 1) + (pop records) + (dns-query-asynchronous + (concat (caar records) "._tcp." domain) + func 'SRV)) + (t + (funcall callback "https://seccdn.libravatar.org/avatar"))))) + (dns-query-asynchronous + (concat (caar records) "._tcp." domain) func 'SRV))))) (defun gravatar-hash (mail-address) "Return the Gravatar hash for MAIL-ADDRESS." @@ -138,13 +185,18 @@ a gravatar for a given email address." ,@(and gravatar-size `((s ,gravatar-size)))))) -(defun gravatar-build-url (mail-address) - "Return the URL of a gravatar for MAIL-ADDRESS." +(defun gravatar-build-url (mail-address callback) + "Find the URL of a gravatar for MAIL-ADDRESS and call CALLBACK with it." ;; https://gravatar.com/site/implement/images/ - (format "%s/%s?%s" - gravatar-base-url - (gravatar-hash mail-address) - (gravatar--query-string))) + (let ((query-string (gravatar--query-string))) + (funcall (alist-get gravatar-service gravatar-service-alist) + mail-address + (lambda (url) + (funcall callback + (format "%s/%s?%s" + url + (gravatar-hash mail-address) + query-string)))))) (defun gravatar-get-data () "Return body of current URL buffer, or nil on failure." @@ -160,18 +212,23 @@ a gravatar for a given email address." When finished, call CALLBACK as (apply CALLBACK GRAVATAR CBARGS), where GRAVATAR is either an image descriptor, or the symbol `error' if the retrieval failed." - (let ((url (gravatar-build-url mail-address))) - (if (url-cache-expired url gravatar-cache-ttl) - (url-retrieve url #'gravatar-retrieved (list callback cbargs) t) - (with-current-buffer (url-fetch-from-cache url) - (gravatar-retrieved () callback cbargs))))) + (gravatar-build-url + mail-address + (lambda (url) + (if (url-cache-expired url gravatar-cache-ttl) + (url-retrieve url #'gravatar-retrieved (list callback cbargs) t) + (with-current-buffer (url-fetch-from-cache url) + (gravatar-retrieved () callback cbargs)))))) ;;;###autoload (defun gravatar-retrieve-synchronously (mail-address) "Synchronously retrieve a gravatar for MAIL-ADDRESS. Value is either an image descriptor, or the symbol `error' if the retrieval failed." - (let ((url (gravatar-build-url mail-address))) + (let ((url nil)) + (gravatar-build-url mail-address (lambda (u) (setq url u))) + (while (not url) + (sleep-for 0.01)) (with-current-buffer (if (url-cache-expired url gravatar-cache-ttl) (url-retrieve-synchronously url t) (url-fetch-from-cache url)) diff --git a/lisp/image/image-converter.el b/lisp/image/image-converter.el index b694052f5b9..ee1dc845fb5 100644 --- a/lisp/image/image-converter.el +++ b/lisp/image/image-converter.el @@ -42,6 +42,9 @@ installed on the system." (defvar image-converter-regexp nil "A regexp that matches the file name suffixes that can be converted.") +(defvar image-converter-file-name-extensions nil + "A list of file name suffixes that can be converted.") + (defvar image-converter--converters '((graphicsmagick :command ("gm" "convert") :probe ("-list" "format")) (ffmpeg :command "ffmpeg" :probe "-decoders") @@ -58,9 +61,11 @@ is a string, it should be a MIME format string like (unless image-converter (image-converter--find-converter)) ;; When image-converter was customized - (if (and image-converter (not image-converter-regexp)) - (when-let ((formats (image-converter--probe image-converter))) - (setq image-converter-regexp (concat "\\." (regexp-opt formats) "\\'")))) + (when (and image-converter (not image-converter-regexp)) + (when-let ((formats (image-converter--probe image-converter))) + (setq image-converter-regexp + (concat "\\." (regexp-opt formats) "\\'")) + (setq image-converter-file-name-extensions formats))) (and image-converter (or (and (not data-p) (string-match image-converter-regexp source)) @@ -183,7 +188,8 @@ data is returned as a string." (dolist (elem image-converter--converters) (when-let ((formats (image-converter--probe (car elem)))) (setq image-converter (car elem) - image-converter-regexp (concat "\\." (regexp-opt formats) "\\'")) + image-converter-regexp (concat "\\." (regexp-opt formats) "\\'") + image-converter-file-name-extensions formats) (throw 'done image-converter))))) (cl-defmethod image-converter--convert ((type (eql graphicsmagick)) source 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 033a7a5cbb5..c8318a3967f 100644 --- a/lisp/info.el +++ b/lisp/info.el @@ -3790,20 +3790,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) @@ -4101,22 +4089,28 @@ If FORK is non-nil, it is passed to `Info-goto-node'." :help "Go to top node of file"] ["Final Node" Info-final-node :help "Go to final node in this file"] + "---" ("Menu Item" ["You should never see this" report-emacs-bug t]) ("Reference" ["You should never see this" report-emacs-bug t]) ["Search..." Info-search :help "Search for regular expression in this Info file"] ["Search Next" Info-search-next :help "Search for another occurrence of regular expression"] - ["Go to Node..." Info-goto-node + "---" + ("History" + ["Back in history" Info-history-back :active Info-history + :help "Go back in history to the last node you were at"] + ["Forward in history" Info-history-forward :active Info-history-forward + :help "Go forward in history"] + ["Show History" Info-history :active Info-history-list + :help "Go to menu of visited nodes"]) + ("Go to" + ["Go to Node..." Info-goto-node :help "Go to a named node"] - ["Back in history" Info-history-back :active Info-history - :help "Go back in history to the last node you were at"] - ["Forward in history" Info-history-forward :active Info-history-forward - :help "Go forward in history"] - ["History" Info-history :active Info-history-list - :help "Go to menu of visited nodes"] - ["Table of Contents" Info-toc - :help "Go to table of contents"] + ["Table of Contents" Info-toc + :help "Go to table of contents"] + ["Go to Directory" Info-directory + :help "Go to the Info directory node."]) ("Index" ["Lookup a String..." Info-index :help "Look for a string in the index items"] @@ -4130,6 +4124,7 @@ If FORK is non-nil, it is passed to `Info-goto-node'." :help "Copy the name of the current node into the kill ring"] ["Clone Info buffer" clone-buffer :help "Create a twin copy of the current Info buffer."] + "---" ["Exit" quit-window :help "Stop reading Info"])) @@ -4380,6 +4375,7 @@ Moving within a node: already visible, try to go to the previous menu entry, or up if there is none. \\[beginning-of-buffer] Go to beginning of node. +\\[end-of-buffer] Go to end of node. Advanced commands: \\[Info-search] Search through this Info file for specified regexp, @@ -4975,9 +4971,8 @@ first line or header line, and for breadcrumb links.") "mouse-2: go to this node") 'mouse-face 'highlight))) (when (or not-fontified-p fontify-visited-p) - (put-text-property + (add-face-text-property (match-beginning 1) (match-end 1) - 'font-lock-face ;; Display visited menu items in a different face (if (and Info-fontify-visited-nodes (save-match-data @@ -5006,7 +5001,9 @@ first line or header line, and for breadcrumb links.") (caar hl)))) (setq res (car hl) hl nil) (setq hl (cdr hl)))) - res))) 'info-xref-visited 'info-xref))) + res))) + 'info-xref-visited 'info-xref) + 'append)) (when (and not-fontified-p (memq Info-hide-note-references '(t hide)) (not (Info-index-node))) @@ -5145,9 +5142,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/informat.el b/lisp/informat.el index 9873f66f215..7750ab00898 100644 --- a/lisp/informat.el +++ b/lisp/informat.el @@ -337,7 +337,7 @@ Check that every node pointer points to an existing node." (point)))) (Info-extract-menu-node-name)))) (goto-char (point-min)) - (while (re-search-forward "\\*note[ \n]*[^:\t]*:" nil t) + (while (re-search-forward "\\*note\\>[^:\t]*:" nil t) (goto-char (+ (match-beginning 0) 5)) (skip-chars-forward " \n") (Info-validate-node-name diff --git a/lisp/international/ja-dic-cnv.el b/lisp/international/ja-dic-cnv.el index 45e13462656..f5e70ce7021 100644 --- a/lisp/international/ja-dic-cnv.el +++ b/lisp/international/ja-dic-cnv.el @@ -48,7 +48,7 @@ (defvar ja-dic-filename "ja-dic.el") (defun skkdic-convert-okuri-ari (skkbuf buf) - (byte-compile-info-message "Processing OKURI-ARI entries") + (byte-compile-info "Processing OKURI-ARI entries" t) (goto-char (point-min)) (with-current-buffer buf (insert ";; Setting okuri-ari entries.\n" @@ -97,7 +97,7 @@ ("ゆã" "è¡Œ"))) (defun skkdic-convert-postfix (skkbuf buf) - (byte-compile-info-message "Processing POSTFIX entries") + (byte-compile-info "Processing POSTFIX entries" t) (goto-char (point-min)) (with-current-buffer buf (insert ";; Setting postfix entries.\n" @@ -151,7 +151,7 @@ (defconst skkdic-prefix-list '(skkdic-prefix-list)) (defun skkdic-convert-prefix (skkbuf buf) - (byte-compile-info-message "Processing PREFIX entries") + (byte-compile-info "Processing PREFIX entries" t) (goto-char (point-min)) (with-current-buffer buf (insert ";; Setting prefix entries.\n" @@ -273,7 +273,7 @@ (defun skkdic-collect-okuri-nasi () (save-excursion (let ((progress (make-progress-reporter - (byte-compile-info-message "Collecting OKURI-NASI entries") + (byte-compile-info "Collecting OKURI-NASI entries" t) (point) (point-max) nil 10))) (while (re-search-forward "^\\(\\cH+\\) \\(/\\cj.*\\)/$" @@ -301,7 +301,7 @@ "(skkdic-set-okuri-nasi\n") (let ((l (nreverse skkdic-okuri-nasi-entries)) (progress (make-progress-reporter - (byte-compile-info-message "Processing OKURI-NASI entries") + (byte-compile-info "Processing OKURI-NASI entries" t) 0 skkdic-okuri-nasi-entries-count nil 10)) (count 0)) @@ -531,8 +531,7 @@ To get complete usage, invoke: ',(let ((l entries) (map '(skdic-okuri-nasi)) (progress (make-progress-reporter - (byte-compile-info-message - "Extracting OKURI-NASI entries") + (byte-compile-info "Extracting OKURI-NASI entries") 0 (length entries))) (count 0) entry) diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el index 9644b0effd6..7714a778fcb 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/mule-conf.el b/lisp/international/mule-conf.el index e6e6135243f..edda79ba4ee 100644 --- a/lisp/international/mule-conf.el +++ b/lisp/international/mule-conf.el @@ -1517,6 +1517,10 @@ for decoding and encoding files, process I/O, etc." :charset-list '(unicode) :pre-write-conversion 'utf-7-pre-write-conversion :post-read-conversion 'utf-7-post-read-conversion) +;; FIXME: 'define-coding-system' automatically sets :ascii-compatible-p, +;; to any encoding whose :coding-type is 'utf-8', but UTF-7 is not ASCII +;; compatible, so we override that here (bug#40407). +(coding-system-put 'utf-7 :ascii-compatible-p nil) (define-coding-system 'utf-7-imap "UTF-7 encoding of Unicode, IMAP version (RFC 2060)" @@ -1525,6 +1529,8 @@ for decoding and encoding files, process I/O, etc." :charset-list '(unicode) :pre-write-conversion 'utf-7-imap-pre-write-conversion :post-read-conversion 'utf-7-imap-post-read-conversion) +;; See comment for utf-7 above. +(coding-system-put 'utf-7-imap :ascii-compatible-p nil) ;; Use us-ascii for terminal output if some other coding system is not ;; specified explicitly. diff --git a/lisp/international/mule.el b/lisp/international/mule.el index 86f3d2a34bf..df71205d515 100644 --- a/lisp/international/mule.el +++ b/lisp/international/mule.el @@ -30,12 +30,13 @@ ;;; Code: -;; FIXME? Are these still relevant? Nothing uses them AFAICS. (defconst mule-version "6.0 (HANACHIRUSATO)" "\ Version number and name of this version of MULE (multilingual environment).") +(make-obsolete-variable 'mule-version nil "28.1") (defconst mule-version-date "2003.9.1" "\ Distribution date of this version of MULE (multilingual environment).") +(make-obsolete-variable 'mule-version-date nil "28.1") ;;; CHARSET @@ -768,11 +769,12 @@ decoded by the coding system itself and before any functions in `after-insert-functions' are called. This function is passed one argument: the number of characters in the text to convert, with point at the start of the text. The function should leave point -unchanged, and should return the new character count. Note that -this function should avoid reading from files or receiving text -from subprocesses -- anything that could invoke decoding; if it -must do so, it should bind `coding-system-for-read' to a value -other than the current coding-system, to avoid infinite recursion. +and the match data unchanged, and should return the new character +count. Note that this function should avoid reading from files +or receiving text from subprocesses -- anything that could invoke +decoding; if it must do so, it should bind +`coding-system-for-read' to a value other than the current +coding-system, to avoid infinite recursion. `:pre-write-conversion' @@ -780,13 +782,13 @@ VALUE must be a function to call after all functions in `write-region-annotate-functions' and `buffer-file-format' are called, and before the text is encoded by the coding system itself. This function should convert the whole text in the -current buffer. For backward compatibility, this function is -passed two arguments which can be ignored. Note that this -function should avoid writing to files or sending text to -subprocesses -- anything that could invoke encoding; if it -must do so, it should bind `coding-system-for-write' to a -value other than the current coding-system, to avoid infinite -recursion. +current buffer, and leave the match data unchanged. For backward +compatibility, this function is passed two arguments which can be +ignored. Note that this function should avoid writing to files +or sending text to subprocesses -- anything that could invoke +encoding; if it must do so, it should bind +`coding-system-for-write' to a value other than the current +coding-system, to avoid infinite recursion. `:default-char' 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 4f1bcf2f94e..a6dcd02dc68 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/international/ucs-normalize.el b/lisp/international/ucs-normalize.el index 201ff6b9b17..b703d3dd2f2 100644 --- a/lisp/international/ucs-normalize.el +++ b/lisp/international/ucs-normalize.el @@ -612,14 +612,16 @@ COMPOSITION-PREDICATE will be used to compose region." (defun ucs-normalize-hfs-nfd-post-read-conversion (len) (save-excursion (save-restriction - (narrow-to-region (point) (+ (point) len)) - (ucs-normalize-HFS-NFC-region (point-min) (point-max)) - (- (point-max) (point-min))))) + (save-match-data + (narrow-to-region (point) (+ (point) len)) + (ucs-normalize-HFS-NFC-region (point-min) (point-max)) + (- (point-max) (point-min)))))) ;; Pre-write conversion for `utf-8-hfs'. ;; _from and _to are legacy arguments (see `define-coding-system'). (defun ucs-normalize-hfs-nfd-pre-write-conversion (_from _to) - (ucs-normalize-HFS-NFD-region (point-min) (point-max))) + (save-match-data + (ucs-normalize-HFS-NFD-region (point-min) (point-max)))) ;;; coding-system definition (define-coding-system 'utf-8-hfs diff --git a/lisp/isearch.el b/lisp/isearch.el index 57b13a38d67..81e83d79509 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -2011,15 +2011,16 @@ Turning on character-folding turns off regexp mode.") (defvar isearch-message-properties minibuffer-prompt-properties "Text properties that are added to the isearch prompt.") -(defun isearch--momentary-message (string) - "Print STRING at the end of the isearch prompt for 1 second." +(defun isearch--momentary-message (string &optional seconds) + "Print STRING at the end of the isearch prompt for 1 second. +The optional argument SECONDS overrides the number of seconds." (let ((message-log-max nil)) (message "%s%s%s" (isearch-message-prefix nil isearch-nonincremental) isearch-message (apply #'propertize (format " [%s]" string) isearch-message-properties))) - (sit-for 1)) + (sit-for (or seconds 1))) (isearch-define-mode-toggle lax-whitespace " " nil "In ordinary search, toggles the value of the variable @@ -2381,22 +2382,17 @@ respectively)." (funcall isearch-regexp-function isearch-string)) (isearch-regexp-function (word-search-regexp isearch-string)) (isearch-regexp isearch-string) - ((if (and (eq isearch-case-fold-search t) - search-upper-case) - (isearch-no-upper-case-p - isearch-string isearch-regexp) - isearch-case-fold-search) - ;; Turn isearch-string into a case-insensitive - ;; regexp. - (mapconcat - (lambda (c) - (let ((s (string c))) - (if (string-match "[[:alpha:]]" s) - (format "[%s%s]" (upcase s) (downcase s)) - (regexp-quote s)))) - isearch-string "")) (t (regexp-quote isearch-string))))) - (funcall hi-lock-func regexp (hi-lock-read-face-name))) + (let ((case-fold-search isearch-case-fold-search) + ;; Set `search-upper-case' to nil to not call + ;; `isearch-no-upper-case-p' in `hi-lock'. + (search-upper-case nil) + (search-spaces-regexp + (if (if isearch-regexp + isearch-regexp-lax-whitespace + isearch-lax-whitespace) + search-whitespace-regexp))) + (funcall hi-lock-func regexp (hi-lock-read-face-name) isearch-string))) (and isearch-recursive-edit (exit-recursive-edit))) (defun isearch-highlight-regexp () @@ -2404,14 +2400,18 @@ respectively)." The arguments passed to `highlight-regexp' are the regexp from the last search and the face from `hi-lock-read-face-name'." (interactive) - (isearch--highlight-regexp-or-lines 'highlight-regexp)) + (isearch--highlight-regexp-or-lines + #'(lambda (regexp face lighter) + (highlight-regexp regexp face nil lighter)))) (defun isearch-highlight-lines-matching-regexp () "Exit Isearch mode and call `highlight-lines-matching-regexp'. The arguments passed to `highlight-lines-matching-regexp' are the regexp from the last search and the face from `hi-lock-read-face-name'." (interactive) - (isearch--highlight-regexp-or-lines 'highlight-lines-matching-regexp)) + (isearch--highlight-regexp-or-lines + #'(lambda (regexp face _lighter) + (highlight-lines-matching-regexp regexp face)))) (defun isearch-delete-char () @@ -3443,7 +3443,10 @@ Optional third argument, if t, means if fail just return nil (no error). (string-match "\\`Regular expression too big" isearch-error)) (cond (isearch-regexp-function - (setq isearch-error "Too many words")) + (setq isearch-error nil) + (setq isearch-regexp-function nil) + (isearch-search-and-update) + (isearch--momentary-message "Too many words; switched to literal mode" 2)) ((and isearch-lax-whitespace search-whitespace-regexp) (setq isearch-error "Too many spaces for whitespace matching")))))) @@ -3866,9 +3869,10 @@ Attempt to do the search exactly the way the pending Isearch would." (isearch-regexp-lax-whitespace isearch-lazy-highlight-regexp-lax-whitespace) (isearch-forward isearch-lazy-highlight-forward) - ;; Match invisible text only when counting matches - ;; and user can visit invisible matches - (search-invisible (and isearch-lazy-count search-invisible t)) + ;; Don't match invisible text unless it can be opened + ;; or when counting matches and user can visit hidden matches + (search-invisible (or (eq search-invisible 'open) + (and isearch-lazy-count search-invisible))) (retry t) (success nil)) ;; Use a loop like in `isearch-search'. diff --git a/lisp/jit-lock.el b/lisp/jit-lock.el index 95cc02197c1..8b3384ae827 100644 --- a/lisp/jit-lock.el +++ b/lisp/jit-lock.el @@ -48,8 +48,7 @@ Preserves the `buffer-modified-p' state of the current buffer." "Jit-lock fontifies chunks of at most this many characters at a time. This variable controls both display-time and stealth fontification." - :type 'integer - :group 'jit-lock) + :type 'integer) (defcustom jit-lock-stealth-time nil @@ -59,8 +58,7 @@ If nil, stealth fontification is never performed. The value of this variable is used when JIT Lock mode is turned on." :type '(choice (const :tag "never" nil) - (number :tag "seconds" :value 16)) - :group 'jit-lock) + (number :tag "seconds" :value 16))) (defcustom jit-lock-stealth-nice 0.5 @@ -72,8 +70,7 @@ To reduce machine load during stealth fontification, at the cost of stealth taking longer to fontify, you could increase the value of this variable. See also `jit-lock-stealth-load'." :type '(choice (const :tag "never" nil) - (number :tag "seconds")) - :group 'jit-lock) + (number :tag "seconds"))) (defcustom jit-lock-stealth-load @@ -89,14 +86,12 @@ See also `jit-lock-stealth-nice'." :type (if (condition-case nil (load-average) (error)) '(choice (const :tag "never" nil) (integer :tag "load")) - '(const :format "%t: unsupported\n" nil)) - :group 'jit-lock) + '(const :format "%t: unsupported\n" nil))) (defcustom jit-lock-stealth-verbose nil "If non-nil, means stealth fontification should show status messages." - :type 'boolean - :group 'jit-lock) + :type 'boolean) (defvaralias 'jit-lock-defer-contextually 'jit-lock-contextually) @@ -121,13 +116,11 @@ and sets the buffer-local value of `jit-lock-contextually' to t). The value of this variable is used when JIT Lock mode is turned on." :type '(choice (const :tag "never" nil) (const :tag "always" t) - (other :tag "syntax-driven" syntax-driven)) - :group 'jit-lock) + (other :tag "syntax-driven" syntax-driven))) (defcustom jit-lock-context-time 0.5 "Idle time after which text is contextually refontified, if applicable." - :type '(number :tag "seconds") - :group 'jit-lock) + :type '(number :tag "seconds")) (defcustom jit-lock-antiblink-grace 2 "Delay after which to refontify unterminated strings and comments. @@ -140,14 +133,12 @@ and comments, the delay helps avoid unpleasant \"blinking\", between string/comment and non-string/non-comment fontification." :type '(choice (const :tag "never" nil) (number :tag "seconds")) - :group 'jit-lock :version "27.1") (defcustom jit-lock-defer-time nil ;; 0.25 "Idle time after which deferred fontification should take place. If nil, fontification is not deferred. If 0, then fontification is only deferred while there is input pending." - :group 'jit-lock :type '(choice (const :tag "never" nil) (number :tag "seconds"))) @@ -156,9 +147,10 @@ If 0, then fontification is only deferred while there is input pending." (defvar-local jit-lock-mode nil "Non-nil means Just-in-time Lock mode is active.") -(defvar-local jit-lock-functions nil - "Functions to do the actual fontification. -They are called with two arguments: the START and END of the region to fontify.") +(defvar jit-lock-functions nil + "Special hook run to do the actual fontification. +The functions are called with two arguments: +the START and END of the region to fontify.") (defvar-local jit-lock-context-unfontify-pos nil "Consider text after this position as contextually unfontified. @@ -268,7 +260,7 @@ If you need to debug code run from jit-lock, see `jit-lock-debug-mode'." ;; Setup our hooks. (add-hook 'after-change-functions 'jit-lock-after-change nil t) - (add-hook 'fontification-functions 'jit-lock-function)) + (add-hook 'fontification-functions 'jit-lock-function nil t)) ;; Turn Just-in-time Lock mode off. (t @@ -300,7 +292,7 @@ If you need to debug code run from jit-lock, see `jit-lock-debug-mode'." When this minor mode is enabled, jit-lock runs as little code as possible during redisplay and moves the rest to a timer, where things like `debug-on-error' and Edebug can be used." - :global t :group 'jit-lock + :global t (when jit-lock-defer-timer (cancel-timer jit-lock-defer-timer) (setq jit-lock-defer-timer nil)) @@ -350,7 +342,8 @@ If non-nil, CONTEXTUAL means that a contextual fontification would be useful." "Unregister FUN as a fontification function. Only applies to the current buffer." (remove-hook 'jit-lock-functions fun t) - (unless jit-lock-functions (jit-lock-mode nil))) + (when (member jit-lock-functions '(nil '(t))) + (jit-lock-mode nil))) (defun jit-lock-refontify (&optional beg end) "Force refontification of the region BEG..END (default whole buffer)." @@ -444,8 +437,8 @@ Defaults to the whole buffer. END can be out of bounds." (quit (put-text-property start next 'fontified nil) (signal (car err) (cdr err)))))) - ;; In case we fontified more than requested, take advantage of the - ;; good news. + ;; In case we fontified more than requested, take + ;; advantage of the good news. (when (or (< tight-beg start) (> tight-end next)) (put-text-property tight-beg tight-end 'fontified t)) diff --git a/lisp/json.el b/lisp/json.el index ac323dac295..9002e868537 100644 --- a/lisp/json.el +++ b/lisp/json.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2006-2020 Free Software Foundation, Inc. ;; Author: Theresa O'Connor <ted@oconnor.cx> -;; Version: 1.4 +;; Version: 1.5 ;; Keywords: convenience ;; This file is part of GNU Emacs. @@ -29,11 +29,11 @@ ;; Learn all about JSON here: <URL:http://json.org/>. ;; The user-serviceable entry points for the parser are the functions -;; `json-read' and `json-read-from-string'. The encoder has a single +;; `json-read' and `json-read-from-string'. The encoder has a single ;; entry point, `json-encode'. ;; Since there are several natural representations of key-value pair -;; mappings in elisp (alist, plist, hash-table), `json-read' allows you +;; mappings in Elisp (alist, plist, hash-table), `json-read' allows you ;; to specify which you'd prefer (see `json-object-type' and ;; `json-array-type'). @@ -55,6 +55,7 @@ ;;; Code: (require 'map) +(require 'seq) (require 'subr-x) ;; Parameters @@ -113,8 +114,10 @@ Used only when `json-encoding-pretty-print' is non-nil.") "If non-nil, then the output of `json-encode' will be pretty-printed.") (defvar json-encoding-lisp-style-closings nil - "If non-nil, ] and } closings will be formatted lisp-style, -without indentation.") + "If non-nil, delimiters ] and } will be formatted Lisp-style. +This means they will be placed on the same line as the last +element of the respective array or object, without indentation. +Used only when `json-encoding-pretty-print' is non-nil.") (defvar json-encoding-object-sort-predicate nil "Sorting predicate for JSON object keys during encoding. @@ -124,88 +127,81 @@ instance, setting this to `string<' will have JSON object keys ordered alphabetically.") (defvar json-pre-element-read-function nil - "Function called (if non-nil) by `json-read-array' and -`json-read-object' right before reading a JSON array or object, -respectively. The function is called with one argument, which is -the current JSON key.") + "If non-nil, a function to call before reading a JSON array or object. +It is called by `json-read-array' and `json-read-object', +respectively, with one argument, which is the current JSON key.") (defvar json-post-element-read-function nil - "Function called (if non-nil) by `json-read-array' and -`json-read-object' right after reading a JSON array or object, -respectively.") + "If non-nil, a function to call after reading a JSON array or object. +It is called by `json-read-array' and `json-read-object', +respectively, with no arguments.") ;;; Utilities -(defun json-join (strings separator) - "Join STRINGS with SEPARATOR." - (mapconcat 'identity strings separator)) +(define-obsolete-function-alias 'json-join #'string-join "28.1") (defun json-alist-p (list) - "Non-null if and only if LIST is an alist with simple keys." - (while (consp list) - (setq list (if (and (consp (car list)) - (atom (caar list))) - (cdr list) - 'not-alist))) + "Non-nil if and only if LIST is an alist with simple keys." + (declare (pure t) (side-effect-free error-free)) + (while (and (consp (car-safe list)) + (atom (caar list)) + (setq list (cdr list)))) (null list)) (defun json-plist-p (list) - "Non-null if and only if LIST is a plist with keyword keys." - (while (consp list) - (setq list (if (and (keywordp (car list)) - (consp (cdr list))) - (cddr list) - 'not-plist))) + "Non-nil if and only if LIST is a plist with keyword keys." + (declare (pure t) (side-effect-free error-free)) + (while (and (keywordp (car-safe list)) + (consp (cdr list)) + (setq list (cddr list)))) (null list)) -(defun json--plist-reverse (plist) - "Return a copy of PLIST in reverse order. -Unlike `reverse', this keeps the property-value pairs intact." - (let (res) - (while plist - (let ((prop (pop plist)) - (val (pop plist))) - (push val res) - (push prop res))) - res)) - -(defun json--plist-to-alist (plist) - "Return an alist of the property-value pairs in PLIST." - (let (res) - (while plist - (let ((prop (pop plist)) - (val (pop plist))) - (push (cons prop val) res))) - (nreverse res))) - -(defmacro json--with-indentation (body) +(defun json--plist-nreverse (plist) + "Return PLIST in reverse order. +Unlike `nreverse', this keeps the ordering of each property +relative to its value intact. Like `nreverse', this function may +destructively modify PLIST to produce the result." + (let (prev (next (cddr plist))) + (while next + (setcdr (cdr plist) prev) + (setq prev plist plist next next (cddr next)) + (setcdr (cdr plist) prev))) + plist) + +(defmacro json--with-indentation (&rest body) + "Evaluate BODY with the correct indentation for JSON encoding. +This macro binds `json--encoding-current-indentation' according +to `json-encoding-pretty-print' around BODY." + (declare (debug t) (indent 0)) `(let ((json--encoding-current-indentation (if json-encoding-pretty-print (concat json--encoding-current-indentation json-encoding-default-indentation) ""))) - ,body)) + ,@body)) ;; Reader utilities (define-inline json-advance (&optional n) - "Advance N characters forward." + "Advance N characters forward, or 1 character if N is nil. +On reaching the end of the accessible region of the buffer, stop +and signal an error." (inline-quote (forward-char ,n))) (define-inline json-peek () - "Return the character at point." + "Return the character at point. +At the end of the accessible region of the buffer, return 0." (inline-quote (following-char))) (define-inline json-pop () - "Advance past the character at point, returning it." + "Advance past the character at point, returning it. +Signal `json-end-of-file' if called at the end of the buffer." (inline-quote - (let ((char (json-peek))) - (if (zerop char) - (signal 'json-end-of-file nil) - (json-advance) - char)))) + (prog1 (or (char-after) + (signal 'json-end-of-file ())) + (json-advance)))) (define-inline json-skip-whitespace () "Skip past the whitespace at point." @@ -213,7 +209,7 @@ Unlike `reverse', this keeps the property-value pairs intact." ;; https://www.ecma-international.org/publications/files/ECMA-ST/ECMA-404.pdf ;; or https://tools.ietf.org/html/rfc7159#section-2 for the ;; definition of whitespace in JSON. - (inline-quote (skip-chars-forward "\t\r\n "))) + (inline-quote (skip-chars-forward "\t\n\r "))) @@ -227,6 +223,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)) @@ -235,8 +232,8 @@ Unlike `reverse', this keeps the property-value pairs intact." ;;; Paths (defvar json--path '() - "Used internally by `json-path-to-position' to keep track of -the path during recursive calls to `json-read'.") + "Keeps track of the path during recursive calls to `json-read'. +Used internally by `json-path-to-position'.") (defun json--record-path (key) "Record the KEY to the current JSON path. @@ -247,7 +244,7 @@ Used internally by `json-path-to-position'." "Check if the last parsed JSON structure passed POSITION. Used internally by `json-path-to-position'." (let ((start (caar json--path))) - (when (< start position (+ (point) 1)) + (when (< start position (1+ (point))) (throw :json-path (list :path (nreverse (mapcar #'cdr json--path)) :match-start start :match-end (point))))) @@ -265,13 +262,13 @@ properties: :path -- A list of strings and numbers forming the path to the JSON element at the given position. Strings denote object names, while numbers denote array - indexes. + indices. :match-start -- Position where the matched JSON element begins. :match-end -- Position where the matched JSON element ends. -This can for instance be useful to determine the path to a JSON +This can, for instance, be useful to determine the path to a JSON element in a deeply nested structure." (save-excursion (unless string @@ -279,7 +276,7 @@ element in a deeply nested structure." (let* ((json--path '()) (json-pre-element-read-function #'json--record-path) (json-post-element-read-function - (apply-partially #'json--check-position position)) + (lambda () (json--check-position position))) (path (catch :json-path (if string (json-read-from-string string) @@ -289,38 +286,33 @@ element in a deeply nested structure." ;;; Keywords -(defvar json-keywords '("true" "false" "null") +(defconst json-keywords '("true" "false" "null") "List of JSON keywords.") +(make-obsolete-variable 'json-keywords "it is no longer used." "28.1") ;; Keyword parsing +;; Characters that can follow a JSON value. +(rx-define json--post-value (| (in "\t\n\r ,]}") eos)) + (defun json-read-keyword (keyword) - "Read a JSON keyword at point. -KEYWORD is the keyword expected." - (unless (member keyword json-keywords) - (signal 'json-unknown-keyword (list keyword))) - (mapc (lambda (char) - (when (/= char (json-peek)) - (signal 'json-unknown-keyword - (list (save-excursion - (backward-word-strictly 1) - (thing-at-point 'word))))) - (json-advance)) - keyword) - (json-skip-whitespace) - (unless (looking-at "\\([],}]\\|$\\)") - (signal 'json-unknown-keyword - (list (save-excursion - (backward-word-strictly 1) - (thing-at-point 'word))))) - (cond ((string-equal keyword "true") t) - ((string-equal keyword "false") json-false) - ((string-equal keyword "null") json-null))) + "Read the expected JSON KEYWORD at point." + (prog1 (cond ((equal keyword "true") t) + ((equal keyword "false") json-false) + ((equal keyword "null") json-null) + (t (signal 'json-unknown-keyword (list keyword)))) + (or (looking-at-p keyword) + (signal 'json-unknown-keyword (list (thing-at-point 'word)))) + (json-advance (length keyword)) + (or (looking-at-p (rx json--post-value)) + (signal 'json-unknown-keyword (list (thing-at-point 'word)))) + (json-skip-whitespace))) ;; Keyword encoding (defun json-encode-keyword (keyword) "Encode KEYWORD as a JSON value." + (declare (side-effect-free t)) (cond ((eq keyword t) "true") ((eq keyword json-false) "false") ((eq keyword json-null) "null"))) @@ -329,37 +321,31 @@ KEYWORD is the keyword expected." ;; Number parsing -(defun json-read-number (&optional sign) - "Read the JSON number following point. -The optional SIGN argument is for internal use. - -N.B.: Only numbers which can fit in Emacs Lisp's native number -representation will be parsed correctly." - ;; If SIGN is non-nil, the number is explicitly signed. - (let ((number-regexp - "\\([0-9]+\\)?\\(\\.[0-9]+\\)?\\([Ee][+-]?[0-9]+\\)?")) - (cond ((and (null sign) (= (json-peek) ?-)) - (json-advance) - (- (json-read-number t))) - ((and (null sign) (= (json-peek) ?+)) - (json-advance) - (json-read-number t)) - ((and (looking-at number-regexp) - (or (match-beginning 1) - (match-beginning 2))) - (goto-char (match-end 0)) - (string-to-number (match-string 0))) - (t (signal 'json-number-format (list (point))))))) +(rx-define json--number + (: (? ?-) ; Sign. + (| (: (in "1-9") (* digit)) ?0) ; Integer. + (? ?. (+ digit)) ; Fraction. + (? (in "Ee") (? (in ?+ ?-)) (+ digit)))) ; Exponent. + +(defun json-read-number (&optional _sign) + "Read the JSON number following point." + (declare (advertised-calling-convention () "28.1")) + (or (looking-at (rx json--number)) + (signal 'json-number-format (list (point)))) + (goto-char (match-end 0)) + (prog1 (string-to-number (match-string 0)) + (or (looking-at-p (rx json--post-value)) + (signal 'json-number-format (list (point)))) + (json-skip-whitespace))) ;; Number encoding -(defun json-encode-number (number) - "Return a JSON representation of NUMBER." - (format "%s" number)) +(defalias 'json-encode-number #'number-to-string + "Return a JSON representation of NUMBER.") ;;; Strings -(defvar json-special-chars +(defconst json-special-chars '((?\" . ?\") (?\\ . ?\\) (?b . ?\b) @@ -367,7 +353,7 @@ representation will be parsed correctly." (?n . ?\n) (?r . ?\r) (?t . ?\t)) - "Characters which are escaped in JSON, with their elisp counterparts.") + "Characters which are escaped in JSON, with their Elisp counterparts.") ;; String parsing @@ -377,48 +363,47 @@ representation will be parsed correctly." (defun json-read-escaped-char () "Read the JSON string escaped character at point." - ;; Skip over the '\' + ;; Skip over the '\'. (json-advance) - (let* ((char (json-pop)) - (special (assq char json-special-chars))) + (let ((char (json-pop))) (cond - (special (cdr special)) - ((not (eq char ?u)) char) + ((cdr (assq char json-special-chars))) + ((/= char ?u) char) ;; Special-case UTF-16 surrogate pairs, ;; cf. <https://tools.ietf.org/html/rfc7159#section-7>. Note that ;; this clause overlaps with the next one and therefore has to ;; come first. ((looking-at - (rx (group (any "Dd") (any "89ABab") (= 2 (any xdigit))) - "\\u" (group (any "Dd") (any "C-Fc-f") (= 2 (any xdigit))))) + (rx (group (any "Dd") (any "89ABab") (= 2 xdigit)) + "\\u" (group (any "Dd") (any "C-Fc-f") (= 2 xdigit)))) (json-advance 10) (json--decode-utf-16-surrogates (string-to-number (match-string 1) 16) (string-to-number (match-string 2) 16))) ((looking-at (rx (= 4 xdigit))) - (let ((hex (match-string 0))) - (json-advance 4) - (string-to-number hex 16))) + (json-advance 4) + (string-to-number (match-string 0) 16)) (t (signal 'json-string-escape (list (point))))))) (defun json-read-string () "Read the JSON string at point." - (unless (= (json-peek) ?\") - (signal 'json-string-format (list "doesn't start with `\"'!"))) - ;; Skip over the '"' + ;; Skip over the '"'. (json-advance) (let ((characters '()) (char (json-peek))) - (while (not (= char ?\")) + (while (/= char ?\") (when (< char 32) - (signal 'json-string-format (list (prin1-char char)))) + (if (zerop char) + (signal 'json-end-of-file ()) + (signal 'json-string-format (list char)))) (push (if (= char ?\\) (json-read-escaped-char) - (json-pop)) + (json-advance) + char) characters) (setq char (json-peek))) - ;; Skip over the '"' + ;; Skip over the '"'. (json-advance) (if characters (concat (nreverse characters)) @@ -426,29 +411,47 @@ representation will be parsed correctly." ;; String encoding +;; Escape only quotation mark, backslash, and the control +;; characters U+0000 to U+001F (RFC 4627, ECMA-404). +(rx-define json--escape (in ?\" ?\\ cntrl)) + +(defvar json--long-string-threshold 200 + "Length above which strings are considered long for JSON encoding. +It is generally faster to manipulate such strings in a buffer +rather than directly.") + +(defvar json--string-buffer nil + "Buffer used for encoding Lisp strings as JSON. +Initialized lazily by `json-encode-string'.") + (defun json-encode-string (string) "Return a JSON representation of STRING." - ;; Reimplement the meat of `replace-regexp-in-string', for - ;; performance (bug#20154). - (let ((l (length string)) - (start 0) - res mb) - ;; Only escape quotation mark, backslash and the control - ;; characters U+0000 to U+001F (RFC 4627, ECMA-404). - (while (setq mb (string-match "[\"\\[:cntrl:]]" string start)) - (let* ((c (aref string mb)) - (special (rassq c json-special-chars))) - (push (substring string start mb) res) - (push (if special - ;; Special JSON character (\n, \r, etc.). - (string ?\\ (car special)) - ;; Fallback: UCS code point in \uNNNN form. - (format "\\u%04x" c)) - res) - (setq start (1+ mb)))) - (push (substring string start l) res) - (push "\"" res) - (apply #'concat "\"" (nreverse res)))) + ;; Try to avoid buffer overhead in trivial cases, while also + ;; avoiding searching pathological strings for escape characters. + ;; Since `string-match-p' doesn't take a LIMIT argument, we use + ;; string length as our heuristic. See also bug#20154. + (if (and (< (length string) json--long-string-threshold) + (not (string-match-p (rx json--escape) string))) + (concat "\"" string "\"") + (with-current-buffer + (or json--string-buffer + (with-current-buffer (generate-new-buffer " *json-string*") + ;; This seems to afford decent performance gains. + (setq-local inhibit-modification-hooks t) + (setq json--string-buffer (current-buffer)))) + (insert ?\" string) + (goto-char (1+ (point-min))) + (while (re-search-forward (rx json--escape) nil 'move) + (let ((char (preceding-char))) + (delete-char -1) + (insert ?\\ (or + ;; Special JSON character (\n, \r, etc.). + (car (rassq char json-special-chars)) + ;; Fallback: UCS code point in \uNNNN form. + (format "u%04x" char))))) + (insert ?\") + ;; Empty buffer for next invocation. + (delete-and-extract-region (point-min) (point-max))))) (defun json-encode-key (object) "Return a JSON representation of OBJECT. @@ -459,15 +462,13 @@ this signals `json-key-format'." (signal 'json-key-format (list object))) encoded)) -;;; JSON Objects +;;; Objects (defun json-new-object () - "Create a new Elisp object corresponding to a JSON object. + "Create a new Elisp object corresponding to an empty JSON object. Please see the documentation of `json-object-type'." - (cond ((eq json-object-type 'hash-table) - (make-hash-table :test 'equal)) - (t - ()))) + (and (eq json-object-type 'hash-table) + (make-hash-table :test #'equal))) (defun json-add-to-object (object key value) "Add a new KEY -> VALUE association to OBJECT. @@ -475,10 +476,10 @@ Returns the updated object, which you should save, e.g.: (setq obj (json-add-to-object obj \"foo\" \"bar\")) Please see the documentation of `json-object-type' and `json-key-type'." (let ((json-key-type - (or json-key-type - (cdr (assq json-object-type '((hash-table . string) - (alist . symbol) - (plist . keyword))))))) + (cond (json-key-type) + ((eq json-object-type 'hash-table) 'string) + ((eq json-object-type 'alist) 'symbol) + ((eq json-object-type 'plist) 'keyword)))) (setq key (cond ((eq json-key-type 'string) key) @@ -498,13 +499,13 @@ Please see the documentation of `json-object-type' and `json-key-type'." (defun json-read-object () "Read the JSON object at point." - ;; Skip over the "{" + ;; Skip over the '{'. (json-advance) (json-skip-whitespace) - ;; read key/value pairs until "}" + ;; Read key/value pairs until '}'. (let ((elements (json-new-object)) key value) - (while (not (= (json-peek) ?})) + (while (/= (json-peek) ?\}) (json-skip-whitespace) (setq key (json-read-string)) (json-skip-whitespace) @@ -519,94 +520,94 @@ Please see the documentation of `json-object-type' and `json-key-type'." (funcall json-post-element-read-function)) (setq elements (json-add-to-object elements key value)) (json-skip-whitespace) - (when (/= (json-peek) ?}) + (when (/= (json-peek) ?\}) (if (= (json-peek) ?,) (json-advance) (signal 'json-object-format (list "," (json-peek)))))) - ;; Skip over the "}" + ;; Skip over the '}'. (json-advance) (pcase json-object-type ('alist (nreverse elements)) - ('plist (json--plist-reverse elements)) + ('plist (json--plist-nreverse elements)) (_ elements)))) ;; Hash table encoding (defun json-encode-hash-table (hash-table) "Return a JSON representation of HASH-TABLE." - (if json-encoding-object-sort-predicate - (json-encode-alist (map-into hash-table 'list)) - (format "{%s%s}" - (json-join - (let (r) - (json--with-indentation - (maphash - (lambda (k v) - (push (format - (if json-encoding-pretty-print - "%s%s: %s" - "%s%s:%s") - json--encoding-current-indentation - (json-encode-key k) - (json-encode v)) - r)) - hash-table)) - r) - json-encoding-separator) - (if (or (not json-encoding-pretty-print) - json-encoding-lisp-style-closings) - "" - json--encoding-current-indentation)))) + (cond ((hash-table-empty-p hash-table) "{}") + (json-encoding-object-sort-predicate + (json--encode-alist (map-pairs hash-table) t)) + (t + (let ((kv-sep (if json-encoding-pretty-print ": " ":")) + result) + (json--with-indentation + (maphash + (lambda (k v) + (push (concat json--encoding-current-indentation + (json-encode-key k) + kv-sep + (json-encode v)) + result)) + hash-table)) + (concat "{" + (string-join (nreverse result) json-encoding-separator) + (and json-encoding-pretty-print + (not json-encoding-lisp-style-closings) + json--encoding-current-indentation) + "}"))))) ;; List encoding (including alists and plists) -(defun json-encode-alist (alist) - "Return a JSON representation of ALIST." +(defun json--encode-alist (alist &optional destructive) + "Return a JSON representation of ALIST. +DESTRUCTIVE non-nil means it is safe to modify ALIST by +side-effects." (when json-encoding-object-sort-predicate - (setq alist - (sort alist (lambda (a b) + (setq alist (sort (if destructive alist (copy-sequence alist)) + (lambda (a b) (funcall json-encoding-object-sort-predicate (car a) (car b)))))) - (format "{%s%s}" - (json-join - (json--with-indentation - (mapcar (lambda (cons) - (format (if json-encoding-pretty-print - "%s%s: %s" - "%s%s:%s") - json--encoding-current-indentation - (json-encode-key (car cons)) - (json-encode (cdr cons)))) - alist)) - json-encoding-separator) - (if (or (not json-encoding-pretty-print) - json-encoding-lisp-style-closings) - "" - json--encoding-current-indentation))) + (concat "{" + (let ((kv-sep (if json-encoding-pretty-print ": " ":"))) + (json--with-indentation + (mapconcat (lambda (cons) + (concat json--encoding-current-indentation + (json-encode-key (car cons)) + kv-sep + (json-encode (cdr cons)))) + alist + json-encoding-separator))) + (and json-encoding-pretty-print + (not json-encoding-lisp-style-closings) + json--encoding-current-indentation) + "}")) + +(defun json-encode-alist (alist) + "Return a JSON representation of ALIST." + (if alist (json--encode-alist alist) "{}")) (defun json-encode-plist (plist) "Return a JSON representation of PLIST." - (if json-encoding-object-sort-predicate - (json-encode-alist (json--plist-to-alist plist)) - (let (result) - (json--with-indentation - (while plist - (push (concat - json--encoding-current-indentation - (json-encode-key (car plist)) - (if json-encoding-pretty-print - ": " - ":") - (json-encode (cadr plist))) + (cond ((null plist) "{}") + (json-encoding-object-sort-predicate + (json--encode-alist (map-pairs plist) t)) + (t + (let ((kv-sep (if json-encoding-pretty-print ": " ":")) result) - (setq plist (cddr plist)))) - (concat "{" - (json-join (nreverse result) json-encoding-separator) - (if (and json-encoding-pretty-print - (not json-encoding-lisp-style-closings)) - json--encoding-current-indentation - "") - "}")))) + (json--with-indentation + (while plist + (push (concat json--encoding-current-indentation + (json-encode-key (pop plist)) + kv-sep + (json-encode (pop plist))) + result))) + (concat "{" + (string-join (nreverse result) json-encoding-separator) + (and json-encoding-pretty-print + (not json-encoding-lisp-style-closings) + json--encoding-current-indentation) + "}"))))) (defun json-encode-list (list) "Return a JSON representation of LIST. @@ -624,15 +625,17 @@ become JSON objects." (defun json-read-array () "Read the JSON array at point." - ;; Skip over the "[" + ;; Skip over the '['. (json-advance) (json-skip-whitespace) - ;; read values until "]" - (let (elements) - (while (not (= (json-peek) ?\])) + ;; Read values until ']'. + (let (elements + (len 0)) + (while (/= (json-peek) ?\]) (json-skip-whitespace) (when json-pre-element-read-function - (funcall json-pre-element-read-function (length elements))) + (funcall json-pre-element-read-function len) + (setq len (1+ len))) (push (json-read) elements) (when json-post-element-read-function (funcall json-post-element-read-function)) @@ -640,8 +643,8 @@ become JSON objects." (when (/= (json-peek) ?\]) (if (= (json-peek) ?,) (json-advance) - (signal 'json-error (list 'bleah))))) - ;; Skip over the "]" + (signal 'json-array-format (list "," (json-peek)))))) + ;; Skip over the ']'. (json-advance) (pcase json-array-type ('vector (nreverse (vconcat elements))) @@ -652,42 +655,43 @@ become JSON objects." (defun json-encode-array (array) "Return a JSON representation of ARRAY." (if (and json-encoding-pretty-print - (> (length array) 0)) + (not (seq-empty-p array))) (concat + "[" (json--with-indentation - (concat (format "[%s" json--encoding-current-indentation) - (json-join (mapcar 'json-encode array) - (format "%s%s" - json-encoding-separator + (concat json--encoding-current-indentation + (mapconcat #'json-encode array + (concat json-encoding-separator json--encoding-current-indentation)))) - (format "%s]" - (if json-encoding-lisp-style-closings - "" - json--encoding-current-indentation))) + (unless json-encoding-lisp-style-closings + json--encoding-current-indentation) + "]") (concat "[" - (mapconcat 'json-encode array json-encoding-separator) + (mapconcat #'json-encode array json-encoding-separator) "]"))) -;;; JSON reader. +;;; Reader (defmacro json-readtable-dispatch (char) - "Dispatch reader function for CHAR." - (declare (debug (symbolp))) - (let ((table - '((?t json-read-keyword "true") - (?f json-read-keyword "false") - (?n json-read-keyword "null") - (?{ json-read-object) - (?\[ json-read-array) - (?\" json-read-string))) - res) - (dolist (c '(?- ?+ ?. ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)) - (push (list c 'json-read-number) table)) - (pcase-dolist (`(,c . ,rest) table) - (push `((eq ,char ,c) (,@rest)) res)) - `(cond ,@res (t (signal 'json-readtable-error (list ,char)))))) + "Dispatch reader function for CHAR at point. +If CHAR is nil, signal `json-end-of-file'." + (declare (debug t)) + (macroexp-let2 nil char char + `(cond ,@(map-apply + (lambda (key expr) + `((eq ,char ,key) ,expr)) + `((?\" ,#'json-read-string) + (?\[ ,#'json-read-array) + (?\{ ,#'json-read-object) + (?n ,#'json-read-keyword "null") + (?f ,#'json-read-keyword "false") + (?t ,#'json-read-keyword "true") + ,@(mapcar (lambda (c) (list c #'json-read-number)) + '(?- ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)))) + (,char (signal 'json-readtable-error (list ,char))) + (t (signal 'json-end-of-file ()))))) (defun json-read () "Parse and return the JSON object following point. @@ -705,10 +709,7 @@ you will get the following structure returned: ((c . :json-false))]) (b . \"foo\"))" (json-skip-whitespace) - (let ((char (json-peek))) - (if (zerop char) - (signal 'json-end-of-file nil) - (json-readtable-dispatch char)))) + (json-readtable-dispatch (char-after))) ;; Syntactic sugar for the reader @@ -723,12 +724,11 @@ you will get the following structure returned: "Read the first JSON object contained in FILE and return it." (with-temp-buffer (insert-file-contents file) - (goto-char (point-min)) (json-read))) -;;; JSON encoder +;;; Encoder (defun json-encode (object) "Return a JSON representation of OBJECT as a string. @@ -736,20 +736,21 @@ you will get the following structure returned: OBJECT should have a structure like one returned by `json-read'. If an error is detected during encoding, an error based on `json-error' is signaled." - (cond ((memq object (list t json-null json-false)) - (json-encode-keyword object)) - ((stringp object) (json-encode-string object)) - ((keywordp object) (json-encode-string - (substring (symbol-name object) 1))) - ((listp object) (json-encode-list object)) - ((symbolp object) (json-encode-string - (symbol-name object))) - ((numberp object) (json-encode-number object)) - ((arrayp object) (json-encode-array object)) - ((hash-table-p object) (json-encode-hash-table object)) - (t (signal 'json-error (list object))))) - -;; Pretty printing & minimizing + (cond ((eq object t) (json-encode-keyword object)) + ((eq object json-null) (json-encode-keyword object)) + ((eq object json-false) (json-encode-keyword object)) + ((stringp object) (json-encode-string object)) + ((keywordp object) (json-encode-string + (substring (symbol-name object) 1))) + ((listp object) (json-encode-list object)) + ((symbolp object) (json-encode-string + (symbol-name object))) + ((numberp object) (json-encode-number object)) + ((arrayp object) (json-encode-array object)) + ((hash-table-p object) (json-encode-hash-table object)) + (t (signal 'json-error (list object))))) + +;;; Pretty printing & minimizing (defun json-pretty-print-buffer (&optional minimize) "Pretty-print current buffer. @@ -768,9 +769,9 @@ MAX-SECS.") With prefix argument MINIMIZE, minimize it instead." (interactive "r\nP") (let ((json-encoding-pretty-print (null minimize)) - ;; Distinguish an empty objects from 'null' + ;; Distinguish an empty object from 'null'. (json-null :json-null) - ;; Ensure that ordering is maintained + ;; Ensure that ordering is maintained. (json-object-type 'alist) (orig-buf (current-buffer)) error) @@ -799,9 +800,7 @@ With prefix argument MINIMIZE, minimize it instead." ;; them. (let ((space (buffer-substring (point) - (+ (point) - (skip-chars-forward - " \t\n" (point-max))))) + (+ (point) (skip-chars-forward " \t\n")))) (json (json-read))) (setq pos (point)) ; End of last good json-read. (set-buffer tmp-buf) @@ -831,14 +830,14 @@ With prefix argument MINIMIZE, minimize it instead." "Pretty-print current buffer with object keys ordered. With prefix argument MINIMIZE, minimize it instead." (interactive "P") - (let ((json-encoding-object-sort-predicate 'string<)) + (let ((json-encoding-object-sort-predicate #'string<)) (json-pretty-print-buffer minimize))) (defun json-pretty-print-ordered (begin end &optional minimize) "Pretty-print the region with object keys ordered. With prefix argument MINIMIZE, minimize it instead." (interactive "r\nP") - (let ((json-encoding-object-sort-predicate 'string<)) + (let ((json-encoding-object-sort-predicate #'string<)) (json-pretty-print begin end minimize))) (provide 'json) diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el index 65c0df8f57c..ff8f250a22e 100644 --- a/lisp/jsonrpc.el +++ b/lisp/jsonrpc.el @@ -4,11 +4,11 @@ ;; Author: João Távora <joaotavora@gmail.com> ;; Keywords: processes, languages, extensions +;; Version: 1.0.12 ;; Package-Requires: ((emacs "25.2")) -;; Version: 1.0.9 -;; This is an Elpa :core package. Don't use functionality that is not -;; compatible with Emacs 25.2. +;; This is a GNU ELPA :core package. Avoid functionality that is not +;; compatible with the version of Emacs recorded above. ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by @@ -37,7 +37,6 @@ ;;; Code: (require 'cl-lib) -(require 'json) (require 'eieio) (eval-when-compile (require 'subr-x)) (require 'warnings) @@ -364,21 +363,53 @@ connection object, called when the process dies .") (cl-defmethod initialize-instance ((conn jsonrpc-process-connection) slots) (cl-call-next-method) - (let* ((proc (plist-get slots :process)) - (proc (if (functionp proc) (funcall proc) proc)) - (buffer (get-buffer-create (format "*%s output*" (process-name proc)))) - (stderr (get-buffer-create (format "*%s stderr*" (process-name proc))))) + (cl-destructuring-bind (&key ((:process proc)) name &allow-other-keys) slots + ;; FIXME: notice the undocumented bad coupling in the stderr + ;; buffer name, it must be named exactly like this we expect when + ;; calling `make-process'. If there were a `set-process-stderr' + ;; like there is `set-process-buffer' we wouldn't need this and + ;; could use a pipe with a process filter instead of + ;; `after-change-functions'. Alternatively, we need a new initarg + ;; (but maybe not a slot). + (let ((calling-buffer (current-buffer))) + (with-current-buffer (get-buffer-create (format "*%s stderr*" name)) + (let ((inhibit-read-only t) + (hidden-name (concat " " (buffer-name)))) + (erase-buffer) + (buffer-disable-undo) + (add-hook + 'after-change-functions + (lambda (beg _end _pre-change-len) + (cl-loop initially (goto-char beg) + do (forward-line) + when (bolp) + for line = (buffer-substring + (line-beginning-position 0) + (line-end-position 0)) + do (with-current-buffer (jsonrpc-events-buffer conn) + (goto-char (point-max)) + (let ((inhibit-read-only t)) + (insert (format "[stderr] %s\n" line)))) + until (eobp))) + nil t) + ;; If we are correctly coupled to the client, the process + ;; now created should pick up the current stderr buffer, + ;; which we immediately rename + (setq proc (if (functionp proc) + (with-current-buffer calling-buffer (funcall proc)) + proc)) + (ignore-errors (kill-buffer hidden-name)) + (rename-buffer hidden-name) + (process-put proc 'jsonrpc-stderr (current-buffer)) + (read-only-mode t)))) (setf (jsonrpc--process conn) proc) - (set-process-buffer proc buffer) - (process-put proc 'jsonrpc-stderr stderr) + (set-process-buffer proc (get-buffer-create (format " *%s output*" name))) (set-process-filter proc #'jsonrpc--process-filter) (set-process-sentinel proc #'jsonrpc--process-sentinel) (with-current-buffer (process-buffer proc) (buffer-disable-undo) (set-marker (process-mark proc) (point-min)) - (let ((inhibit-read-only t)) (erase-buffer) (read-only-mode t) proc)) - (with-current-buffer stderr - (buffer-disable-undo)) + (let ((inhibit-read-only t)) (erase-buffer) (read-only-mode t))) (process-put proc 'jsonrpc-connection conn))) (cl-defmethod jsonrpc-connection-send ((connection jsonrpc-process-connection) @@ -442,26 +473,35 @@ With optional CLEANUP, kill any associated buffers." ;;; (define-error 'jsonrpc-error "jsonrpc-error") -(defun jsonrpc--json-read () - "Read JSON object in buffer, move point to end of buffer." - ;; TODO: I guess we can make these macros if/when jsonrpc.el - ;; goes into Emacs core. - (cond ((fboundp 'json-parse-buffer) (json-parse-buffer - :object-type 'plist - :null-object nil - :false-object :json-false)) - (t (let ((json-object-type 'plist)) - (json-read))))) - -(defun jsonrpc--json-encode (object) - "Encode OBJECT into a JSON string." - (cond ((fboundp 'json-serialize) (json-serialize - object - :false-object :json-false - :null-object nil)) - (t (let ((json-false :json-false) - (json-null nil)) - (json-encode object))))) +(defalias 'jsonrpc--json-read + (if (fboundp 'json-parse-buffer) + (lambda () + (json-parse-buffer :object-type 'plist + :null-object nil + :false-object :json-false)) + (require 'json) + (defvar json-object-type) + (declare-function json-read "json" ()) + (lambda () + (let ((json-object-type 'plist)) + (json-read)))) + "Read JSON object in buffer, move point to end of buffer.") + +(defalias 'jsonrpc--json-encode + (if (fboundp 'json-serialize) + (lambda (object) + (json-serialize object + :false-object :json-false + :null-object nil)) + (require 'json) + (defvar json-false) + (defvar json-null) + (declare-function json-encode "json" (object)) + (lambda (object) + (let ((json-false :json-false) + (json-null nil)) + (json-encode object)))) + "Encode OBJECT into a JSON string.") (cl-defun jsonrpc--reply (connection id &key (result nil result-supplied-p) (error nil error-supplied-p)) @@ -682,7 +722,7 @@ originated." (format "-%s" subtype))))) (goto-char (point-max)) (prog1 - (let ((msg (format "%s%s%s %s:\n%s\n" + (let ((msg (format "[%s]%s%s %s:\n%s" type (if id (format " (id:%s)" id) "") (if error " ERROR" "") diff --git a/lisp/kermit.el b/lisp/kermit.el index b0a4d90932e..f2607bfcf4c 100644 --- a/lisp/kermit.el +++ b/lisp/kermit.el @@ -1,4 +1,4 @@ -;;; kermit.el --- additions to shell mode for use with kermit +;;; kermit.el --- additions to shell mode for use with kermit -*- lexical-binding: t -*- ;; Copyright (C) 1988, 2001-2020 Free Software Foundation, Inc. diff --git a/lisp/language/burmese.el b/lisp/language/burmese.el index 7f2a99a41a2..1888c8f86a2 100644 --- a/lisp/language/burmese.el +++ b/lisp/language/burmese.el @@ -23,7 +23,6 @@ ;;; Commentary: -;; Aung San Suu Kyi says to call her country "Burma". ;; The murderous generals say to call it "Myanmar". ;; We will call it "Burma". -- rms, Chief GNUisance. diff --git a/lisp/language/chinese.el b/lisp/language/chinese.el index bc6969c1398..4389db961d8 100644 --- a/lisp/language/chinese.el +++ b/lisp/language/chinese.el @@ -103,6 +103,11 @@ (define-coding-system-alias 'hz-gb-2312 'chinese-hz) (define-coding-system-alias 'hz 'chinese-hz) +;; FIXME: 'define-coding-system' automatically sets :ascii-compatible-p, +;; to any encoding whose :coding-type is 'utf-8', but UTF-7 is not ASCII +;; compatible, so we override that here (bug#40407). +(coding-system-put 'chinese-hz :ascii-compatible-p nil) + (set-language-info-alist "Chinese-GB" '((charset chinese-gb2312 chinese-sisheng) (iso639-language . zh) diff --git a/lisp/language/cyril-util.el b/lisp/language/cyril-util.el index a3a6f3fdd94..ce60d1a3ad4 100644 --- a/lisp/language/cyril-util.el +++ b/lisp/language/cyril-util.el @@ -47,7 +47,7 @@ ;;;###autoload (defun standard-display-cyrillic-translit (&optional cyrillic-language) - "Display a cyrillic buffer using a transliteration. + "Display a Cyrillic buffer using a transliteration. For readability, the table is slightly different from the one used for the input method `cyrillic-translit'. diff --git a/lisp/language/hanja-util.el b/lisp/language/hanja-util.el index 19cba91556b..f38dead5a23 100644 --- a/lisp/language/hanja-util.el +++ b/lisp/language/hanja-util.el @@ -22,7 +22,7 @@ ;;; Commentary: -;; This file defines korean hanja table and symbol table. +;; This file defines the Korean Hanja table and symbol table. ;;; Code: @@ -31,7 +31,7 @@ (defvar hanja-table nil "A char table for Hanja characters. -It maps a hangul character to a list of the corresponding Hanja characters. +It maps a Hangul character to a list of the corresponding Hanja characters. Each element of the list has the form CHAR or (CHAR . STRING) where CHAR is a Hanja character and STRING is the meaning of that character. This variable is initialized by `hanja-init-load'.") diff --git a/lisp/language/hebrew.el b/lisp/language/hebrew.el index 573541aec16..08b70abfc29 100644 --- a/lisp/language/hebrew.el +++ b/lisp/language/hebrew.el @@ -240,7 +240,7 @@ Bidirectional editing is supported."))) (let* ((base "[\u05D0-\u05F2\uFB1D\uFB1F-\uFB28\uFB2A-\uFB4F]") (combining - "[\u0591-\u05BD\u05BF\u05C1-\u05C2\u05C4-\u05C5\u05C7\uFB1E]+") + "[\u034F\u0591-\u05BD\u05BF\u05C1-\u05C2\u05C4-\u05C5\u05C7\uFB1E]+") (pattern1 (concat base combining)) (pattern2 (concat base "\u200D" combining))) (set-char-table-range diff --git a/lisp/language/ind-util.el b/lisp/language/ind-util.el index 4319e5537e7..62885227f10 100644 --- a/lisp/language/ind-util.el +++ b/lisp/language/ind-util.el @@ -232,8 +232,8 @@ '( (;; VOWELS (?à´… nil) (?à´† ?à´¾) (?à´‡ ?à´¿) (?à´ˆ ?ീ) (?à´‰ ?àµ) (?à´Š ?ൂ) - (?à´‹ ?ൃ) (?à´Œ nil) nil (?à´ ?േ) (?à´Ž ?െ) (?à´ ?ൈ) - nil (?à´“ ?ോ) (?à´’ ?ൊ) (?à´” ?ൌ) nil nil) + (?à´‹ ?ൃ) (?à´Œ ?ൢ) (?ൡ ?ൣ) (?à´ ?േ) (?à´Ž ?െ) (?à´ ?ൈ) + nil (?à´’ ?ൊ) (?à´“ ?ോ) (?à´” ?ൗ) (?ൠ?àµ) (?ൠ?ൄ)) (;; CONSONANTS ?à´• ?à´– ?à´— ?à´˜ ?à´™ ;; GUTTRULS ?à´š ?à´› ?à´œ ?à´ ?à´ž ;; PALATALS @@ -243,13 +243,16 @@ ?à´¯ ?à´° ?à´± ?à´² ?à´³ ?à´´ ?à´µ ;; SEMIVOWELS ?à´¶ ?à´· ?à´¸ ?à´¹ ;; SIBILANTS nil nil nil nil nil nil nil nil ;; NUKTAS - "à´œàµà´ž" "à´•àµà´·") + "à´œàµà´ž" "à´•àµà´·" + "à´±àµà´±" "à´¨àµà´±" "à´¤àµà´¤" "à´¤àµà´¥" "à´žàµà´ž" "à´™àµà´™" "à´¨àµà´¨" + "à´žàµà´š" "à´¨àµà´•" "à´™àµà´•" "à´šàµà´š" "à´šàµà´›" "à´•àµà´•" + "à´¬àµà´¬" "à´•àµà´•" "à´—àµà´—" "à´œàµà´œ" "à´®àµà´®" "à´ªàµà´ª" "à´µàµà´µ" "à´•àµà´¸" "à´¶àµà´¶") (;; Misc Symbols nil ?à´‚ ?à´ƒ nil ?ൠnil nil) (;; Digits ?൦ ?൧ ?൨ ?൩ ?൪ ?൫ ?൬ ?ൠ?൮ ?൯) - (;; Inscript-extra (4) (#, $, ^, *, ]) - "àµà´°" "à´°àµ" "à´¤àµà´°" "à´¶àµà´°" nil))) + (;; Chillus + "à´£àµ" ?ൺ "à´¨àµ" ?ൻ "à´°àµ" ?ർ "à´²àµ" ?ൽ "à´³àµ" ?ൾ))) (defvar indian-tml-base-table '( @@ -323,6 +326,29 @@ (;; misc -- 7 ".N" (".n" "M") "H" ".a" ".h" ("AUM" "OM") ".."))) +(defvar indian-mlm-mozhi-table + '(;; for encode/decode + (;; vowels -- 18 + "a" ("aa" "A") "i" ("ii" "I") "u" ("uu" "U") + "R" "Ll" "Lll" ("E" "ae") "e" "ai" + nil "o" "O" "au" "~" "RR") + (;; consonants -- 40 + ("k" "c") "kh" "g" "gh" "ng" + "ch" ("Ch" "chh") "j" "jh" "nj" + "T" "Th" "D" "Dh" "N" + "th" "thh" "d" "dh" "n" nil + "p" ("ph" "f") "b" "bh" "m" + "y" "r" "rr" "l" "L" "zh" ("v" "w") + ("S" "z") "sh" "s" "h" + nil nil nil nil nil nil nil nil + nil "X" + ;; some of these are extra to Mozhi + ("t" "tt") "nt" "tth" "tthh" "nnj" "nng" "nn" + "nch" "nc" "nk" "cch" "cchh" "cc" + "B" ("C" "K" "q") "G" "J" "M" "P" "V" "x" "Z") + (;; misc -- 7 + nil nil "H"))) + (defvar indian-kyoto-harvard-table '(;; for encode/decode (;; vowel @@ -524,6 +550,10 @@ (indian-make-hash indian-mlm-base-table indian-itrans-v5-table)) +(defvar indian-mlm-mozhi-hash + (indian-make-hash indian-mlm-base-table + indian-mlm-mozhi-table)) + (defvar indian-tml-itrans-v5-hash (indian-make-hash indian-tml-base-table indian-itrans-v5-table-for-tamil)) diff --git a/lisp/language/indian.el b/lisp/language/indian.el index eb882c810e1..657ad6915eb 100644 --- a/lisp/language/indian.el +++ b/lisp/language/indian.el @@ -25,7 +25,7 @@ ;;; Commentary: ;; This file contains definitions of Indian language environments, and -;; setups for displaying the scrtipts used there. +;; setups for displaying the scripts used there. ;;; Code: diff --git a/lisp/language/japanese.el b/lisp/language/japanese.el index d77efa48c9b..9a99245dfde 100644 --- a/lisp/language/japanese.el +++ b/lisp/language/japanese.el @@ -82,9 +82,7 @@ (#x00A6 . #xFFE4) ; BROKEN LINE FULLWIDTH BROKEN LINE ))) (define-translation-table 'japanese-ucs-jis-to-cp932-map map) - (mapc #'(lambda (x) (let ((tmp (car x))) - (setcar x (cdr x)) (setcdr x tmp))) - map) + (setq map (mapcar (lambda (x) (cons (cdr x) (car x))) map)) (define-translation-table 'japanese-ucs-cp932-to-jis-map map)) ;; U+2014 (EM DASH) vs U+2015 (HORIZONTAL BAR) @@ -241,8 +239,10 @@ eucJP-ms is defined in <http://www.opengroup.or.jp/jvc/cde/appendix.html>." (#x2b65 . [#x02E9 #x02E5]) (#x2b66 . [#x02E5 #x02E9]))) table) - (dolist (elt map) - (setcar elt (decode-char 'japanese-jisx0213-1 (car elt)))) + (setq map + (mapcar (lambda (x) (cons (decode-char 'japanese-jisx0213-1 (car x)) + (cdr x))) + map)) (setq table (make-translation-table-from-alist map)) (define-translation-table 'jisx0213-to-unicode table) (define-translation-table 'unicode-to-jisx0213 diff --git a/lisp/language/korean.el b/lisp/language/korean.el index 210d0fabaf7..7e758159a48 100644 --- a/lisp/language/korean.el +++ b/lisp/language/korean.el @@ -84,6 +84,18 @@ and the following key bindings are available within Korean input methods: F9, Hangul_Hanja: hangul-to-hanja-conversion") )) +;; For auto-composing conjoining jamo. +(let* ((choseong "[\u1100-\u115F\uA960-\uA97C]") + (jungseong "[\u1160-\u11A7\uD7B0-\uD7C6]") + (jongseong "[\u11A8-\u11FF\uD7CB-\uD7FB]?") + (pattern (concat choseong jungseong jongseong))) + (set-char-table-range composition-function-table + '(#x1100 . #x115F) + (list (vector pattern 0 'font-shape-gstring))) + (set-char-table-range composition-function-table + '(#xA960 . #xA97C) + (list (vector pattern 0 'font-shape-gstring)))) + (provide 'korean) ;;; korean.el ends here diff --git a/lisp/language/lao-util.el b/lisp/language/lao-util.el index a20aecee421..fa4c2f7f891 100644 --- a/lisp/language/lao-util.el +++ b/lisp/language/lao-util.el @@ -183,7 +183,9 @@ ;; Semi-vowel-sign-lo and lower vowels are put under the letter. (defconst lao-transcription-consonant-alist - (sort '(;; single consonants + (sort + (copy-sequence + '(;; single consonants ("k" . "àº") ("kh" . "ຂ") ("qh" . "ຄ") @@ -223,14 +225,16 @@ ("hy" . ["ຫàº"]) ("hn" . ["ຫນ"]) ("hm" . ["ຫມ"]) - ) - (function (lambda (x y) (> (length (car x)) (length (car y))))))) + )) + (lambda (x y) (> (length (car x)) (length (car y)))))) (defconst lao-transcription-semi-vowel-alist '(("r" . "ຼ"))) (defconst lao-transcription-vowel-alist - (sort '(("a" . "ະ") + (sort + (copy-sequence + '(("a" . "ະ") ("ar" . "າ") ("i" . "ິ") ("ii" . "ີ") @@ -257,8 +261,8 @@ ("ai" . "ໄ") ("ei" . "ໃ") ("ao" . ["ເົາ"]) - ("aM" . "ຳ")) - (function (lambda (x y) (> (length (car x)) (length (car y))))))) + ("aM" . "ຳ"))) + (lambda (x y) (> (length (car x)) (length (car y)))))) ;; Maa-sakod is put at the tail. (defconst lao-transcription-maa-sakod-alist diff --git a/lisp/language/misc-lang.el b/lisp/language/misc-lang.el index e25e63b4c5c..e3a24c41536 100644 --- a/lisp/language/misc-lang.el +++ b/lisp/language/misc-lang.el @@ -136,10 +136,10 @@ thin (i.e. 1-dot width) space." (set-char-table-range composition-function-table '(#x600 . #x74F) - (list (vector "[\u0600-\u074F\u200C\u200D]+" 0 - 'arabic-shape-gstring) - (vector "[\u200C\u200D][\u0600-\u074F\u200C\u200D]+" 1 - 'arabic-shape-gstring))) + (list (vector "[\u200C\u200D][\u0600-\u074F\u200C\u200D]+" + 1 'arabic-shape-gstring) + (vector "[\u0600-\u074F\u200C\u200D]+" + 0 'arabic-shape-gstring))) (provide 'misc-lang) diff --git a/lisp/language/tibet-util.el b/lisp/language/tibet-util.el index 29fff9175b7..8684cdb1338 100644 --- a/lisp/language/tibet-util.el +++ b/lisp/language/tibet-util.el @@ -43,13 +43,17 @@ ("་" . "་") ("༔" . "༔") ;; Yes these are dirty. But ... - ("༎ ༎" . ,(compose-string "༎ ༎" 0 3 [?༎ (Br . Bl) ? (Br . Bl) ?༎])) + ("༎ ༎" . ,(compose-string (copy-sequence "༎ ༎") + 0 3 [?༎ (Br . Bl) ? (Br . Bl) ?༎])) ("༄༅༅" . ,(compose-string - "à¿à¿‚à¿‚à¿‚" 0 4 + (copy-sequence "à¿à¿‚à¿‚à¿‚") 0 4 [?à¿ (Br . Bl) ?à¿‚ (Br . Bl) ?à¿‚ (Br . Bl) ?à¿‚])) - ("༄༅" . ,(compose-string "à¿à¿‚à¿‚" 0 3 [?à¿ (Br . Bl) ?à¿‚ (Br . Bl) ?à¿‚])) - ("༆" . ,(compose-string "à¿à¿‚༙" 0 3 [?à¿ (Br . Bl) ?à¿‚ (br . tr) ?༙])) - ("༄" . ,(compose-string "à¿à¿‚" 0 2 [?à¿ (Br . Bl) ?à¿‚])))) + ("༄༅" . ,(compose-string (copy-sequence "à¿à¿‚à¿‚") + 0 3 [?à¿ (Br . Bl) ?à¿‚ (Br . Bl) ?à¿‚])) + ("༆" . ,(compose-string (copy-sequence "à¿à¿‚༙") + 0 3 [?à¿ (Br . Bl) ?à¿‚ (br . tr) ?༙])) + ("༄" . ,(compose-string (copy-sequence "à¿à¿‚") + 0 2 [?à¿ (Br . Bl) ?à¿‚])))) ;;;###autoload (defun tibetan-char-p (ch) diff --git a/lisp/language/tibetan.el b/lisp/language/tibetan.el index d31cd5cd528..bbd4729f6c5 100644 --- a/lisp/language/tibetan.el +++ b/lisp/language/tibetan.el @@ -326,7 +326,9 @@ (defconst tibetan-subjoined-transcription-alist - (sort '(("+k" . "à¾") + (sort + (copy-sequence + '(("+k" . "à¾") ("+kh" . "ྑ") ("+g" . "ྒ") ("+gh" . "ྒྷ") @@ -371,8 +373,8 @@ ("+W" . "ྺ") ;; fixed form subscribed WA ("+Y" . "ྻ") ;; fixed form subscribed YA ("+R" . "ྼ") ;; fixed form subscribed RA - ) - (lambda (x y) (> (length (car x)) (length (car y)))))) + )) + (lambda (x y) (> (length (car x)) (length (car y)))))) ;;; ;;; alist for Tibetan base consonant <-> subjoined consonant conversion. diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el index c755bdfde3f..7077925602c 100644 --- a/lisp/ldefs-boot.el +++ b/lisp/ldefs-boot.el @@ -1076,7 +1076,7 @@ search for matches for any two (or more) of those words. With \\[universal-argument] prefix, or if `apropos-do-all' is non-nil, consider all symbols (if they match PATTERN). -Returns list of symbols and documentation found. +Return list of symbols and documentation found. \(fn PATTERN &optional DO-ALL)" t nil) @@ -2452,16 +2452,34 @@ Function to display the current buffer in a WWW browser. This is used by the `browse-url-at-point', `browse-url-at-mouse', and `browse-url-of-file' commands. -If the value is not a function it should be a list of pairs -\(REGEXP . FUNCTION). In this case the function called will be the one -associated with the first REGEXP which matches the current URL. The -function is passed the URL and any other args of `browse-url'. The last -regexp should probably be \".\" to specify a default browser. - -Also see `browse-url-secondary-browser-function'.") +Also see `browse-url-secondary-browser-function' and +`browse-url-handlers'.") (custom-autoload 'browse-url-browser-function "browse-url" t) +(defvar browse-url-default-handlers '(("\\`mailto:" . browse-url--mailto) ("\\`man:" . browse-url--man) (browse-url--non-html-file-url-p . browse-url-emacs)) "\ +Like `browse-url-handlers' but populated by Emacs and packages. + +Emacs and external packages capable of browsing certain URLs +should place their entries in this alist rather than +`browse-url-handlers' which is reserved for the user.") + +(autoload 'browse-url-select-handler "browse-url" "\ +Return a handler of suitable for browsing URL. +This searches `browse-url-handlers', and +`browse-url-default-handlers' for a matching handler. Return nil +if no handler is found. + +If KIND is given, the search is restricted to handlers whose +function symbol has the symbol-property `browse-url-browser-kind' +set to KIND. + +Currently, it also consults `browse-url-browser-function' first +if it is set to an alist, although this usage is deprecated since +Emacs 28.1 and will be removed in a future release. + +\(fn URL &optional KIND)" nil nil) + (autoload 'browse-url-of-file "browse-url" "\ Ask a WWW browser to display FILE. Display the current buffer's file if FILE is nil or if called @@ -2491,16 +2509,18 @@ Ask a WWW browser to display the current region. Ask a WWW browser to load URL. Prompt for a URL, defaulting to the URL at or before point. Invokes a suitable browser function which does the actual job. -The variable `browse-url-browser-function' says which browser function to -use. If the URL is a mailto: URL, consult `browse-url-mailto-function' -first, if that exists. -The additional ARGS are passed to the browser function. See the doc -strings of the actual functions, starting with `browse-url-browser-function', -for information about the significance of ARGS (most of the functions -ignore it). -If ARGS are omitted, the default is to pass `browse-url-new-window-flag' -as ARGS. +The variables `browse-url-browser-function', +`browse-url-handlers', and `browse-url-default-handlers' +determine which browser function to use. + +The additional ARGS are passed to the browser function. See the +doc strings of the actual functions, starting with +`browse-url-browser-function', for information about the +significance of ARGS (most of the functions ignore it). + +If ARGS are omitted, the default is to pass +`browse-url-new-window-flag' as ARGS. \(fn URL &rest ARGS)" t nil) @@ -2512,6 +2532,15 @@ Optional prefix argument ARG non-nil inverts the value of the option \(fn &optional ARG)" t nil) +(autoload 'browse-url-with-browser-kind "browse-url" "\ +Browse URL with a browser of the given browser KIND. +KIND is either `internal' or `external'. + +When called interactively, the default browser kind is the +opposite of the browser kind of `browse-url-browser-function'. + +\(fn KIND URL &optional ARG)" t nil) + (autoload 'browse-url-at-mouse "browse-url" "\ Ask a WWW browser to load a URL clicked with the mouse. The URL is the one around or before the position of the mouse click @@ -2699,6 +2728,8 @@ NEW-WINDOW instead of `browse-url-new-window-flag'. \(fn URL &optional NEW-WINDOW)" t nil) +(make-obsolete 'browse-url-conkeror 'nil '"28.1") + (autoload 'browse-url-w3 "browse-url" "\ Ask the w3 WWW browser to load URL. Default to the URL around or before point. @@ -3674,7 +3705,7 @@ Return the syntactic context of the current line." nil nil) ;;;### (autoloads nil "cc-fonts" "progmodes/cc-fonts.el" (0 0 0 0)) ;;; Generated autoloads from progmodes/cc-fonts.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cc-fonts" '("autodoc-" "c++-font-lock-keywords" "c-" "gtkdoc-font-lock-" "idl-font-lock-keywords" "java" "objc-font-lock-keywords" "pike-font-lock-keywords"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cc-fonts" '("autodoc-" "c++-font-lock-keywords" "c-" "doxygen-font-lock-" "gtkdoc-font-lock-" "idl-font-lock-keywords" "java" "objc-font-lock-keywords" "pike-font-lock-keywords"))) ;;;*** @@ -3843,7 +3874,7 @@ should be used. This function attempts to use file contents to determine whether the code is C or C++ and based on that chooses whether to enable -`c-mode' or `c++-mode'." nil nil) +`c-mode' or `c++-mode'." t nil) (autoload 'c++-mode "cc-mode" "\ Major mode for editing C++ code. @@ -4480,7 +4511,6 @@ Returns non-nil if any false statements are found. ;;;### (autoloads nil "checkdoc" "emacs-lisp/checkdoc.el" (0 0 0 ;;;;;; 0)) ;;; Generated autoloads from emacs-lisp/checkdoc.el -(push (purecopy '(checkdoc 0 6 2)) package--builtin-versions) (put 'checkdoc-force-docstrings-flag 'safe-local-variable #'booleanp) (put 'checkdoc-force-history-flag 'safe-local-variable #'booleanp) (put 'checkdoc-permit-comma-termination-flag 'safe-local-variable #'booleanp) @@ -4746,6 +4776,34 @@ and runs the normal hook `command-history-hook'." t nil) ;;;*** +;;;### (autoloads nil "cl-font-lock" "progmodes/cl-font-lock.el" +;;;;;; (0 0 0 0)) +;;; Generated autoloads from progmodes/cl-font-lock.el + +(defvar cl-font-lock-built-in-mode nil "\ +Non-nil if Cl-Font-Lock-Built-In mode is enabled. +See the `cl-font-lock-built-in-mode' command +for a description of this minor mode. +Setting this variable directly does not take effect; +either customize it (see the info node `Easy Customization') +or call the function `cl-font-lock-built-in-mode'.") + +(custom-autoload 'cl-font-lock-built-in-mode "cl-font-lock" nil) + +(autoload 'cl-font-lock-built-in-mode "cl-font-lock" "\ +Highlight built-in functions, variables, and types in `lisp-mode'. + +If called interactively, enable Cl-Font-Lock-Built-In mode if ARG is +positive, and disable it if ARG is zero or negative. If called from +Lisp, also enable the mode if ARG is omitted or nil, and toggle it if +ARG is `toggle'; disable the mode otherwise. + +\(fn &optional ARG)" t nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cl-font-lock" '("cl-font-lock-"))) + +;;;*** + ;;;### (autoloads nil "cl-generic" "emacs-lisp/cl-generic.el" (0 ;;;;;; 0 0 0)) ;;; Generated autoloads from emacs-lisp/cl-generic.el @@ -5492,7 +5550,9 @@ doesn't have enough contents to decide, this is identical to See also `conf-space-mode', `conf-colon-mode', `conf-javaprop-mode', `conf-ppd-mode' and `conf-xdefaults-mode'. -\\{conf-mode-map}" t nil) +\\{conf-mode-map} + +\(fn)" t nil) (autoload 'conf-unix-mode "conf-mode" "\ Conf Mode starter for Unix style Conf files. @@ -6469,7 +6529,6 @@ Mode used for cvs status output. ;;;### (autoloads nil "cwarn" "progmodes/cwarn.el" (0 0 0 0)) ;;; Generated autoloads from progmodes/cwarn.el -(push (purecopy '(cwarn 1 3 1)) package--builtin-versions) (autoload 'cwarn-mode "cwarn" "\ Minor mode that highlights suspicious C and C++ constructions. @@ -6607,7 +6666,7 @@ Create a new data-debug buffer with NAME. \(fn NAME)" nil nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "data-debug" '("data-debug-" "dd-propertize"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "data-debug" '("data-debug-"))) ;;;*** @@ -7067,8 +7126,10 @@ Otherwise return a description formatted by of `eldoc-echo-area-use-multiline-p' variable and width of minibuffer window for width limit. -This function is meant to be used as a value of -`eldoc-documentation-function' variable." nil nil) +This function can be used as a value of +`eldoc-documentation-functions' variable. + +\(fn CALLBACK &rest _)" nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "descr-text" '("describe-"))) @@ -7635,7 +7696,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} @@ -8975,7 +9035,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-"))) ;;;*** @@ -9889,6 +9949,12 @@ It creates an autoload function for CNAME's constructor. ;;;*** +;;;### (autoloads nil "eldoc" "emacs-lisp/eldoc.el" (0 0 0 0)) +;;; Generated autoloads from emacs-lisp/eldoc.el +(push (purecopy '(eldoc 1 8 0)) package--builtin-versions) + +;;;*** + ;;;### (autoloads nil "elec-pair" "elec-pair.el" (0 0 0 0)) ;;; Generated autoloads from elec-pair.el @@ -10192,6 +10258,10 @@ some major modes from being locked under some circumstances. Report a bug in GNU Emacs. Prompts for bug subject. Leaves you in a mail buffer. +Already submitted bugs can be found in the Emacs bug tracker: + + https://debbugs.gnu.org/cgi/pkgreport.cgi?package=emacs;max-bugs=100;base-order=1;bug-rev=1 + \(fn TOPIC &optional UNUSED)" t nil) (set-advertised-calling-convention 'report-emacs-bug '(topic) '"24.5") @@ -11798,6 +11868,14 @@ Edit the hotlist of directory servers in a specialized buffer." t nil) ;;;*** +;;;### (autoloads nil "eudcb-macos-contacts" "net/eudcb-macos-contacts.el" +;;;;;; (0 0 0 0)) +;;; Generated autoloads from net/eudcb-macos-contacts.el + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eudcb-macos-contacts" '("eudc-macos-contacts-"))) + +;;;*** + ;;;### (autoloads nil "ewoc" "emacs-lisp/ewoc.el" (0 0 0 0)) ;;; Generated autoloads from emacs-lisp/ewoc.el @@ -11845,7 +11923,11 @@ word(s) will be searched for via `eww-search-prefix'. If called with a prefix ARG, use a new buffer instead of reusing the default EWW buffer. -\(fn URL &optional ARG)" t nil) +If BUFFER, the data to be rendered is in that buffer. In that +case, this function doesn't actually fetch URL. BUFFER will be +killed after rendering. + +\(fn URL &optional ARG BUFFER)" t nil) (defalias 'browse-web 'eww) (autoload 'eww-open-file "eww" "\ @@ -11885,7 +11967,7 @@ instead of `browse-url-new-window-flag'. (autoload 'eww-list-bookmarks "eww" "\ Display the bookmarks." t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eww" '("eww-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eww" '("erc--download-directory" "eww-"))) ;;;*** @@ -12455,16 +12537,16 @@ operating on the next file and nil otherwise. (autoload 'fileloop-initialize-replace "fileloop" "\ Initialize a new round of query&replace on several files. - FROM is a regexp and TO is the replacement to use. - FILES describes the files, as in `fileloop-initialize'. - CASE-FOLD can be t, nil, or `default': - if it is nil, matching of FROM is case-sensitive. - if it is t, matching of FROM is case-insensitive, except - when `search-upper-case' is non-nil and FROM includes - upper-case letters. - if it is `default', the function uses the value of - `case-fold-search' instead. - DELIMITED if non-nil means replace only word-delimited matches. +FROM is a regexp and TO is the replacement to use. +FILES describes the files, as in `fileloop-initialize'. +CASE-FOLD can be t, nil, or `default': + if it is nil, matching of FROM is case-sensitive. + if it is t, matching of FROM is case-insensitive, except + when `search-upper-case' is non-nil and FROM includes + upper-case letters. + if it is `default', the function uses the value of + `case-fold-search' instead. +DELIMITED if non-nil means replace only word-delimited matches. \(fn FROM TO FILES CASE-FOLD &optional DELIMITED)" nil nil) @@ -12770,6 +12852,13 @@ Interactively, prompt for LIBRARY using the one at or near point. \(fn LIBRARY)" t nil) +(autoload 'read-library-name "find-func" "\ +Read and return a library name, defaulting to the one near point. + +A library name is the filename of an Emacs Lisp library located +in a directory under `load-path' (or `find-function-source-path', +if non-nil)." nil nil) + (autoload 'find-library-other-window "find-func" "\ Find the Emacs Lisp source of LIBRARY in another window. @@ -12937,7 +13026,7 @@ Find directly the variable at point in the other window." t nil) (autoload 'find-function-setup-keys "find-func" "\ Define some key bindings for the find-function family of functions." nil nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "find-func" '("find-" "read-library-name"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "find-func" '("find-"))) ;;;*** @@ -13029,7 +13118,7 @@ lines. ;;;### (autoloads nil "flymake" "progmodes/flymake.el" (0 0 0 0)) ;;; Generated autoloads from progmodes/flymake.el -(push (purecopy '(flymake 1 0 8)) package--builtin-versions) +(push (purecopy '(flymake 1 0 9)) package--builtin-versions) (autoload 'flymake-log "flymake" "\ Log, at level LEVEL, the message MSG formatted with ARGS. @@ -13376,7 +13465,54 @@ play around with the following keys: ;;;### (autoloads nil "format-spec" "format-spec.el" (0 0 0 0)) ;;; Generated autoloads from format-spec.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "format-spec" '("format-spec"))) +(autoload 'format-spec "format-spec" "\ +Return a string based on FORMAT and SPECIFICATION. +FORMAT is a string containing `format'-like specs like \"su - %u %k\". +SPECIFICATION is an alist mapping format specification characters +to their substitutions. + +For instance: + + (format-spec \"su - %u %l\" + \\=`((?u . ,(user-login-name)) + (?l . \"ls\"))) + +Each %-spec may contain optional flag, width, and precision +modifiers, as follows: + + %<flags><width><precision>character + +The following flags are allowed: + +* 0: Pad to the width, if given, with zeros instead of spaces. +* -: Pad to the width, if given, on the right instead of the left. +* <: Truncate to the width and precision, if given, on the left. +* >: Truncate to the width and precision, if given, on the right. +* ^: Convert to upper case. +* _: Convert to lower case. + +The width and truncation modifiers behave like the corresponding +ones in `format' when applied to %s. + +For example, \"%<010b\" means \"substitute into the output the +value associated with ?b in SPECIFICATION, either padding it with +leading zeros or truncating leading characters until it's ten +characters wide\". + +Any text properties of FORMAT are copied to the result, with any +text properties of a %-spec itself copied to its substitution. + +IGNORE-MISSING indicates how to handle %-spec characters not +present in SPECIFICATION. If it is nil or omitted, emit an +error; if it is the symbol `ignore', leave those %-specs verbatim +in the result, including their text properties, if any; if it is +the symbol `delete', remove those %-specs from the result; +otherwise do the same as for the symbol `ignore', but also leave +any occurrences of \"%%\" in FORMAT verbatim in the result. + +\(fn FORMAT SPECIFICATION &optional IGNORE-MISSING)" nil nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "format-spec" '("format-spec-"))) ;;;*** @@ -13561,7 +13697,7 @@ and choose the directory as the fortune-file. Minimum set of parameters to filter for live (on-session) framesets. DO NOT MODIFY. See `frameset-filter-alist' for a full description.") -(defvar frameset-persistent-filter-alist (nconc '((background-color . frameset-filter-sanitize-color) (buffer-list . :never) (buffer-predicate . :never) (buried-buffer-list . :never) (client . :never) (delete-before . :never) (font . frameset-filter-font-param) (font-backend . :never) (foreground-color . frameset-filter-sanitize-color) (frameset--text-pixel-height . :save) (frameset--text-pixel-width . :save) (fullscreen . frameset-filter-shelve-param) (GUI:font . frameset-filter-unshelve-param) (GUI:fullscreen . frameset-filter-unshelve-param) (GUI:height . frameset-filter-unshelve-param) (GUI:width . frameset-filter-unshelve-param) (height . frameset-filter-shelve-param) (outer-window-id . :never) (parent-frame . :never) (parent-id . :never) (mouse-wheel-frame . :never) (tty . frameset-filter-tty-to-GUI) (tty-type . frameset-filter-tty-to-GUI) (width . frameset-filter-shelve-param) (window-id . :never) (window-system . :never)) frameset-session-filter-alist) "\ +(defvar frameset-persistent-filter-alist (append '((background-color . frameset-filter-sanitize-color) (buffer-list . :never) (buffer-predicate . :never) (buried-buffer-list . :never) (client . :never) (delete-before . :never) (font . frameset-filter-font-param) (font-backend . :never) (foreground-color . frameset-filter-sanitize-color) (frameset--text-pixel-height . :save) (frameset--text-pixel-width . :save) (fullscreen . frameset-filter-shelve-param) (GUI:font . frameset-filter-unshelve-param) (GUI:fullscreen . frameset-filter-unshelve-param) (GUI:height . frameset-filter-unshelve-param) (GUI:width . frameset-filter-unshelve-param) (height . frameset-filter-shelve-param) (outer-window-id . :never) (parent-frame . :never) (parent-id . :never) (mouse-wheel-frame . :never) (tty . frameset-filter-tty-to-GUI) (tty-type . frameset-filter-tty-to-GUI) (width . frameset-filter-shelve-param) (window-id . :never) (window-system . :never)) frameset-session-filter-alist) "\ Parameters to filter for persistent framesets. DO NOT MODIFY. See `frameset-filter-alist' for a full description.") @@ -14022,8 +14158,13 @@ DEFAULT-MAP specifies the default key map for ICON-LIST. (when (fboundp 'custom-autoload) (custom-autoload 'gnus-select-method "gnus")) +(autoload 'gnus-child-no-server "gnus" "\ +Read network news as a child, without connecting to the local server. + +\(fn &optional ARG)" t nil) + (autoload 'gnus-slave-no-server "gnus" "\ -Read network news as a slave, without connecting to the local server. +Read network news as a child, without connecting to the local server. \(fn &optional ARG)" t nil) @@ -14036,10 +14177,15 @@ an NNTP server to use. As opposed to `gnus', this command will not connect to the local server. -\(fn &optional ARG SLAVE)" t nil) +\(fn &optional ARG CHILD)" t nil) + +(autoload 'gnus-child "gnus" "\ +Read news as a child. + +\(fn &optional ARG)" t nil) (autoload 'gnus-slave "gnus" "\ -Read news as a slave. +Read news as a child. \(fn &optional ARG)" t nil) @@ -14062,7 +14208,7 @@ If ARG is non-nil and a positive number, Gnus will use that as the startup level. If ARG is non-nil and not a positive number, Gnus will prompt the user for the name of an NNTP server to use. -\(fn &optional ARG DONT-CONNECT SLAVE)" t nil) +\(fn &optional ARG DONT-CONNECT CHILD)" t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "gnus" '("gnus-"))) @@ -14077,8 +14223,13 @@ Start Gnus unplugged." t nil) (autoload 'gnus-plugged "gnus-agent" "\ Start Gnus plugged." t nil) +(autoload 'gnus-child-unplugged "gnus-agent" "\ +Read news as a child unplugged. + +\(fn &optional ARG)" t nil) + (autoload 'gnus-slave-unplugged "gnus-agent" "\ -Read news as a slave unplugged. +Read news as a child unplugged. \(fn &optional ARG)" t nil) @@ -14270,6 +14421,10 @@ DELAY is a string, giving the length of the time. Possible values are: * hh:mm for a specific time. Use 24h format. If it is later than this time, then the deadline is tomorrow, else today. +The value of `message-draft-headers' determines which headers are +generated when the article is delayed. Remaining headers are +generated when the article is sent. + \(fn DELAY)" t nil) (autoload 'gnus-delay-send-queue "gnus-delay" "\ @@ -15376,9 +15531,13 @@ arguments as NAME. DO is a function as defined in `gv-get'. \(fn SYMBOL NAME ARGS HANDLER &optional FIX)" nil nil) -(or (assq 'gv-expander defun-declarations-alist) (let ((x `(gv-expander ,(apply-partially #'gv--defun-declaration 'gv-expander)))) (push x macro-declarations-alist) (push x defun-declarations-alist))) +(defsubst gv--expander-defun-declaration (&rest args) (apply #'gv--defun-declaration 'gv-expander args)) -(or (assq 'gv-setter defun-declarations-alist) (push `(gv-setter ,(apply-partially #'gv--defun-declaration 'gv-setter)) defun-declarations-alist)) +(defsubst gv--setter-defun-declaration (&rest args) (apply #'gv--defun-declaration 'gv-setter args)) + +(or (assq 'gv-expander defun-declarations-alist) (let ((x (list 'gv-expander #'gv--expander-defun-declaration))) (push x macro-declarations-alist) (push x defun-declarations-alist))) + +(or (assq 'gv-setter defun-declarations-alist) (push (list 'gv-setter #'gv--setter-defun-declaration) defun-declarations-alist)) (autoload 'gv-define-setter "gv" "\ Define a setter method for generalized variable NAME. @@ -15740,6 +15899,28 @@ BUFFER should be a buffer or a buffer name. \(fn &optional BUFFER)" t nil) +(autoload 'describe-keymap "help-fns" "\ +Describe key bindings in KEYMAP. +When called interactively, prompt for a variable that has a +keymap value. + +\(fn KEYMAP)" t nil) + +(autoload 'describe-mode "help-fns" "\ +Display documentation of current major mode and minor modes. +A brief summary of the minor modes comes first, followed by the +major mode description. This is followed by detailed +descriptions of the minor modes, each on a separate page. + +For this to work correctly for a minor mode, the mode's indicator +variable (listed in `minor-mode-alist') must also be a function +whose documentation describes the minor mode. + +If called from Lisp with a non-nil BUFFER argument, display +documentation for the major and minor modes of that buffer. + +\(fn &optional BUFFER)" t nil) + (autoload 'doc-file-to-man "help-fns" "\ Produce an nroff buffer containing the doc-strings from the DOC file. @@ -15782,10 +15963,10 @@ Commands: \(fn)" t nil) (autoload 'help-mode-setup "help-mode" "\ -Enter Help Mode in the current buffer." nil nil) +Enter Help mode in the current buffer." nil nil) (autoload 'help-mode-finish "help-mode" "\ -Finalize Help Mode setup in current buffer." nil nil) +Finalize Help mode setup in current buffer." nil nil) (autoload 'help-setup-xref "help-mode" "\ Invoked from commands using the \"*Help*\" buffer to install some xref info. @@ -16097,6 +16278,9 @@ of text in those lines. Interactively, prompt for REGEXP using `read-regexp', then FACE. Use the global history list for FACE. +If REGEXP contains upper case characters (excluding those preceded by `\\') +and `search-upper-case' is non-nil, the matching is case-sensitive. + Use Font lock mode, if enabled, to highlight REGEXP. Otherwise, use overlays for highlighting. If overlays are used, the highlighting will not update as you type. @@ -16112,6 +16296,13 @@ Use the global history list for FACE. Limit face setting to the corresponding SUBEXP (interactively, the prefix argument) of REGEXP. If SUBEXP is omitted or nil, the entire REGEXP is highlighted. +LIGHTER is a human-readable string that can be used to select +a regexp to unhighlight by its name instead of selecting a possibly +complex regexp or closure. + +If REGEXP contains upper case characters (excluding those preceded by `\\') +and `search-upper-case' is non-nil, the matching is case-sensitive. + Use Font lock mode, if enabled, to highlight REGEXP. Otherwise, use overlays for highlighting. If overlays are used, the highlighting will not update as you type. The Font Lock mode @@ -16119,7 +16310,7 @@ is considered \"enabled\" in a buffer if its `major-mode' causes `font-lock-specified-p' to return non-nil, which means the major mode specifies support for Font Lock. -\(fn REGEXP &optional FACE SUBEXP)" t nil) +\(fn REGEXP &optional FACE SUBEXP LIGHTER)" t nil) (defalias 'highlight-phrase 'hi-lock-face-phrase-buffer) @@ -16128,9 +16319,9 @@ Set face of each match of phrase REGEXP to FACE. Interactively, prompt for REGEXP using `read-regexp', then FACE. Use the global history list for FACE. -When called interactively, replace whitespace in user-provided -regexp with arbitrary whitespace, and make initial lower-case -letters case-insensitive, before highlighting with `hi-lock-set-pattern'. +If REGEXP contains upper case characters (excluding those preceded by `\\') +and `search-upper-case' is non-nil, the matching is case-sensitive. +Also set `search-spaces-regexp' to the value of `search-whitespace-regexp'. Use Font lock mode, if enabled, to highlight REGEXP. Otherwise, use overlays for highlighting. If overlays are used, the @@ -16149,6 +16340,9 @@ Uses the next face from `hi-lock-face-defaults' without prompting, unless you use a prefix argument. Uses `find-tag-default-as-symbol-regexp' to retrieve the symbol at point. +If REGEXP contains upper case characters (excluding those preceded by `\\') +and `search-upper-case' is non-nil, the matching is case-sensitive. + This uses Font lock mode if it is enabled; otherwise it uses overlays, in which case the highlighting will not update as you type. The Font Lock mode is considered \"enabled\" in a buffer if its `major-mode' @@ -16428,7 +16622,6 @@ See `highlight-changes-mode' for more information on Highlight-Changes mode. ;;;### (autoloads nil "hippie-exp" "hippie-exp.el" (0 0 0 0)) ;;; Generated autoloads from hippie-exp.el -(push (purecopy '(hippie-exp 1 6)) package--builtin-versions) (defvar hippie-expand-try-functions-list '(try-complete-file-name-partially try-complete-file-name try-expand-all-abbrevs try-expand-list try-expand-line try-expand-dabbrev try-expand-dabbrev-all-buffers try-expand-dabbrev-from-kill try-complete-lisp-symbol-partially try-complete-lisp-symbol) "\ The list of expansion functions tried in order by `hippie-expand'. @@ -16850,7 +17043,6 @@ If optional arg OTHER-WINDOW is non-nil, then use another window. ;;;### (autoloads nil "icalendar" "calendar/icalendar.el" (0 0 0 ;;;;;; 0)) ;;; Generated autoloads from calendar/icalendar.el -(push (purecopy '(icalendar 0 19)) package--builtin-versions) (autoload 'icalendar-export-file "icalendar" "\ Export diary file to iCalendar format. @@ -17169,7 +17361,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 @@ -18279,6 +18470,7 @@ Moving within a node: already visible, try to go to the previous menu entry, or up if there is none. \\[beginning-of-buffer] Go to beginning of node. +\\[end-of-buffer] Go to end of node. Advanced commands: \\[Info-search] Search through this Info file for specified regexp, @@ -19054,7 +19246,7 @@ one of the aforementioned options instead of using this mode. ;;;### (autoloads nil "json" "json.el" (0 0 0 0)) ;;; Generated autoloads from json.el -(push (purecopy '(json 1 4)) package--builtin-versions) +(push (purecopy '(json 1 5)) package--builtin-versions) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "json" '("json-"))) @@ -19062,7 +19254,7 @@ one of the aforementioned options instead of using this mode. ;;;### (autoloads nil "jsonrpc" "jsonrpc.el" (0 0 0 0)) ;;; Generated autoloads from jsonrpc.el -(push (purecopy '(jsonrpc 1 0 9)) package--builtin-versions) +(push (purecopy '(jsonrpc 1 0 12)) package--builtin-versions) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "jsonrpc" '("jrpc-default-request-timeout" "jsonrpc-"))) @@ -19544,7 +19736,6 @@ generations (this defaults to 1). ;;;### (autoloads nil "linum" "linum.el" (0 0 0 0)) ;;; Generated autoloads from linum.el -(push (purecopy '(linum 0 9 24)) package--builtin-versions) (autoload 'linum-mode "linum" "\ Toggle display of line numbers in the left margin (Linum mode). @@ -19710,7 +19901,7 @@ done. Otherwise, it uses the current buffer. \(fn CALLBACK &optional SETUP PARAMS BUFFER MODE &rest IGNORE)" nil nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "log-edit" '("log-edit-" "vc-log-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "log-edit" '("log-edit-"))) ;;;*** @@ -19842,7 +20033,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-"))) ;;;*** @@ -20385,7 +20576,7 @@ Previous contents of that buffer are killed first." t nil) ;;;### (autoloads nil "man" "man.el" (0 0 0 0)) ;;; Generated autoloads from man.el -(defalias 'manual-entry 'man) +(define-obsolete-function-alias 'manual-entry 'man "28.1") (autoload 'man "man" "\ Get a Un*x manual page and put it in a buffer. @@ -20446,7 +20637,7 @@ Default bookmark handler for Man buffers. ;;;### (autoloads nil "map" "emacs-lisp/map.el" (0 0 0 0)) ;;; Generated autoloads from emacs-lisp/map.el -(push (purecopy '(map 2 0)) package--builtin-versions) +(push (purecopy '(map 2 1)) package--builtin-versions) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "map" '("map-"))) @@ -20454,7 +20645,6 @@ Default bookmark handler for Man buffers. ;;;### (autoloads nil "master" "master.el" (0 0 0 0)) ;;; Generated autoloads from master.el -(push (purecopy '(master 1 0 2)) package--builtin-versions) (autoload 'master-mode "master" "\ Toggle Master mode. @@ -20664,49 +20854,6 @@ Major mode for editing MetaPost sources. ;;;*** -;;;### (autoloads nil "metamail" "mail/metamail.el" (0 0 0 0)) -;;; Generated autoloads from mail/metamail.el - -(autoload 'metamail-interpret-header "metamail" "\ -Interpret a header part of a MIME message in current buffer. -Its body part is not interpreted at all." t nil) - -(autoload 'metamail-interpret-body "metamail" "\ -Interpret a body part of a MIME message in current buffer. -Optional argument VIEWMODE specifies the value of the -EMACS_VIEW_MODE environment variable (defaulted to 1). -Optional argument NODISPLAY non-nil means buffer is not -redisplayed as output is inserted. -Its header part is not interpreted at all. - -\(fn &optional VIEWMODE NODISPLAY)" t nil) - -(autoload 'metamail-buffer "metamail" "\ -Process current buffer through `metamail'. -Optional argument VIEWMODE specifies the value of the -EMACS_VIEW_MODE environment variable (defaulted to 1). -Optional argument BUFFER specifies a buffer to be filled (nil -means current). -Optional argument NODISPLAY non-nil means buffer is not -redisplayed as output is inserted. - -\(fn &optional VIEWMODE BUFFER NODISPLAY)" t nil) - -(autoload 'metamail-region "metamail" "\ -Process current region through `metamail'. -Optional argument VIEWMODE specifies the value of the -EMACS_VIEW_MODE environment variable (defaulted to 1). -Optional argument BUFFER specifies a buffer to be filled (nil -means current). -Optional argument NODISPLAY non-nil means buffer is not -redisplayed as output is inserted. - -\(fn BEG END &optional VIEWMODE BUFFER NODISPLAY)" t nil) - -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "metamail" '("metamail-"))) - -;;;*** - ;;;### (autoloads nil "mh-acros" "mh-e/mh-acros.el" (0 0 0 0)) ;;; Generated autoloads from mh-e/mh-acros.el @@ -22177,6 +22324,10 @@ values: `ssl' -- Equivalent to `tls'. `shell' -- A shell connection. +:coding is a symbol or a cons used to specify the coding systems +used to decode and encode the data which the process reads and +writes. See `make-network-process' for details. + :return-list specifies this function's return value. If omitted or nil, return a process object. A non-nil means to return (PROC . PROPS), where PROC is a process object and PROPS @@ -22199,7 +22350,10 @@ values: :capability-command specifies a command used to query the HOST for its capabilities. For instance, for IMAP this should be - \"1 CAPABILITY\\r\\n\". + \"1 CAPABILITY\\r\\n\". This can either be a string (which will + then be sent verbatim to the server), or a function (called with + a single parameter; the \"greeting\" from the server when connecting), + and should return a string to send to the server. :starttls-function specifies a function for handling STARTTLS. This function should take one parameter, the response to the @@ -22230,8 +22384,8 @@ a greeting from the server. :nowait, if non-nil, says the connection should be made asynchronously, if possible. -:shell-command is a format-spec string that can be used if :type -is `shell'. It has two specs, %s for host and %p for port +:shell-command is a `format-spec' string that can be used if +:type is `shell'. It has two specs, %s for host and %p for port number. Example: \"ssh gateway nc %s %p\". :tls-parameters is a list that should be supplied if you're @@ -24753,8 +24907,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 @@ -26139,15 +26294,56 @@ Open profile FILENAME. ;;;### (autoloads nil "project" "progmodes/project.el" (0 0 0 0)) ;;; Generated autoloads from progmodes/project.el +(push (purecopy '(project 0 5 0)) package--builtin-versions) (autoload 'project-current "project" "\ -Return the project instance in DIR or `default-directory'. -When no project found in DIR, and MAYBE-PROMPT is non-nil, ask -the user for a different directory to look in. If that directory -is not a part of a detectable project either, return a -`transient' project instance rooted in it. +Return the project instance in DIRECTORY, defaulting to `default-directory'. + +When no project is found in that directory, the result depends on +the value of MAYBE-PROMPT: if it is nil or omitted, return nil, +else ask the user for a directory in which to look for the +project, and if no project is found there, return a \"transient\" +project instance. + +The \"transient\" project instance is a special kind of value +which denotes a project rooted in that directory and includes all +the files under the directory except for those that should be +ignored (per `project-ignores'). + +See the doc string of `project-find-functions' for the general form +of the project instance object. + +\(fn &optional MAYBE-PROMPT DIRECTORY)" nil nil) + +(defvar project-prefix-map (let ((map (make-sparse-keymap))) (define-key map "f" 'project-find-file) (define-key map "F" 'project-or-external-find-file) (define-key map "b" 'project-switch-to-buffer) (define-key map "s" 'project-shell) (define-key map "d" 'project-dired) (define-key map "v" 'project-vc-dir) (define-key map "c" 'project-compile) (define-key map "e" 'project-eshell) (define-key map "k" 'project-kill-buffers) (define-key map "p" 'project-switch-project) (define-key map "g" 'project-find-regexp) (define-key map "G" 'project-or-external-find-regexp) (define-key map "r" 'project-query-replace-regexp) map) "\ +Keymap for project commands.") + (define-key ctl-x-map "p" project-prefix-map) + +(autoload 'project-other-window-command "project" "\ +Run project command, displaying resultant buffer in another window. + +The following commands are available: + +\\{project-prefix-map} +\\{project-other-window-map}" t nil) + (define-key ctl-x-4-map "p" #'project-other-window-command) + +(autoload 'project-other-frame-command "project" "\ +Run project command, displaying resultant buffer in another frame. + +The following commands are available: + +\\{project-prefix-map} +\\{project-other-frame-map}" t nil) + (define-key ctl-x-5-map "p" #'project-other-frame-command) + +(autoload 'project-other-tab-command "project" "\ +Run project command, displaying resultant buffer in a new tab. -\(fn &optional MAYBE-PROMPT DIR)" nil nil) +The following commands are available: + +\\{project-prefix-map}" t nil) + (define-key tab-prefix-map "p" #'project-other-tab-command) (autoload 'project-find-regexp "project" "\ Find all matches for REGEXP in the current project's roots. @@ -26168,15 +26364,35 @@ pattern to search for. \(fn REGEXP)" t nil) (autoload 'project-find-file "project" "\ -Visit a file (with completion) in the current project's roots. +Visit a file (with completion) in the current project. The completion default is the filename at point, if one is recognized." t nil) (autoload 'project-or-external-find-file "project" "\ -Visit a file (with completion) in the current project's roots or external roots. +Visit a file (with completion) in the current project or external roots. The completion default is the filename at point, if one is recognized." t nil) +(autoload 'project-dired "project" "\ +Start Dired in the current project's root." t nil) + +(autoload 'project-vc-dir "project" "\ +Run VC-Dir in the current project's root." t nil) + +(autoload 'project-shell "project" "\ +Start an inferior shell in the current project's root directory. +If a buffer already exists for running a shell in the project's root, +switch to it. Otherwise, create a new shell buffer. +With \\[universal-argument] prefix arg, create a new inferior shell buffer even +if one already exists." t nil) + +(autoload 'project-eshell "project" "\ +Start Eshell in the current project's root directory. +If a buffer already exists for running Eshell in the project's root, +switch to it. Otherwise, create a new Eshell buffer. +With \\[universal-argument] prefix arg, create a new Eshell buffer even +if one already exists." t nil) + (autoload 'project-search "project" "\ Search for REGEXP in all the files of the project. Stops when a match is found. @@ -26193,6 +26409,81 @@ loop using the command \\[fileloop-continue]. \(fn FROM TO)" t nil) +(autoload 'project-compile "project" "\ +Run `compile' in the project root. +Arguments the same as in `compile'. + +\(fn COMMAND &optional COMINT)" t nil) + +(autoload 'project-switch-to-buffer "project" "\ +Display buffer BUFFER-OR-NAME in the selected window. +When called interactively, prompts for a buffer belonging to the +current project. Two buffers belong to the same project if their +project instances, as reported by `project-current' in each +buffer, are identical. + +\(fn BUFFER-OR-NAME)" t nil) + +(autoload 'project-display-buffer "project" "\ +Display BUFFER-OR-NAME in some window, without selecting it. +When called interactively, prompts for a buffer belonging to the +current project. Two buffers belong to the same project if their +project instances, as reported by `project-current' in each +buffer, are identical. + +This function uses `display-buffer' as a subroutine, which see +for how it is determined where the buffer will be displayed. + +\(fn BUFFER-OR-NAME)" t nil) + +(autoload 'project-display-buffer-other-frame "project" "\ +Display BUFFER-OR-NAME preferably in another frame. +When called interactively, prompts for a buffer belonging to the +current project. Two buffers belong to the same project if their +project instances, as reported by `project-current' in each +buffer, are identical. + +This function uses `display-buffer-other-frame' as a subroutine, +which see for how it is determined where the buffer will be +displayed. + +\(fn BUFFER-OR-NAME)" t nil) + +(autoload 'project-kill-buffers "project" "\ +Kill the buffers belonging to the current project. +Two buffers belong to the same project if their project +instances, as reported by `project-current' in each buffer, are +identical. Only the buffers that match a condition in +`project-kill-buffer-conditions' will be killed. If NO-CONFIRM +is non-nil, the command will not ask the user for confirmation. +NO-CONFIRM is always nil when the command is invoked +interactivly. + +\(fn &optional NO-CONFIRM)" t nil) + +(autoload 'project-remember-project "project" "\ +Add project PR to the front of the project list. +Save the result in `project-list-file' if the list of projects has changed. + +\(fn PR)" nil nil) + +(autoload 'project-known-project-roots "project" "\ +Return the list of root directories of all known projects." nil nil) + +(defvar project-switch-commands '((102 "Find file" project-find-file) (103 "Find regexp" project-find-regexp) (100 "Dired" project-dired) (118 "VC-Dir" project-vc-dir) (101 "Eshell" project-eshell)) "\ +Alist mapping keys to project switching menu entries. +Used by `project-switch-project' to construct a dispatch menu of +commands available upon \"switching\" to another project. + +Each element is of the form (KEY LABEL COMMAND), where COMMAND is the +command to run when KEY is pressed. LABEL is used to distinguish +the menu entries in the dispatch menu.") + +(autoload 'project-switch-project "project" "\ +\"Switch\" to another project by running an Emacs command. +The available commands are presented as a dispatch menu +made from `project-switch-commands'." t nil) + (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "project" '("project-"))) ;;;*** @@ -26848,7 +27139,7 @@ HELP-TEXT is a text set in `hangul-input-method-help-text'. ;;;;;; 0 0)) ;;; Generated autoloads from leim/quail/indian.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "quail/indian" '("inscript-" "quail-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "quail/indian" '("indian-mlm-mozhi-u" "inscript-" "quail-"))) ;;;*** @@ -27507,7 +27798,6 @@ This means the number of non-shy regexp grouping constructs ;;;### (autoloads nil "remember" "textmodes/remember.el" (0 0 0 0)) ;;; Generated autoloads from textmodes/remember.el -(push (purecopy '(remember 2 0)) package--builtin-versions) (autoload 'remember "remember" "\ Remember an arbitrary piece of data. @@ -27559,7 +27849,6 @@ to turn the *scratch* buffer into your notes buffer. ;;;### (autoloads nil "repeat" "repeat.el" (0 0 0 0)) ;;; Generated autoloads from repeat.el -(push (purecopy '(repeat 0 51)) package--builtin-versions) (autoload 'repeat "repeat" "\ Repeat most recently executed command. @@ -28434,7 +28723,6 @@ Major mode for editing Ruby code. ;;;### (autoloads nil "ruler-mode" "ruler-mode.el" (0 0 0 0)) ;;; Generated autoloads from ruler-mode.el -(push (purecopy '(ruler-mode 1 6)) package--builtin-versions) (defvar ruler-mode nil "\ Non-nil if Ruler mode is enabled. @@ -28642,7 +28930,7 @@ For more details, see Info node `(elisp) Extending Rx'. \(fn NAME [(ARGS...)] RX)" nil t) -(function-put 'rx-define 'lisp-indent-function '1) +(function-put 'rx-define 'lisp-indent-function 'defun) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rx" '("rx-"))) @@ -28685,6 +28973,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) @@ -28786,13 +29082,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 @@ -29908,6 +30197,11 @@ If SEQUENCE is empty, return INITIAL-VALUE and FUNCTION is not called. \(fn FUNCTION SEQUENCE INITIAL-VALUE)" nil nil) +(autoload 'seq-every-p "seq" "\ +Return non-nil if (PRED element) is non-nil for all elements of SEQUENCE. + +\(fn PRED SEQUENCE)" nil nil) + (autoload 'seq-some "seq" "\ Return non-nil if PRED is satisfied for at least one element of SEQUENCE. If so, return the first non-nil value returned by PRED. @@ -30098,7 +30392,7 @@ have <h1>Very Major Headlines</h1> through <h6>Very Minor Headlines</h6> <p>Paragraphs only need an opening tag. Line breaks and multiple spaces are ignored unless the text is <pre>preformatted.</pre> Text can be marked as -<b>bold</b>, <i>italic</i> or <u>underlined</u> using the normal M-o or +<strong>bold</strong>, <em>italic</em> or <u>underlined</u> using the normal M-o or Edit/Text Properties/Face commands. Pages can have <a name=\"SOMENAME\">named points</a> and can link other points @@ -30156,11 +30450,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. @@ -30617,7 +30909,9 @@ enable the mode if ARG is omitted or nil, and toggle it if ARG is (autoload 'smerge-start-session "smerge-mode" "\ Turn on `smerge-mode' and move point to first conflict marker. -If no conflict maker is found, turn off `smerge-mode'." t nil) +If no conflict maker is found, turn off `smerge-mode'. + +\(fn &optional INTERACTIVELY)" t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "smerge-mode" '("smerge-"))) @@ -32081,6 +32375,11 @@ The variable list SPEC is the same as in `if-let'. (function-put 'when-let 'lisp-indent-function '1) +(autoload 'string-truncate-left "subr-x" "\ +Truncate STRING to LENGTH, replacing initial surplus with \"...\". + +\(fn STRING LENGTH)" nil nil) + (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "subr-x" '("and-let*" "hash-table-" "if-let" "internal--" "replace-region-contents" "string-" "thread-" "when-let*"))) ;;;*** @@ -33273,7 +33572,7 @@ Should show the queue(s) that \\[tex-print] puts jobs on.") (custom-autoload 'tex-show-queue-command "tex-mode" t) -(defvar tex-default-mode 'latex-mode "\ +(defvar tex-default-mode #'latex-mode "\ Mode to enter for a new file that might be either TeX or LaTeX. This variable is used when it can't be determined whether the file is plain TeX or LaTeX or what because the file contains no commands. @@ -33293,11 +33592,14 @@ String inserted by typing \\[tex-insert-quote] to close a quotation.") (autoload 'tex-mode "tex-mode" "\ Major mode for editing files of input for TeX, LaTeX, or SliTeX. +This is the shared parent mode of several submodes. Tries to determine (by looking at the beginning of the file) whether this file is for plain TeX, LaTeX, or SliTeX and calls `plain-tex-mode', -`latex-mode', or `slitex-mode', respectively. If it cannot be determined, +`latex-mode', or `slitex-mode', accordingly. If it cannot be determined, such as if there are no commands in the file, the value of `tex-default-mode' -says which mode to use." t nil) +says which mode to use. + +\(fn)" t nil) (defalias 'TeX-mode 'tex-mode) @@ -34508,7 +34810,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. @@ -34538,18 +34840,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))) @@ -34585,7 +34884,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) @@ -34617,6 +34916,13 @@ Add archive file name handler to `file-name-handler-alist'." (when tramp-archive ;;;*** +;;;### (autoloads nil "tramp-crypt" "net/tramp-crypt.el" (0 0 0 0)) +;;; Generated autoloads from net/tramp-crypt.el + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tramp-crypt" '("tramp-crypt-"))) + +;;;*** + ;;;### (autoloads nil "tramp-ftp" "net/tramp-ftp.el" (0 0 0 0)) ;;; Generated autoloads from net/tramp-ftp.el @@ -35936,7 +36242,10 @@ Note that if FILE is a symbolic link, it will not be resolved -- the responsible backend system for the symbolic link itself will be reported. -\(fn FILE)" nil nil) +If NO-ERROR is nil, signal an error that no VC backend is +responsible for the given file. + +\(fn FILE &optional NO-ERROR)" nil nil) (autoload 'vc-next-action "vc" "\ Do the next logical version control operation on the current fileset. @@ -36132,7 +36441,7 @@ with its diffs (if the underlying VCS supports that). \(fn &optional LIMIT REVISION)" t nil) (autoload 'vc-print-branch-log "vc" "\ -Show the change log for BRANCH in a window. +Show the change log for BRANCH root in a window. \(fn BRANCH)" t nil) @@ -36356,6 +36665,11 @@ Name of the format file in a .bzr directory.") ;;;### (autoloads nil "vc-dir" "vc/vc-dir.el" (0 0 0 0)) ;;; Generated autoloads from vc/vc-dir.el +(autoload 'vc-dir-root "vc-dir" "\ +Run `vc-dir' in the repository root directory without prompt. +If the default directory of the current buffer is +not under version control, prompt for a directory." t nil) + (autoload 'vc-dir "vc-dir" "\ Show the VC status for \"interesting\" files in and below DIR. This allows you to mark files and perform VC operations on them. @@ -36375,6 +36689,13 @@ These are the commands available for use in the file status buffer: \(fn DIR &optional BACKEND)" t nil) +(autoload 'vc-dir-bookmark-jump "vc-dir" "\ +Provides the bookmark-jump behavior for a `vc-dir' buffer. +This implements the `handler' function interface for the record +type returned by `vc-dir-bookmark-make-record'. + +\(fn BMK)" nil nil) + (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "vc-dir" '("vc-"))) ;;;*** @@ -36592,7 +36913,7 @@ Key bindings: ;;;### (autoloads nil "verilog-mode" "progmodes/verilog-mode.el" ;;;;;; (0 0 0 0)) ;;; Generated autoloads from progmodes/verilog-mode.el -(push (purecopy '(verilog-mode 2019 12 17 268053413)) package--builtin-versions) +(push (purecopy '(verilog-mode 2020 6 27 14326051)) package--builtin-versions) (autoload 'verilog-mode "verilog-mode" "\ Major mode for editing Verilog code. @@ -37784,7 +38105,6 @@ this is equivalent to `display-warning', using ;;;### (autoloads nil "wdired" "wdired.el" (0 0 0 0)) ;;; Generated autoloads from wdired.el -(push (purecopy '(wdired 2 0)) package--builtin-versions) (autoload 'wdired-change-to-wdired-mode "wdired" "\ Put a Dired buffer in Writable Dired (WDired) mode. @@ -38383,6 +38703,11 @@ Display the next buffer in the same window. \(fn &optional ARG)" t nil) +(autoload 'windmove-display-new-frame "windmove" "\ +Display the next buffer in a new frame. + +\(fn &optional ARG)" t nil) + (autoload 'windmove-display-new-tab "windmove" "\ Display the next buffer in a new tab. @@ -38495,7 +38820,6 @@ you can press `C-c <right>' (calling `winner-redo'). ;;;### (autoloads nil "woman" "woman.el" (0 0 0 0)) ;;; Generated autoloads from woman.el -(push (purecopy '(woman 0 551)) package--builtin-versions) (defvar woman-locale nil "\ String specifying a manual page locale, or nil. @@ -38642,6 +38966,7 @@ If LIMIT is non-nil, then do not consider characters beyond LIMIT. ;;;### (autoloads nil "xref" "progmodes/xref.el" (0 0 0 0)) ;;; Generated autoloads from progmodes/xref.el +(push (purecopy '(xref 1 0 1)) package--builtin-versions) (autoload 'xref-find-backend "xref" nil nil nil) @@ -38867,31 +39192,40 @@ Zone out, completely." t nil) ;;;;;; "electric.el" "emacs-lisp/backquote.el" "emacs-lisp/byte-run.el" ;;;;;; "emacs-lisp/cl-extra.el" "emacs-lisp/cl-macs.el" "emacs-lisp/cl-preloaded.el" ;;;;;; "emacs-lisp/cl-seq.el" "emacs-lisp/eieio-compat.el" "emacs-lisp/eieio-custom.el" -;;;;;; "emacs-lisp/eieio-opt.el" "emacs-lisp/eldoc.el" "emacs-lisp/float-sup.el" -;;;;;; "emacs-lisp/lisp-mode.el" "emacs-lisp/lisp.el" "emacs-lisp/macroexp.el" -;;;;;; "emacs-lisp/map-ynp.el" "emacs-lisp/nadvice.el" "emacs-lisp/syntax.el" -;;;;;; "emacs-lisp/timer.el" "env.el" "epa-hook.el" "erc/erc-autoaway.el" -;;;;;; "erc/erc-button.el" "erc/erc-capab.el" "erc/erc-compat.el" -;;;;;; "erc/erc-dcc.el" "erc/erc-desktop-notifications.el" "erc/erc-ezbounce.el" -;;;;;; "erc/erc-fill.el" "erc/erc-identd.el" "erc/erc-imenu.el" -;;;;;; "erc/erc-join.el" "erc/erc-list.el" "erc/erc-log.el" "erc/erc-match.el" -;;;;;; "erc/erc-menu.el" "erc/erc-netsplit.el" "erc/erc-notify.el" -;;;;;; "erc/erc-page.el" "erc/erc-pcomplete.el" "erc/erc-replace.el" -;;;;;; "erc/erc-ring.el" "erc/erc-services.el" "erc/erc-sound.el" -;;;;;; "erc/erc-speedbar.el" "erc/erc-spelling.el" "erc/erc-stamp.el" -;;;;;; "erc/erc-track.el" "erc/erc-truncate.el" "erc/erc-xdcc.el" -;;;;;; "eshell/em-alias.el" "eshell/em-banner.el" "eshell/em-basic.el" -;;;;;; "eshell/em-cmpl.el" "eshell/em-dirs.el" "eshell/em-glob.el" -;;;;;; "eshell/em-hist.el" "eshell/em-ls.el" "eshell/em-pred.el" -;;;;;; "eshell/em-prompt.el" "eshell/em-rebind.el" "eshell/em-script.el" -;;;;;; "eshell/em-smart.el" "eshell/em-term.el" "eshell/em-tramp.el" -;;;;;; "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" +;;;;;; "emacs-lisp/eieio-opt.el" "emacs-lisp/float-sup.el" "emacs-lisp/lisp-mode.el" +;;;;;; "emacs-lisp/lisp.el" "emacs-lisp/macroexp.el" "emacs-lisp/map-ynp.el" +;;;;;; "emacs-lisp/nadvice.el" "emacs-lisp/syntax.el" "emacs-lisp/timer.el" +;;;;;; "env.el" "epa-hook.el" "erc/erc-autoaway.el" "erc/erc-button.el" +;;;;;; "erc/erc-capab.el" "erc/erc-compat.el" "erc/erc-dcc.el" "erc/erc-desktop-notifications.el" +;;;;;; "erc/erc-ezbounce.el" "erc/erc-fill.el" "erc/erc-identd.el" +;;;;;; "erc/erc-imenu.el" "erc/erc-join.el" "erc/erc-list.el" "erc/erc-log.el" +;;;;;; "erc/erc-match.el" "erc/erc-menu.el" "erc/erc-netsplit.el" +;;;;;; "erc/erc-notify.el" "erc/erc-page.el" "erc/erc-pcomplete.el" +;;;;;; "erc/erc-replace.el" "erc/erc-ring.el" "erc/erc-services.el" +;;;;;; "erc/erc-sound.el" "erc/erc-speedbar.el" "erc/erc-spelling.el" +;;;;;; "erc/erc-stamp.el" "erc/erc-track.el" "erc/erc-truncate.el" +;;;;;; "erc/erc-xdcc.el" "eshell/em-alias.el" "eshell/em-banner.el" +;;;;;; "eshell/em-basic.el" "eshell/em-cmpl.el" "eshell/em-dirs.el" +;;;;;; "eshell/em-glob.el" "eshell/em-hist.el" "eshell/em-ls.el" +;;;;;; "eshell/em-pred.el" "eshell/em-prompt.el" "eshell/em-rebind.el" +;;;;;; "eshell/em-script.el" "eshell/em-smart.el" "eshell/em-term.el" +;;;;;; "eshell/em-tramp.el" "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/charprop.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/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/indian.el b/lisp/leim/quail/indian.el index 2681eab0e5e..100ae63f6ac 100644 --- a/lisp/leim/quail/indian.el +++ b/lisp/leim/quail/indian.el @@ -117,6 +117,7 @@ indian-knd-itrans-v5-hash "kannada-itrans" "Kannada" "KndIT" "Kannada transliteration by ITRANS method.") +;; ITRANS not applicable to Malayalam & could be removed eventually (if nil (quail-define-package "malayalam-itrans" "Malayalam" "MlmIT" t "Malayalam ITRANS")) (quail-define-indian-trans-package @@ -358,24 +359,23 @@ Full key sequences are listed below:") '( (;; VOWELS (18) (?D nil) (?E ?e) (?F ?f) (?R ?r) (?G ?g) (?T ?t) - (?+ ?=) ("F]" "f]") (?! ?@) (?S ?s) (?Z ?z) (?W ?w) - (?| ?\\) (?~ ?`) (?A ?a) (?Q ?q) ("+]" "=]") ("R]" "r]")) + (?= ?+) nil nil (?S ?s) (?Z ?z) (?W ?w) + nil (?~ ?`) (?A ?a) (?Q ?q)) (;; CONSONANTS (42) ?k ?K ?i ?I ?U ;; GRUTTALS ?\; ?: ?p ?P ?} ;; PALATALS ?' ?\" ?\[ ?{ ?C ;; CEREBRALS - ?l ?L ?o ?O ?v ?V ;; DENTALS + ?l ?L ?o ?O ?v nil ;; DENTALS ?h ?H ?y ?Y ?c ;; LABIALS - ?/ ?j ?J ?n ?N "N]" ?b ;; SEMIVOWELS + ?/ ?j ?J ?n ?N ?B ?b ;; SEMIVOWELS ?M ?< ?m ?u ;; SIBILANTS - "k]" "K]" "i]" "p]" "[]" "{]" "H]" "/]" ;; NUKTAS - ?% ?&) + nil nil nil nil nil nil nil nil nil) ;; NUKTAS (;; Misc Symbols (7) - ?X ?x ?_ ">]" ?d "X]" ?>) + nil ?x ?_ nil ?d) (;; Digits ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9) - (;; Inscripts - ?# ?$ ?^ ?* ?\]))) + (;; Chillus + "Cd" "Cd]" "vd" "vd]" "jd" "jd]" "nd" "nd]" "Nd" "Nd]"))) (defvar inscript-tml-keytable '( @@ -463,6 +463,9 @@ Full key sequences are listed below:") "malayalam-inscript" "Malayalam" "MlmIS" "Malayalam keyboard Inscript.") +(quail-defrule "\\" ?‌) +(quail-defrule "X" ?​) + (if nil (quail-define-package "tamil-inscript" "Tamil" "TmlIS" t "Tamil keyboard Inscript")) (quail-define-inscript-package @@ -571,4 +574,72 @@ Full key sequences are listed below:") ("?" ?\?) ("/" ?à§)) +(defun indian-mlm-mozhi-update-translation (control-flag) + (let ((len (length quail-current-key)) chillu + (vowels '(?a ?e ?i ?o ?u ?A ?E ?I ?O ?U ?R))) + (cond ((numberp control-flag) + (progn (if (= control-flag 0) + (setq quail-current-str quail-current-key) + (cond (input-method-exit-on-first-char) + ((and (memq (aref quail-current-key + (1- control-flag)) + vowels) + (setq chillu (cl-position + (aref quail-current-key + control-flag) + '(?m ?N ?n ?r ?l ?L)))) + ;; conditions for putting chillu + (and (or (and (= control-flag (1- len)) + (not (setq control-flag nil))) + (and (= control-flag (- len 2)) + (let ((temp (aref quail-current-key + (1- len)))) + ;; is it last char of word? + (not + (or (and (>= temp ?a) (<= temp ?z)) + (and (>= temp ?A) (<= temp ?Z)) + (eq temp ?~)))) + (setq control-flag (1+ control-flag)))) + (setq quail-current-str ;; put chillu + (concat (if (not (stringp + quail-current-str)) + (string quail-current-str) + quail-current-str) + (string + (nth chillu '(?à´‚ ?ൺ ?ൻ ?ർ ?ൽ ?ൾ))))))))) + (and (not input-method-exit-on-first-char) control-flag + (while (> len control-flag) + (setq len (1- len)) + (setq unread-command-events + (cons (aref quail-current-key len) + unread-command-events)))) + )) + ((null control-flag) + (unless quail-current-str + (setq quail-current-str quail-current-key) + )) + ((equal control-flag t) + (if (memq (aref quail-current-key (1- len)) ;; If vowel ending, + vowels) ;; may have to put + (setq control-flag nil))))) ;; chillu. So don't + control-flag) ;; end translation + +(quail-define-package "malayalam-mozhi" "Malayalam" "MlmMI" t + "Malayalam transliteration by Mozhi method." + nil nil t nil nil nil t nil + 'indian-mlm-mozhi-update-translation) + +(maphash + (lambda (key val) + (quail-defrule key (if (= (length val) 1) + (string-to-char val) + (vector val)))) + (cdr indian-mlm-mozhi-hash)) + +(defun indian-mlm-mozhi-underscore (key len) (throw 'quail-tag nil)) + +(quail-defrule "_" 'indian-mlm-mozhi-underscore) +(quail-defrule "|" ?‌) +(quail-defrule "||" ?​) + ;;; indian.el ends here diff --git a/lisp/leim/quail/latin-ltx.el b/lisp/leim/quail/latin-ltx.el index 35a9adbe29b..6a2508ba31d 100644 --- a/lisp/leim/quail/latin-ltx.el +++ b/lisp/leim/quail/latin-ltx.el @@ -242,12 +242,14 @@ system, including many technical ones. Examples: ((lambda (name char) ;; "GREEK SMALL LETTER PHI" (which is \phi) and "GREEK PHI SYMBOL" ;; (which is \varphi) are reversed in `ucs-names', so we define - ;; them manually. - (unless (string-match-p "\\<PHI\\>" name) + ;; them manually. Also ignore "GREEK SMALL LETTER EPSILON" and + ;; add the correct value for \epsilon manually. + (unless (string-match-p "\\<\\(?:PHI\\|GREEK SMALL LETTER EPSILON\\)\\>" name) (concat "\\" (funcall (if (match-end 1) #' capitalize #'downcase) (match-string 2 name))))) "\\`GREEK \\(?:SMALL\\|CAPITA\\(L\\)\\) LETTER \\([^- ]+\\)\\'") + ("\\epsilon" ?ϵ) ("\\phi" ?Ï•) ("\\Box" ?â–¡) ("\\Bumpeq" ?≎) @@ -641,6 +643,7 @@ system, including many technical ones. Examples: (concat "\\var" (downcase (match-string 1 name))))) "\\`GREEK \\([^- ]+\\) SYMBOL\\'") + ("\\varepsilon" ?ε) ("\\varphi" ?φ) ("\\varprime" ?′) ("\\varpropto" ?âˆ) @@ -727,7 +730,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/linum.el b/lisp/linum.el index 8f0e7ddce4d..e8c364245ae 100644 --- a/lisp/linum.el +++ b/lisp/linum.el @@ -5,7 +5,7 @@ ;; Author: Markus Triska <markus.triska@gmx.at> ;; Maintainer: emacs-devel@gnu.org ;; Keywords: convenience -;; Version: 0.9x +;; Old-Version: 0.9x ;; This file is part of GNU Emacs. @@ -32,6 +32,7 @@ ;;; Code: (defconst linum-version "0.9x") +(make-obsolete-variable 'linum-version nil "28.1") (defvar linum-overlays nil "Overlays used in this buffer.") (defvar linum-available nil "Overlays available for reuse.") diff --git a/lisp/ls-lisp.el b/lisp/ls-lisp.el index 2952242c251..8851522bbdb 100644 --- a/lisp/ls-lisp.el +++ b/lisp/ls-lisp.el @@ -435,9 +435,9 @@ not contain `d', so that a full listing is expected." ;; text. But if the listing is empty, as e.g. in empty ;; directories with -a removed from switches, point will be ;; before the inserted text, and dired-insert-directory will - ;; not indent the listing correctly. Going to the end of the - ;; buffer fixes that. - (unless files (goto-char (point-max))) + ;; not indent the listing correctly. Getting past the + ;; inserted text solves this. + (unless (cdr total-line) (forward-line 2)) (if (memq ?R switches) ;; List the contents of all directories recursively. ;; cadr of each element of `file-alist' is t for diff --git a/lisp/mail/emacsbug.el b/lisp/mail/emacsbug.el index 7f3dc4454ab..efbc0668553 100644 --- a/lisp/mail/emacsbug.el +++ b/lisp/mail/emacsbug.el @@ -208,7 +208,11 @@ This requires either the macOS \"open\" command, or the freedesktop ;;;###autoload (defun report-emacs-bug (topic &optional unused) "Report a bug in GNU Emacs. -Prompts for bug subject. Leaves you in a mail buffer." +Prompts for bug subject. Leaves you in a mail buffer. + +Already submitted bugs can be found in the Emacs bug tracker: + + https://debbugs.gnu.org/cgi/pkgreport.cgi?package=emacs;max-bugs=100;base-order=1;bug-rev=1" (declare (advertised-calling-convention (topic) "24.5")) (interactive "sBug Subject: ") ;; The syntax `version;' is preferred to `[version]' because the @@ -270,7 +274,7 @@ Prompts for bug subject. Leaves you in a mail buffer." 'face 'link 'help-echo (concat "mouse-2, RET: Follow this link") 'action (lambda (button) - (browse-url "https://debbugs.gnu.org/")) + (browse-url "https://debbugs.gnu.org/cgi/pkgreport.cgi?package=emacs;max-bugs=100;base-order=1;bug-rev=1")) 'follow-link t) (insert ". Please check that 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/qp.el b/lisp/mail/qp.el index 388c3981c97..35ff47fd098 100644 --- a/lisp/mail/qp.el +++ b/lisp/mail/qp.el @@ -1,4 +1,4 @@ -;;; qp.el --- Quoted-Printable functions +;;; qp.el --- Quoted-Printable functions -*- lexical-binding:t -*- ;; Copyright (C) 1998-2020 Free Software Foundation, Inc. diff --git a/lisp/mail/rfc2045.el b/lisp/mail/rfc2045.el index 7d962ea2348..dba9c04cc83 100644 --- a/lisp/mail/rfc2045.el +++ b/lisp/mail/rfc2045.el @@ -1,4 +1,4 @@ -;;; rfc2045.el --- Functions for decoding rfc2045 headers +;;; rfc2045.el --- Functions for decoding rfc2045 headers -*- lexical-binding:t -*- ;; Copyright (C) 1998-2020 Free Software Foundation, Inc. diff --git a/lisp/mail/rfc2368.el b/lisp/mail/rfc2368.el index 7b38288be20..afa30590059 100644 --- a/lisp/mail/rfc2368.el +++ b/lisp/mail/rfc2368.el @@ -1,4 +1,4 @@ -;;; rfc2368.el --- support for rfc2368 +;;; rfc2368.el --- support for rfc2368 -*- lexical-binding:t -*- ;; Copyright (C) 1998, 2000-2020 Free Software Foundation, Inc. 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 3feff803e3e..44cde7cb5a9 100644 --- a/lisp/mail/rmail.el +++ b/lisp/mail/rmail.el @@ -578,11 +578,21 @@ Examples: (defvar rmail-reply-prefix "Re: " "String to prepend to Subject line when replying to a message.") +;; Note: this is matched with case-fold-search bound to t. +(defcustom rmail-re-abbrevs + "\\(RE\\|رد\\|回å¤\\|回覆\\|SV\\|Antw\\|VS\\|REF\\|AW\\|ΑΠ\\|ΣΧΕΤ\\|השב\\|Vá\\|R\\|RIF\\|BLS\\|RES\\|Odp\\|YNT\\|ATB\\)" + "Regexp with localized 'Re:' abbreviations in various languages." + :version "28.1" + :type 'regexp) + ;; Some mailers use "Re(2):" or "Re^2:" or "Re: Re:" or "Re[2]:". ;; This pattern should catch all the common variants. ;; rms: I deleted the change to delete tags in square brackets ;; because they mess up RT tags. -(defvar rmail-reply-regexp "\\`\\(Re\\(([0-9]+)\\|\\[[0-9]+\\]\\|\\^[0-9]+\\)?: *\\)*" +(defvar rmail-reply-regexp + (concat "\\`\\(" + rmail-re-abbrevs + "\\(([0-9]+)\\|\\[[0-9]+\\]\\|\\^[0-9]+\\)?[:：] *\\)*") "Regexp to delete from Subject line before inserting `rmail-reply-prefix'.") (defcustom rmail-display-summary nil @@ -3398,7 +3408,7 @@ whitespace, replacing whitespace runs with a single space and removing prefixes such as Re:, Fwd: and so on and mailing list tags such as [tag]." (let ((subject (or (rmail-get-header "Subject" msgnum) "")) - (regexp "\\`[ \t\n]*\\(\\(\\w\\{1,3\\}:\\|\\[[^]]+]\\)[ \t\n]+\\)*")) + (regexp "\\`[ \t\n]*\\(\\(\\w\\{1,4\\}[:：]\\|\\[[^]]+]\\)[ \t\n]+\\)*")) (setq subject (rfc2047-decode-string subject)) (setq subject (replace-regexp-in-string regexp "" subject)) (replace-regexp-in-string "[ \t\n]+" " " subject))) @@ -4393,9 +4403,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/mail/smtpmail.el b/lisp/mail/smtpmail.el index f5c9432879f..666395e0b9e 100644 --- a/lisp/mail/smtpmail.el +++ b/lisp/mail/smtpmail.el @@ -53,6 +53,7 @@ ;; See http://www.ietf.org/rfc/rfc2554.txt ;;; Code: +;;; Dependencies (require 'sendmail) (require 'auth-source) @@ -61,12 +62,12 @@ (autoload 'message-make-message-id "message") (autoload 'rfc2104-hash "rfc2104") -;;; +;;; Options + (defgroup smtpmail nil "SMTP protocol for sending mail." :group 'mail) - (defcustom smtpmail-default-smtp-server nil "Specify default SMTP server. This only has effect if you specify it before loading the smtpmail library." @@ -172,8 +173,7 @@ mean \"try again\"." :type 'integer :version "27.1") -;; End of customizable variables. - +;;; Variables (defvar smtpmail-address-buffer) (defvar smtpmail-recipient-address-list) @@ -192,6 +192,8 @@ for `smtpmail-try-auth-method'.") (defvar smtpmail-mail-address nil "Value to use for envelope-from address for mail from ambient buffer.") +;;; Functions + ;;;###autoload (defun smtpmail-send-it () (let ((errbuf (if mail-interactive diff --git a/lisp/man.el b/lisp/man.el index c914ec34b97..da8a15f69b9 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." @@ -836,7 +836,8 @@ POS defaults to `point'." ;; ====================================================================== ;; Top level command and background process sentinel -;; For compatibility with older versions. +;; This alias was originally for compatibility with older versions. +;; Some users got used to having it, so we will not remove it. ;;;###autoload (defalias 'manual-entry 'man) @@ -1396,7 +1397,7 @@ synchronously, PROCESS is the name of the buffer where the manpage command is run. Second argument STRING is the entire string of output." (save-excursion (let ((Man-buffer (process-buffer process))) - (if (null (buffer-name Man-buffer)) ;; deleted buffer + (if (not (buffer-live-p Man-buffer)) ;; deleted buffer (set-process-buffer process nil) (with-current-buffer Man-buffer @@ -1430,7 +1431,7 @@ manpage command." (delete-buff nil) message) - (if (null (buffer-name Man-buffer)) ;; deleted buffer + (if (not (buffer-live-p Man-buffer)) ;; deleted buffer (or (stringp process) (set-process-buffer process nil)) diff --git a/lisp/master.el b/lisp/master.el index b0996bf1290..387116a8fbd 100644 --- a/lisp/master.el +++ b/lisp/master.el @@ -3,7 +3,7 @@ ;; Copyright (C) 1999-2020 Free Software Foundation, Inc. ;; Author: Alex Schroeder <alex@gnu.org> -;; Version: 1.0.2 +;; Old-Version: 1.0.2 ;; Keywords: comm ;; This file is part of GNU Emacs. diff --git a/lisp/menu-bar.el b/lisp/menu-bar.el index cc12a17c794..bc094c9050d 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 @@ -1803,6 +1815,10 @@ mail status in mode line")) (bindings--define-key menu [list-keybindings] '(menu-item "List Key Bindings" describe-bindings :help "Display all current key bindings (keyboard shortcuts)")) + (bindings--define-key menu [list-recent-keystrokes] + '(menu-item "Show Recent Inputs" view-lossage + :help "Display last few input events and the commands \ +they ran")) (bindings--define-key menu [describe-current-display-table] '(menu-item "Describe Display Table" describe-current-display-table :help "Describe the current display table")) diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index f6e2b236f3e..d2c3f9045e5 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -1968,12 +1968,13 @@ variables.") (plist-get completion-extra-properties :annotation-function) completion-annotate-function)) + (mainbuf (current-buffer)) ;; If the *Completions* buffer is shown in a new ;; window, mark it as softly-dedicated, so bury-buffer in ;; minibuffer-hide-completions will know whether to ;; delete the window or not. (display-buffer-mark-dedicated 'soft)) - (with-displayed-buffer-window + (with-current-buffer-window "*Completions*" ;; This is a copy of `display-buffer-fallback-action' ;; where `display-buffer-use-some-window' is replaced @@ -1987,66 +1988,69 @@ variables.") ,(if (eq (selected-window) (minibuffer-window)) 'display-buffer-at-bottom 'display-buffer-below-selected)) - ,(if temp-buffer-resize-mode - '(window-height . resize-temp-buffer-window) - '(window-height . fit-window-to-buffer)) - ,(when temp-buffer-resize-mode - '(preserve-size . (nil . t)))) - nil - ;; Remove the base-size tail because `sort' requires a properly - ;; nil-terminated list. - (when last (setcdr last nil)) - (setq completions - ;; FIXME: This function is for the output of all-completions, - ;; not completion-all-completions. Often it's the same, but - ;; not always. - (let ((sort-fun (completion-metadata-get - all-md 'display-sort-function))) - (if sort-fun - (funcall sort-fun completions) - (sort completions 'string-lessp)))) - (when afun - (setq completions - (mapcar (lambda (s) - (let ((ann (funcall afun s))) - (if ann (list s ann) s))) - completions))) - - (with-current-buffer standard-output - (set (make-local-variable 'completion-base-position) - (list (+ start base-size) - ;; FIXME: We should pay attention to completion - ;; boundaries here, but currently - ;; completion-all-completions does not give us the - ;; necessary information. - end)) - (set (make-local-variable 'completion-list-insert-choice-function) - (let ((ctable minibuffer-completion-table) - (cpred minibuffer-completion-predicate) - (cprops completion-extra-properties)) - (lambda (start end choice) - (unless (or (zerop (length prefix)) - (equal prefix - (buffer-substring-no-properties - (max (point-min) - (- start (length prefix))) - start))) - (message "*Completions* out of date")) - ;; FIXME: Use `md' to do quoting&terminator here. - (completion--replace start end choice) - (let* ((minibuffer-completion-table ctable) - (minibuffer-completion-predicate cpred) - (completion-extra-properties cprops) - (result (concat prefix choice)) - (bounds (completion-boundaries - result ctable cpred ""))) - ;; If the completion introduces a new field, then - ;; completion is not finished. - (completion--done result - (if (eq (car bounds) (length result)) - 'exact 'finished))))))) - - (display-completion-list completions)))) + ,(if temp-buffer-resize-mode + '(window-height . resize-temp-buffer-window) + '(window-height . fit-window-to-buffer)) + ,(when temp-buffer-resize-mode + '(preserve-size . (nil . t))) + (body-function + . ,#'(lambda (_window) + (with-current-buffer mainbuf + ;; Remove the base-size tail because `sort' requires a properly + ;; nil-terminated list. + (when last (setcdr last nil)) + (setq completions + ;; FIXME: This function is for the output of all-completions, + ;; not completion-all-completions. Often it's the same, but + ;; not always. + (let ((sort-fun (completion-metadata-get + all-md 'display-sort-function))) + (if sort-fun + (funcall sort-fun completions) + (sort completions 'string-lessp)))) + (when afun + (setq completions + (mapcar (lambda (s) + (let ((ann (funcall afun s))) + (if ann (list s ann) s))) + completions))) + + (with-current-buffer standard-output + (set (make-local-variable 'completion-base-position) + (list (+ start base-size) + ;; FIXME: We should pay attention to completion + ;; boundaries here, but currently + ;; completion-all-completions does not give us the + ;; necessary information. + end)) + (set (make-local-variable 'completion-list-insert-choice-function) + (let ((ctable minibuffer-completion-table) + (cpred minibuffer-completion-predicate) + (cprops completion-extra-properties)) + (lambda (start end choice) + (unless (or (zerop (length prefix)) + (equal prefix + (buffer-substring-no-properties + (max (point-min) + (- start (length prefix))) + start))) + (message "*Completions* out of date")) + ;; FIXME: Use `md' to do quoting&terminator here. + (completion--replace start end choice) + (let* ((minibuffer-completion-table ctable) + (minibuffer-completion-predicate cpred) + (completion-extra-properties cprops) + (result (concat prefix choice)) + (bounds (completion-boundaries + result ctable cpred ""))) + ;; If the completion introduces a new field, then + ;; completion is not finished. + (completion--done result + (if (eq (car bounds) (length result)) + 'exact 'finished))))))) + + (display-completion-list completions))))) + nil))) nil)) (defun minibuffer-hide-completions () diff --git a/lisp/misc.el b/lisp/misc.el index 05244a6ea2f..8c39492784b 100644 --- a/lisp/misc.el +++ b/lisp/misc.el @@ -1,4 +1,4 @@ -;;; misc.el --- some nonstandard editing and utility commands for Emacs +;;; misc.el --- some nonstandard editing and utility commands for Emacs -*- lexical-binding:t -*- ;; Copyright (C) 1989, 2001-2020 Free Software Foundation, Inc. @@ -162,7 +162,7 @@ Internal use only." "Recompute the list of dynamic libraries. Internal use only." (setq tabulated-list-format ; recomputed because column widths can change - (let ((max-id-len 0) (max-name-len 0)) + (let ((max-id-len 7) (max-name-len 11)) (dolist (lib dynamic-library-alist) (let ((id-len (length (symbol-name (car lib)))) (name-len (apply 'max (mapcar 'length (cdr lib))))) @@ -181,7 +181,9 @@ Internal use only." (push (list id (vector (symbol-name id) (list-dynamic-libraries--loaded from) (mapconcat 'identity (cdr lib) ", "))) - tabulated-list-entries))))) + tabulated-list-entries)))) + (when (not dynamic-library-alist) + (message "No dynamic libraries found"))) ;;;###autoload (defun list-dynamic-libraries (&optional loaded-only-p buffer) diff --git a/lisp/mouse.el b/lisp/mouse.el index e58a2e6da18..d369545f18e 100644 --- a/lisp/mouse.el +++ b/lisp/mouse.el @@ -49,7 +49,10 @@ "If non-nil, copy to kill-ring upon mouse adjustments of the region. This affects `mouse-save-then-kill' (\\[mouse-save-then-kill]) in -addition to mouse drags." +addition to mouse drags. + +This variable applies only to mouse adjustments in Emacs, not +selecting and adjusting regions in other windows." :type 'boolean :version "24.1") @@ -552,7 +555,7 @@ frame instead." (not (eq (window-frame minibuffer-window) frame)))) ;; Drag frame when the window is on the bottom of its frame and ;; there is no minibuffer window below. - (mouse-drag-frame start-event 'move))))) + (mouse-drag-frame-move start-event))))) (defun mouse-drag-header-line (start-event) "Change the height of a window by dragging on its header line. @@ -569,7 +572,7 @@ the frame instead." (mouse-drag-line start-event 'header) (let ((frame (window-frame window))) (when (frame-parameter frame 'drag-with-header-line) - (mouse-drag-frame start-event 'move)))))) + (mouse-drag-frame-move start-event)))))) (defun mouse-drag-vertical-line (start-event) "Change the width of a window by dragging on a vertical line. @@ -577,46 +580,137 @@ START-EVENT is the starting mouse event of the drag action." (interactive "e") (mouse-drag-line start-event 'vertical)) -(defun mouse-resize-frame (frame x-diff y-diff &optional x-move y-move) - "Helper function for `mouse-drag-frame'." - (let* ((frame-x-y (frame-position frame)) - (frame-x (car frame-x-y)) - (frame-y (cdr frame-x-y)) - alist) - (if (> x-diff 0) - (when x-move - (setq x-diff (min x-diff frame-x)) - (setq x-move (- frame-x x-diff))) - (let* ((min-width (frame-windows-min-size frame t nil t)) - (min-diff (max 0 (- (frame-inner-width frame) min-width)))) - (setq x-diff (max x-diff (- min-diff))) - (when x-move - (setq x-move (+ frame-x (- x-diff)))))) - - (if (> y-diff 0) - (when y-move - (setq y-diff (min y-diff frame-y)) - (setq y-move (- frame-y y-diff))) - (let* ((min-height (frame-windows-min-size frame nil nil t)) - (min-diff (max 0 (- (frame-inner-height frame) min-height)))) - (setq y-diff (max y-diff (- min-diff))) - (when y-move - (setq y-move (+ frame-y (- y-diff)))))) - - (unless (zerop x-diff) - (when x-move - (push `(left . ,x-move) alist)) - (push `(width . (text-pixels . ,(+ (frame-text-width frame) x-diff))) - alist)) - (unless (zerop y-diff) - (when y-move - (push `(top . ,y-move) alist)) - (push `(height . (text-pixels . ,(+ (frame-text-height frame) y-diff))) - alist)) - (when alist - (modify-frame-parameters frame alist)))) - -(defun mouse-drag-frame (start-event part) +(defun mouse-drag-frame-resize (start-event part) + "Drag a frame or one of its edges with the mouse. +START-EVENT is the starting mouse event of the drag action. Its +position window denotes the frame that will be dragged. + +PART specifies the part that has been dragged and must be one of +the symbols `left', `top', `right', `bottom', `top-left', +`top-right', `bottom-left', `bottom-right' to drag an internal +border or edge. If PART equals `move', this means to move the +frame with the mouse." + ;; Give temporary modes such as isearch a chance to turn off. + (run-hooks 'mouse-leave-buffer-hook) + (let* ((echo-keystrokes 0) + (start (event-start start-event)) + (window (posn-window start)) + ;; FRAME is the frame to drag. + (frame (if (window-live-p window) + (window-frame window) + window)) + ;; Initial "first" frame position and size. While dragging we + ;; base all calculations against that size and position. + (first-pos (frame-position frame)) + (first-left (car first-pos)) + (first-top (cdr first-pos)) + (first-width (frame-text-width frame)) + (first-height (frame-text-height frame)) + ;; Don't let FRAME become less large than the size needed to + ;; fit all of its windows. + (min-text-width + (+ (frame-windows-min-size frame t nil t) + (- (frame-inner-width frame) first-width))) + (min-text-height + (+ (frame-windows-min-size frame nil nil t) + (- (frame-inner-height frame) first-height))) + ;; PARENT is the parent frame of FRAME or, if FRAME is a + ;; top-level frame, FRAME's workarea. + (parent (frame-parent frame)) + (parent-edges + (if parent + (frame-edges parent) + (let* ((attributes + (car (display-monitor-attributes-list))) + (workarea (assq 'workarea attributes))) + (and workarea + `(,(nth 1 workarea) ,(nth 2 workarea) + ,(+ (nth 1 workarea) (nth 3 workarea)) + ,(+ (nth 2 workarea) (nth 4 workarea))))))) + (parent-left (and parent-edges (nth 0 parent-edges))) + (parent-top (and parent-edges (nth 1 parent-edges))) + (parent-right (and parent-edges (nth 2 parent-edges))) + (parent-bottom (and parent-edges (nth 3 parent-edges))) + ;; Drag types. drag-left/drag-right and drag-top/drag-bottom + ;; are mutually exclusive. + (drag-left (memq part '(bottom-left left top-left))) + (drag-top (memq part '(top-left top top-right))) + (drag-right (memq part '(top-right right bottom-right))) + (drag-bottom (memq part '(bottom-right bottom bottom-left))) + ;; Initial "first" mouse position. While dragging we base all + ;; calculations against that position. + (first-x-y (mouse-absolute-pixel-position)) + (first-x (car first-x-y)) + (first-y (cdr first-x-y)) + (exitfun nil) + (move + (lambda (event) + (interactive "e") + (when (consp event) + (let* ((last-x-y (mouse-absolute-pixel-position)) + (last-x (car last-x-y)) + (last-y (cdr last-x-y)) + (left (- last-x first-x)) + (top (- last-y first-y)) + alist) + ;; We never want to warp the mouse position here. When + ;; moving the mouse leftward or upward, then with a wide + ;; border the calculated left or top position of the + ;; frame could drop to a value less than zero depending + ;; on where precisely the mouse within the border. We + ;; guard against this by never allowing the frame to + ;; move to a position less than zero here. No such + ;; precautions are used for the right and bottom borders + ;; so with a large internal border parts of that border + ;; may disappear. + (when (and drag-left (>= last-x parent-left) + (>= (- first-width left) min-text-width)) + (push `(left . ,(max (+ first-left left) 0)) alist) + (push `(width . (text-pixels . ,(- first-width left))) + alist)) + (when (and drag-top (>= last-y parent-top) + (>= (- first-height top) min-text-height)) + (push `(top . ,(max 0 (+ first-top top))) alist) + (push `(height . (text-pixels . ,(- first-height top))) + alist)) + (when (and drag-right (<= last-x parent-right) + (>= (+ first-width left) min-text-width)) + (push `(width . (text-pixels . ,(+ first-width left))) + alist)) + (when (and drag-bottom (<= last-y parent-bottom) + (>= (+ first-height top) min-text-height)) + (push `(height . (text-pixels . ,(+ first-height top))) + alist)) + (modify-frame-parameters frame alist))))) + (old-track-mouse track-mouse)) + ;; Start tracking. The special value 'dragging' signals the + ;; display engine to freeze the mouse pointer shape for as long + ;; as we drag. + (setq track-mouse 'dragging) + ;; Loop reading events and sampling the position of the mouse. + (setq exitfun + (set-transient-map + (let ((map (make-sparse-keymap))) + (define-key map [switch-frame] #'ignore) + (define-key map [select-window] #'ignore) + (define-key map [scroll-bar-movement] #'ignore) + (define-key map [mouse-movement] move) + ;; Swallow drag-mouse-1 events to avoid selecting some other window. + (define-key map [drag-mouse-1] + (lambda () (interactive) (funcall exitfun))) + ;; Some of the events will of course end up looked up + ;; with a mode-line, header-line or vertical-line prefix ... + (define-key map [mode-line] map) + (define-key map [header-line] map) + (define-key map [vertical-line] map) + ;; ... and some maybe even with a right- or bottom-divider + ;; prefix. + (define-key map [right-divider] map) + (define-key map [bottom-divider] map) + map) + t (lambda () (setq track-mouse old-track-mouse)))))) + +(defun mouse-drag-frame-move (start-event) "Drag a frame or one of its edges with the mouse. START-EVENT is the starting mouse event of the drag action. Its position window denotes the frame that will be dragged. @@ -635,9 +729,14 @@ frame with the mouse." (frame (if (window-live-p window) (window-frame window) window)) - (width (frame-native-width frame)) - (height (frame-native-height frame)) - ;; PARENT is the parent frame of FRAME or, if FRAME is a + (native-width (frame-native-width frame)) + (native-height (frame-native-height frame)) + ;; Initial "first" frame position and size. While dragging we + ;; base all calculations against that size and position. + (first-pos (frame-position frame)) + (first-left (car first-pos)) + (first-top (cdr first-pos)) + ;; PARENT is the parent frame of FRAME or, if FRAME is a ;; top-level frame, FRAME's workarea. (parent (frame-parent frame)) (parent-edges @@ -654,19 +753,16 @@ frame with the mouse." (parent-top (and parent-edges (nth 1 parent-edges))) (parent-right (and parent-edges (nth 2 parent-edges))) (parent-bottom (and parent-edges (nth 3 parent-edges))) - ;; `pos-x' and `pos-y' record the x- and y-coordinates of the - ;; last sampled mouse position. Note that we sample absolute - ;; mouse positions to avoid that moving the mouse from one - ;; frame into another gets into our way. `last-x' and `last-y' - ;; records the x- and y-coordinates of the previously sampled - ;; position. The differences between `last-x' and `pos-x' as - ;; well as `last-y' and `pos-y' determine the amount the mouse - ;; has been dragged between the last two samples. - pos-x-y pos-x pos-y - (last-x-y (mouse-absolute-pixel-position)) - (last-x (car last-x-y)) - (last-y (cdr last-x-y)) - ;; `snap-x' and `snap-y' record the x- and y-coordinates of the + ;; Initial "first" mouse position. While dragging we base all + ;; calculations against that position. + (first-x-y (mouse-absolute-pixel-position)) + (first-x (car first-x-y)) + (first-y (cdr first-x-y)) + ;; `snap-width' (maybe also a yet to be provided `snap-height') + ;; could become floats to handle proportionality wrt PARENT. + ;; We don't do any checks on this parameter so far. + (snap-width (frame-parameter frame 'snap-width)) + ;; `snap-x' and `snap-y' record the x- and y-coordinates of the ;; mouse position when FRAME snapped. As soon as the ;; difference between `pos-x' and `snap-x' (or `pos-y' and ;; `snap-y') exceeds the value of FRAME's `snap-width' @@ -678,176 +774,141 @@ frame with the mouse." (lambda (event) (interactive "e") (when (consp event) - (setq pos-x-y (mouse-absolute-pixel-position)) - (setq pos-x (car pos-x-y)) - (setq pos-y (cdr pos-x-y)) - (cond - ((eq part 'left) - (mouse-resize-frame frame (- last-x pos-x) 0 t)) - ((eq part 'top) - (mouse-resize-frame frame 0 (- last-y pos-y) nil t)) - ((eq part 'right) - (mouse-resize-frame frame (- pos-x last-x) 0)) - ((eq part 'bottom) - (mouse-resize-frame frame 0 (- pos-y last-y))) - ((eq part 'top-left) - (mouse-resize-frame - frame (- last-x pos-x) (- last-y pos-y) t t)) - ((eq part 'top-right) - (mouse-resize-frame - frame (- pos-x last-x) (- last-y pos-y) nil t)) - ((eq part 'bottom-left) - (mouse-resize-frame - frame (- last-x pos-x) (- pos-y last-y) t)) - ((eq part 'bottom-right) - (mouse-resize-frame - frame (- pos-x last-x) (- pos-y last-y))) - ((eq part 'move) - (let* ((old-position (frame-position frame)) - (old-left (car old-position)) - (old-top (cdr old-position)) - (left (+ old-left (- pos-x last-x))) - (top (+ old-top (- pos-y last-y))) - right bottom - ;; `snap-width' (maybe also a yet to be provided - ;; `snap-height') could become floats to handle - ;; proportionality wrt PARENT. We don't do any - ;; checks on this parameter so far. - (snap-width (frame-parameter frame 'snap-width))) - ;; Docking and constraining. - (when (and (numberp snap-width) parent-edges) + (let* ((last-x-y (mouse-absolute-pixel-position)) + (last-x (car last-x-y)) + (last-y (cdr last-x-y)) + (left (- last-x first-x)) + (top (- last-y first-y)) + right bottom) + (setq left (+ first-left left)) + (setq top (+ first-top top)) + ;; Docking and constraining. + (when (and (numberp snap-width) parent-edges) + (cond + ;; Docking at the left parent edge. + ((< last-x first-x) (cond - ;; Docking at the left parent edge. - ((< pos-x last-x) - (cond - ((and (> left parent-left) - (<= (- left parent-left) snap-width)) - ;; Snap when the mouse moved leftward and - ;; FRAME's left edge would end up within - ;; `snap-width' pixels from PARENT's left edge. - (setq snap-x pos-x) - (setq left parent-left)) - ((and (<= left parent-left) - (<= (- parent-left left) snap-width) - snap-x (<= (- snap-x pos-x) snap-width)) - ;; Stay snapped when the mouse moved leftward - ;; but not more than `snap-width' pixels from - ;; the time FRAME snapped. - (setq left parent-left)) - (t - ;; Unsnap when the mouse moved more than - ;; `snap-width' pixels leftward from the time - ;; FRAME snapped. - (setq snap-x nil)))) - ((> pos-x last-x) - (setq right (+ left width)) - (cond - ((and (< right parent-right) - (<= (- parent-right right) snap-width)) - ;; Snap when the mouse moved rightward and - ;; FRAME's right edge would end up within - ;; `snap-width' pixels from PARENT's right edge. - (setq snap-x pos-x) - (setq left (- parent-right width))) - ((and (>= right parent-right) - (<= (- right parent-right) snap-width) - snap-x (<= (- pos-x snap-x) snap-width)) - ;; Stay snapped when the mouse moved rightward - ;; but not more more than `snap-width' pixels - ;; from the time FRAME snapped. - (setq left (- parent-right width))) - (t - ;; Unsnap when the mouse moved rightward more - ;; than `snap-width' pixels from the time FRAME - ;; snapped. - (setq snap-x nil))))) - + ((and (> left parent-left) + (<= (- left parent-left) snap-width)) + ;; Snap when the mouse moved leftward and FRAME's + ;; left edge would end up within `snap-width' + ;; pixels from PARENT's left edge. + (setq snap-x last-x) + (setq left parent-left)) + ((and (<= left parent-left) + (<= (- parent-left left) snap-width) + snap-x (<= (- snap-x last-x) snap-width)) + ;; Stay snapped when the mouse moved leftward but + ;; not more than `snap-width' pixels from the time + ;; FRAME snapped. + (setq left parent-left)) + (t + ;; Unsnap when the mouse moved more than + ;; `snap-width' pixels leftward from the time + ;; FRAME snapped. + (setq snap-x nil)))) + ((> last-x first-x) + (setq right (+ left native-width)) (cond - ((< pos-y last-y) - (cond - ((and (> top parent-top) - (<= (- top parent-top) snap-width)) - ;; Snap when the mouse moved upward and FRAME's - ;; top edge would end up within `snap-width' - ;; pixels from PARENT's top edge. - (setq snap-y pos-y) - (setq top parent-top)) - ((and (<= top parent-top) - (<= (- parent-top top) snap-width) - snap-y (<= (- snap-y pos-y) snap-width)) - ;; Stay snapped when the mouse moved upward but - ;; not more more than `snap-width' pixels from - ;; the time FRAME snapped. - (setq top parent-top)) - (t - ;; Unsnap when the mouse moved upward more than - ;; `snap-width' pixels from the time FRAME - ;; snapped. - (setq snap-y nil)))) - ((> pos-y last-y) - (setq bottom (+ top height)) - (cond - ((and (< bottom parent-bottom) - (<= (- parent-bottom bottom) snap-width)) - ;; Snap when the mouse moved downward and - ;; FRAME's bottom edge would end up within - ;; `snap-width' pixels from PARENT's bottom - ;; edge. - (setq snap-y pos-y) - (setq top (- parent-bottom height))) - ((and (>= bottom parent-bottom) - (<= (- bottom parent-bottom) snap-width) - snap-y (<= (- pos-y snap-y) snap-width)) - ;; Stay snapped when the mouse moved downward - ;; but not more more than `snap-width' pixels - ;; from the time FRAME snapped. - (setq top (- parent-bottom height))) - (t - ;; Unsnap when the mouse moved downward more - ;; than `snap-width' pixels from the time FRAME - ;; snapped. - (setq snap-y nil)))))) - - ;; If requested, constrain FRAME's draggable areas to - ;; PARENT's edges. The `top-visible' parameter should - ;; be set when FRAME has a draggable header-line. If - ;; set to a number, it ascertains that the top of - ;; FRAME is always constrained to the top of PARENT - ;; and that at least as many pixels of FRAME as - ;; specified by that number are visible on each of the - ;; three remaining sides of PARENT. - ;; - ;; The `bottom-visible' parameter should be set when - ;; FRAME has a draggable mode-line. If set to a - ;; number, it ascertains that the bottom of FRAME is - ;; always constrained to the bottom of PARENT and that - ;; at least as many pixels of FRAME as specified by - ;; that number are visible on each of the three - ;; remaining sides of PARENT. - (let ((par (frame-parameter frame 'top-visible)) - bottom-visible) - (unless par - (setq par (frame-parameter frame 'bottom-visible)) - (setq bottom-visible t)) - (when (and (numberp par) parent-edges) - (setq left - (max (min (- parent-right par) left) - (+ (- parent-left width) par))) - (setq top - (if bottom-visible - (min (max top (- parent-top (- height par))) - (- parent-bottom height)) - (min (max top parent-top) - (- parent-bottom par)))))) - - ;; Use `modify-frame-parameters' since `left' and - ;; `top' may want to move FRAME out of its PARENT. - (modify-frame-parameters - frame - `((left . (+ ,left)) (top . (+ ,top))))))) - (setq last-x pos-x) - (setq last-y pos-y)))) - (old-track-mouse track-mouse)) + ((and (< right parent-right) + (<= (- parent-right right) snap-width)) + ;; Snap when the mouse moved rightward and FRAME's + ;; right edge would end up within `snap-width' + ;; pixels from PARENT's right edge. + (setq snap-x last-x) + (setq left (- parent-right native-width))) + ((and (>= right parent-right) + (<= (- right parent-right) snap-width) + snap-x (<= (- last-x snap-x) snap-width)) + ;; Stay snapped when the mouse moved rightward but + ;; not more more than `snap-width' pixels from the + ;; time FRAME snapped. + (setq left (- parent-right native-width))) + (t + ;; Unsnap when the mouse moved rightward more than + ;; `snap-width' pixels from the time FRAME + ;; snapped. + (setq snap-x nil))))) + (cond + ((< last-y first-y) + (cond + ((and (> top parent-top) + (<= (- top parent-top) snap-width)) + ;; Snap when the mouse moved upward and FRAME's + ;; top edge would end up within `snap-width' + ;; pixels from PARENT's top edge. + (setq snap-y last-y) + (setq top parent-top)) + ((and (<= top parent-top) + (<= (- parent-top top) snap-width) + snap-y (<= (- snap-y last-y) snap-width)) + ;; Stay snapped when the mouse moved upward but + ;; not more more than `snap-width' pixels from the + ;; time FRAME snapped. + (setq top parent-top)) + (t + ;; Unsnap when the mouse moved upward more than + ;; `snap-width' pixels from the time FRAME + ;; snapped. + (setq snap-y nil)))) + ((> last-y first-y) + (setq bottom (+ top native-height)) + (cond + ((and (< bottom parent-bottom) + (<= (- parent-bottom bottom) snap-width)) + ;; Snap when the mouse moved downward and FRAME's + ;; bottom edge would end up within `snap-width' + ;; pixels from PARENT's bottom edge. + (setq snap-y last-y) + (setq top (- parent-bottom native-height))) + ((and (>= bottom parent-bottom) + (<= (- bottom parent-bottom) snap-width) + snap-y (<= (- last-y snap-y) snap-width)) + ;; Stay snapped when the mouse moved downward but + ;; not more more than `snap-width' pixels from the + ;; time FRAME snapped. + (setq top (- parent-bottom native-height))) + (t + ;; Unsnap when the mouse moved downward more than + ;; `snap-width' pixels from the time FRAME + ;; snapped. + (setq snap-y nil)))))) + + ;; If requested, constrain FRAME's draggable areas to + ;; PARENT's edges. The `top-visible' parameter should + ;; be set when FRAME has a draggable header-line. If + ;; set to a number, it ascertains that the top of FRAME + ;; is always constrained to the top of PARENT and that + ;; at least as many pixels of FRAME as specified by that + ;; number are visible on each of the three remaining + ;; sides of PARENT. + ;; + ;; The `bottom-visible' parameter should be set when + ;; FRAME has a draggable mode-line. If set to a number, + ;; it ascertains that the bottom of FRAME is always + ;; constrained to the bottom of PARENT and that at least + ;; as many pixels of FRAME as specified by that number + ;; are visible on each of the three remaining sides of + ;; PARENT. + (let ((par (frame-parameter frame 'top-visible)) + bottom-visible) + (unless par + (setq par (frame-parameter frame 'bottom-visible)) + (setq bottom-visible t)) + (when (and (numberp par) parent-edges) + (setq left + (max (min (- parent-right par) left) + (+ (- parent-left native-width) par))) + (setq top + (if bottom-visible + (min (max top (- parent-top (- native-height par))) + (- parent-bottom native-height)) + (min (max top parent-top) + (- parent-bottom par)))))) + ;; Use `modify-frame-parameters' since `left' and `top' + ;; may want to move FRAME out of its PARENT. + (modify-frame-parameters frame `((left . (+ ,left)) (top . (+ ,top)))))))) + (old-track-mouse track-mouse)) ;; Start tracking. The special value 'dragging' signals the ;; display engine to freeze the mouse pointer shape for as long ;; as we drag. @@ -879,49 +940,49 @@ frame with the mouse." "Drag left edge of a frame with the mouse. START-EVENT is the starting mouse event of the drag action." (interactive "e") - (mouse-drag-frame start-event 'left)) + (mouse-drag-frame-resize start-event 'left)) (defun mouse-drag-top-left-corner (start-event) "Drag top left corner of a frame with the mouse. START-EVENT is the starting mouse event of the drag action." (interactive "e") - (mouse-drag-frame start-event 'top-left)) + (mouse-drag-frame-resize start-event 'top-left)) (defun mouse-drag-top-edge (start-event) "Drag top edge of a frame with the mouse. START-EVENT is the starting mouse event of the drag action." (interactive "e") - (mouse-drag-frame start-event 'top)) + (mouse-drag-frame-resize start-event 'top)) (defun mouse-drag-top-right-corner (start-event) "Drag top right corner of a frame with the mouse. START-EVENT is the starting mouse event of the drag action." (interactive "e") - (mouse-drag-frame start-event 'top-right)) + (mouse-drag-frame-resize start-event 'top-right)) (defun mouse-drag-right-edge (start-event) "Drag right edge of a frame with the mouse. START-EVENT is the starting mouse event of the drag action." (interactive "e") - (mouse-drag-frame start-event 'right)) + (mouse-drag-frame-resize start-event 'right)) (defun mouse-drag-bottom-right-corner (start-event) "Drag bottom right corner of a frame with the mouse. START-EVENT is the starting mouse event of the drag action." (interactive "e") - (mouse-drag-frame start-event 'bottom-right)) + (mouse-drag-frame-resize start-event 'bottom-right)) (defun mouse-drag-bottom-edge (start-event) "Drag bottom edge of a frame with the mouse. START-EVENT is the starting mouse event of the drag action." (interactive "e") - (mouse-drag-frame start-event 'bottom)) + (mouse-drag-frame-resize start-event 'bottom)) (defun mouse-drag-bottom-left-corner (start-event) "Drag bottom left corner of a frame with the mouse. START-EVENT is the starting mouse event of the drag action." (interactive "e") - (mouse-drag-frame start-event 'bottom-left)) + (mouse-drag-frame-resize start-event 'bottom-left)) (defcustom mouse-select-region-move-to-beginning nil "Effect of selecting a region extending backward from double click. @@ -2498,7 +2559,7 @@ region, text is copied instead of being cut." (lambda (modifier) `(const :tag ,(format "Enable, but copy with the %s modifier" modifier) - modifier)) + ,modifier)) '(alt super hyper shift control meta)) (other :tag "Enable dragging the region" t)) :version "26.1") @@ -2517,9 +2578,12 @@ as it does when dropping text in the source buffer." If this option is nil, `mouse-drag-and-drop-region' does not show tooltips. If this is t, it shows the entire text dragged in a tooltip. If this is an integer (as with the default value of -256), it will show that many characters of the dragged text in -a tooltip." - :type 'integer +256), it will show up to that many characters of the dragged text +in a tooltip." + :type '(choice + (const :tag "Do not show tooltips" nil) + (const :tag "Show all text" t) + (integer :tag "Max number of characters to show" 256)) :version "26.1") (defcustom mouse-drag-and-drop-region-show-cursor t @@ -2553,6 +2617,7 @@ is copied instead of being cut." (let* ((mouse-button (event-basic-type last-input-event)) (mouse-drag-and-drop-region-show-tooltip (when (and mouse-drag-and-drop-region-show-tooltip + (> mouse-drag-and-drop-region-show-tooltip 0) (display-multi-frame-p) (require 'tooltip)) mouse-drag-and-drop-region-show-tooltip)) 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 92ed98b2a89..0cb8d7cb837 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." @@ -4169,8 +4169,7 @@ directory, so that Emacs will know its current contents." (if (file-directory-p file) (ange-ftp-delete-directory file recursive trash) (delete-file file trash))) - ;; We do not want to delete "." and "..". - (directory-files dir 'full (rx (or (not ".") "..."))))) + (directory-files dir 'full directory-files-no-dot-files-regexp))) (if parsed (let* ((host (nth 0 parsed)) (user (nth 1 parsed)) @@ -4739,7 +4738,8 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") (setq ange-ftp-ls-cache-file nil) ;Stop confusing Dired. 0) -(defun ange-ftp-set-file-modes (filename mode) +(defun ange-ftp-set-file-modes (filename mode &optional flag) + flag ;; FIXME: Support 'nofollow'. (ange-ftp-call-chmod (list (format "%o" mode) filename))) (defun ange-ftp-make-symbolic-link (&rest _arguments) diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index 25aabf6d61d..2b8d4d0ce62 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -1,4 +1,4 @@ -;;; browse-url.el --- pass a URL to a WWW browser +;;; browse-url.el --- pass a URL to a WWW browser -*- lexical-binding: t; -*- ;; Copyright (C) 1995-2020 Free Software Foundation, Inc. @@ -39,7 +39,6 @@ ;; browse-url-chrome Chrome 47.0.2526.111 ;; browse-url-chromium Chromium 3.0 ;; browse-url-epiphany Epiphany Don't know -;; browse-url-conkeror Conkeror Don't know ;; browse-url-w3 w3 0 ;; browse-url-text-* Any text browser 0 ;; browse-url-generic arbitrary @@ -114,9 +113,23 @@ ;; To always save modified buffers before displaying the file in a browser: ;; (setq browse-url-save-file t) -;; To invoke different browsers for different URLs: -;; (setq browse-url-browser-function '(("^mailto:" . browse-url-mail) -;; ("." . browse-url-firefox))) +;; To invoke different browsers/tools for different URLs, customize +;; `browse-url-handlers'. In earlier versions of Emacs, the same +;; could be done by setting `browse-url-browser-function' to an alist +;; but this usage is deprecated now. + +;; All browser functions provided by here have a +;; `browse-url-browser-kind' symbol property set to either `internal' +;; or `external' which determines if they browse the given URL inside +;; Emacs or spawn an external application with it. Some parts of +;; Emacs make use of that, e.g., when an URL is dragged into Emacs, it +;; is not sensible to invoke an external browser with it, so here only +;; internal browsers are considered. Therefore, it is advised to put +;; that property also on custom browser functions. +;; (function-put 'my-browse-url-in-emacs 'browse-url-browser-kind +;; 'internal) +;; (function-put 'my-browse-url-externally 'browse-url-browser-kind +;; 'external) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Code: @@ -140,7 +153,6 @@ (function-item :tag "Google Chrome" :value browse-url-chrome) (function-item :tag "Chromium" :value browse-url-chromium) (function-item :tag "Epiphany" :value browse-url-epiphany) - (function-item :tag "Conkeror" :value browse-url-conkeror) (function-item :tag "Text browser in an xterm window" :value browse-url-text-xterm) (function-item :tag "Text browser in an Emacs window" @@ -157,7 +169,9 @@ :value browse-url-default-browser) (function :tag "Your own function") (alist :tag "Regexp/function association list" - :key-type regexp :value-type function))) + :key-type regexp :value-type function + :format "%{%t%}\n%d%v\n" + :doc "Deprecated. Use `browse-url-handlers' instead."))) ;;;###autoload (defcustom browse-url-browser-function 'browse-url-default-browser @@ -165,13 +179,8 @@ This is used by the `browse-url-at-point', `browse-url-at-mouse', and `browse-url-of-file' commands. -If the value is not a function it should be a list of pairs -\(REGEXP . FUNCTION). In this case the function called will be the one -associated with the first REGEXP which matches the current URL. The -function is passed the URL and any other args of `browse-url'. The last -regexp should probably be \".\" to specify a default browser. - -Also see `browse-url-secondary-browser-function'." +Also see `browse-url-secondary-browser-function' and +`browse-url-handlers'." :type browse-url--browser-defcustom-type :version "24.1") @@ -216,7 +225,7 @@ be used instead." "\\(?:" ;; Match paired parentheses, e.g. in Wikipedia URLs: ;; http://thread.gmane.org/47B4E3B2.3050402@gmail.com - "[" chars punct "]+" "(" "[" chars punct "]+" "[" chars "]*)" + "[" chars punct "]+" "(" "[" chars punct "]+" ")" "\\(?:" "[" chars punct "]+" "[" chars "]" "\\)?" "\\|" "[" chars punct "]+" "[" chars "]" @@ -385,6 +394,8 @@ If non-nil, then open the URL in a new buffer rather than a new window if :version "25.1" :type 'boolean) +(make-obsolete-variable 'browse-url-conkeror-new-window-is-buffer nil "28.1") + (defcustom browse-url-galeon-new-window-is-tab nil "Whether to open up new windows in a tab or a new window. If non-nil, then open the URL in a new tab rather than a new window if @@ -414,35 +425,20 @@ Passing an interactive argument to \\[browse-url], or specific browser commands reverses the effect of this variable." :type 'boolean) -(defcustom browse-url-mosaic-program "xmosaic" - "The name by which to invoke Mosaic (or mMosaic)." - :type 'string - :version "20.3") - -(make-obsolete-variable 'browse-url-mosaic-program nil "25.1") - -(defcustom browse-url-mosaic-arguments nil - "A list of strings to pass to Mosaic as arguments." - :type '(repeat (string :tag "Argument"))) - -(make-obsolete-variable 'browse-url-mosaic-arguments nil "25.1") - -(defcustom browse-url-mosaic-pidfile "~/.mosaicpid" - "The name of the pidfile created by Mosaic." - :type 'string) - -(make-obsolete-variable 'browse-url-mosaic-pidfile nil "25.1") - (defcustom browse-url-conkeror-program "conkeror" "The name by which to invoke Conkeror." :type 'string :version "25.1") +(make-obsolete-variable 'browse-url-conkeror-program nil "28.1") + (defcustom browse-url-conkeror-arguments nil "A list of strings to pass to Conkeror as arguments." :version "25.1" :type '(repeat (string :tag "Argument"))) +(make-obsolete-variable 'browse-url-conkeror-arguments nil "28.1") + (defcustom browse-url-filename-alist `(("^/\\(ftp@\\|anonymous@\\)?\\([^:/]+\\):/*" . "ftp://\\2/") ;; The above loses the username to avoid the browser prompting for @@ -483,22 +479,6 @@ Used by the `browse-url-of-file' command." "Hook run after `browse-url-of-file' has asked a browser to load a file." :type 'hook) -(defcustom browse-url-CCI-port 3003 - "Port to access XMosaic via CCI. -This can be any number between 1024 and 65535 but must correspond to -the value set in the browser." - :type 'integer) - -(make-obsolete-variable 'browse-url-CCI-port nil "25.1") - -(defcustom browse-url-CCI-host "localhost" - "Host to access XMosaic via CCI. -This should be the host name of the machine running XMosaic with CCI -enabled. The port number should be set in `browse-url-CCI-port'." - :type 'string) - -(make-obsolete-variable 'browse-url-CCI-host nil "25.1") - (defvar browse-url-temp-file-name nil) (make-variable-buffer-local 'browse-url-temp-file-name) @@ -595,6 +575,116 @@ down (this *won't* always work)." "Wrapper command prepended to the Elinks command-line." :type '(repeat (string :tag "Wrapper"))) +(defun browse-url--browser-kind (function url) + "Return the browser kind of a browser FUNCTION for URL. +The browser kind is either `internal' (the browser runs inside +Emacs), `external' (the browser is spawned in an external +process), or nil (we don't know)." + (let ((kind (if (symbolp function) + (get function 'browse-url-browser-kind)))) + (if (functionp kind) + (funcall kind url) + kind))) + +(defun browse-url--mailto (url &rest args) + "Call `browse-url-mailto-function' with URL and ARGS." + (funcall browse-url-mailto-function url args)) + +(defun browse-url--browser-kind-mailto (url) + (browse-url--browser-kind browse-url-mailto-function url)) +(function-put 'browse-url--mailto 'browse-url-browser-kind + #'browse-url--browser-kind-mailto) + +(defun browse-url--man (url &rest args) + "Call `browse-url-man-function' with URL and ARGS." + (funcall browse-url-man-function url args)) + +(defun browse-url--browser-kind-man (url) + (browse-url--browser-kind browse-url-man-function url)) +(function-put 'browse-url--man 'browse-url-browser-kind + #'browse-url--browser-kind-man) + +(defun browse-url--browser (url &rest args) + "Call `browse-url-browser-function' with URL and ARGS." + (funcall browse-url-browser-function url args)) + +(defun browse-url--browser-kind-browser (url) + (browse-url--browser-kind browse-url-browser-function url)) +(function-put 'browse-url--browser 'browse-url-browser-kind + #'browse-url--browser-kind-browser) + +(defun browse-url--non-html-file-url-p (url) + "Return non-nil if URL is a file:// URL of a non-HTML file." + (and (string-match-p "\\`file://" url) + (not (string-match-p "\\`file://.*\\.html?\\b" url)))) + +;;;###autoload +(defvar browse-url-default-handlers + '(("\\`mailto:" . browse-url--mailto) + ("\\`man:" . browse-url--man) + (browse-url--non-html-file-url-p . browse-url-emacs)) + "Like `browse-url-handlers' but populated by Emacs and packages. + +Emacs and external packages capable of browsing certain URLs +should place their entries in this alist rather than +`browse-url-handlers' which is reserved for the user.") + +(defcustom browse-url-handlers nil + "An alist with elements of the form (REGEXP-OR-PREDICATE . HANDLER). +Each REGEXP-OR-PREDICATE is matched against the URL to be opened +in turn and the first match's HANDLER is invoked with the URL. + +A HANDLER must be a function with the same arguments as +`browse-url'. + +If no REGEXP-OR-PREDICATE matches, the same procedure is +performed with the value of `browse-url-default-handlers'. If +there is also no match, the URL is opened using the value of +`browse-url-browser-function'." + :type '(alist :key-type (choice + (regexp :tag "Regexp") + (function :tag "Predicate")) + :value-type (function :tag "Handler")) + :version "28.1") + +;;;###autoload +(defun browse-url-select-handler (url &optional kind) + "Return a handler of suitable for browsing URL. +This searches `browse-url-handlers', and +`browse-url-default-handlers' for a matching handler. Return nil +if no handler is found. + +If KIND is given, the search is restricted to handlers whose +function symbol has the symbol-property `browse-url-browser-kind' +set to KIND. + +Currently, it also consults `browse-url-browser-function' first +if it is set to an alist, although this usage is deprecated since +Emacs 28.1 and will be removed in a future release." + (catch 'custom-url-handler + (dolist (rxpred-handler + (append + ;; The alist choice of browse-url-browser-function + ;; is deprecated since 28.1, so the (unless ...) + ;; can be removed at some point in time. + (when (and (consp browse-url-browser-function) + (not (functionp browse-url-browser-function))) + (lwarn 'browse-url :warning + "Having `browse-url-browser-function' set to an +alist is deprecated. Use `browse-url-handlers' instead.") + browse-url-browser-function) + browse-url-handlers + browse-url-default-handlers)) + (let ((rx-or-pred (car rxpred-handler)) + (handler (cdr rxpred-handler))) + (when (and (or (null kind) + (eq kind (browse-url--browser-kind + handler url))) + (if (functionp rx-or-pred) + (funcall rx-or-pred url) + (string-match-p rx-or-pred url))) + (throw 'custom-url-handler handler)))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; URL encoding @@ -729,8 +819,8 @@ narrowed." (browse-url-of-file file-name)))) (defun browse-url-delete-temp-file (&optional temp-file-name) - ;; Delete browse-url-temp-file-name from the file system - ;; If optional arg TEMP-FILE-NAME is non-nil, delete it instead + "Delete `browse-url-temp-file-name' from the file system. +If optional arg TEMP-FILE-NAME is non-nil, delete it instead." (let ((file-name (or temp-file-name browse-url-temp-file-name))) (if (and file-name (file-exists-p file-name)) (delete-file file-name)))) @@ -768,16 +858,18 @@ narrowed." "Ask a WWW browser to load URL. Prompt for a URL, defaulting to the URL at or before point. Invokes a suitable browser function which does the actual job. -The variable `browse-url-browser-function' says which browser function to -use. If the URL is a mailto: URL, consult `browse-url-mailto-function' -first, if that exists. - -The additional ARGS are passed to the browser function. See the doc -strings of the actual functions, starting with `browse-url-browser-function', -for information about the significance of ARGS (most of the functions -ignore it). -If ARGS are omitted, the default is to pass `browse-url-new-window-flag' -as ARGS." + +The variables `browse-url-browser-function', +`browse-url-handlers', and `browse-url-default-handlers' +determine which browser function to use. + +The additional ARGS are passed to the browser function. See the +doc strings of the actual functions, starting with +`browse-url-browser-function', for information about the +significance of ARGS (most of the functions ignore it). + +If ARGS are omitted, the default is to pass +`browse-url-new-window-flag' as ARGS." (interactive (browse-url-interactive-arg "URL: ")) (unless (called-interactively-p 'interactive) (setq args (or args (list browse-url-new-window-flag)))) @@ -786,12 +878,9 @@ as ARGS." (not (string-match "\\`[a-z]+:" url))) (setq url (expand-file-name url))) (let ((process-environment (copy-sequence process-environment)) - (function (or (and (string-match "\\`mailto:" url) - browse-url-mailto-function) - (and (string-match "\\`man:" url) - browse-url-man-function) - browse-url-browser-function)) - ;; Ensure that `default-directory' exists and is readable (b#6077). + (function (or (browse-url-select-handler url) + browse-url-browser-function)) + ;; Ensure that `default-directory' exists and is readable (bug#6077). (default-directory (or (unhandled-file-name-directory default-directory) (expand-file-name "~/")))) ;; When connected to various displays, be careful to use the display of @@ -799,20 +888,9 @@ as ARGS." ;; which may not even exist any more. (if (stringp (frame-parameter nil 'display)) (setenv "DISPLAY" (frame-parameter nil 'display))) - (if (and (consp function) - (not (functionp function))) - ;; The `function' can be an alist; look down it for first match - ;; and apply the function (which might be a lambda). - (catch 'done - (dolist (bf function) - (when (string-match (car bf) url) - (apply (cdr bf) url args) - (throw 'done t))) - (error "No browse-url-browser-function matching URL %s" - url)) - ;; Unbound symbols go down this leg, since void-function from - ;; apply is clearer than wrong-type-argument from dolist. - (apply function url args)))) + (if (functionp function) + (apply function url args) + (error "No suitable browser for URL %s" url)))) ;;;###autoload (defun browse-url-at-point (&optional arg) @@ -829,6 +907,34 @@ Optional prefix argument ARG non-nil inverts the value of the option (error "No URL found")))) ;;;###autoload +(defun browse-url-with-browser-kind (kind url &optional arg) + "Browse URL with a browser of the given browser KIND. +KIND is either `internal' or `external'. + +When called interactively, the default browser kind is the +opposite of the browser kind of `browse-url-browser-function'." + (interactive + (let* ((url-arg (browse-url-interactive-arg "URL: ")) + ;; Default to the inverse kind of the default browser. + (default (if (eq (browse-url--browser-kind + browse-url-browser-function (car url-arg)) + 'internal) + 'external + 'internal)) + (k (intern (completing-read + (format "Browser kind (default %s): " default) + '(internal external) + nil t nil nil + default)))) + (cons k url-arg))) + (let ((function (browse-url-select-handler url kind))) + (unless function + (setq function (if (eq kind 'external) + #'browse-url-default-browser + #'eww))) + (funcall function url arg))) + +;;;###autoload (defun browse-url-at-mouse (event) "Ask a WWW browser to load a URL clicked with the mouse. The URL is the one around or before the position of the mouse click @@ -875,12 +981,18 @@ The optional NEW-WINDOW argument is not used." (url-unhex-string url) url))))) +(function-put 'browse-url-default-windows-browser 'browse-url-browser-kind + 'external) + (defun browse-url-default-macosx-browser (url &optional _new-window) "Invoke the macOS system's default Web browser. The optional NEW-WINDOW argument is not used." (interactive (browse-url-interactive-arg "URL: ")) (start-process (concat "open " url) nil "open" url)) +(function-put 'browse-url-default-macosx-browser 'browse-url-browser-kind + 'external) + ;; --- Netscape --- (defun browse-url-process-environment () @@ -928,8 +1040,6 @@ instead of `browse-url-new-window-flag'." ;;; ((executable-find browse-url-galeon-program) 'browse-url-galeon) ((executable-find browse-url-kde-program) 'browse-url-kde) ;;; ((executable-find browse-url-netscape-program) 'browse-url-netscape) -;;; ((executable-find browse-url-mosaic-program) 'browse-url-mosaic) - ((executable-find browse-url-conkeror-program) 'browse-url-conkeror) ((executable-find browse-url-chrome-program) 'browse-url-chrome) ((executable-find browse-url-xterm-program) 'browse-url-text-xterm) ((locate-library "w3") 'browse-url-w3) @@ -937,6 +1047,10 @@ instead of `browse-url-new-window-flag'." (lambda (&rest _ignore) (error "No usable browser found")))) url args)) +(function-put 'browse-url-default-browser 'browse-url-browser-kind + ;; Well, most probably external if we ignore w3. + 'external) + (defun browse-url-can-use-xdg-open () "Return non-nil if the \"xdg-open\" program can be used. xdg-open is a desktop utility that calls your preferred web browser." @@ -956,6 +1070,8 @@ The optional argument IGNORED is not used." (interactive (browse-url-interactive-arg "URL: ")) (call-process "xdg-open" nil 0 nil url)) +(function-put 'browse-url-xdg-open 'browse-url-browser-kind 'external) + ;;;###autoload (defun browse-url-netscape (url &optional new-window) "Ask the Netscape WWW browser to load URL. @@ -999,6 +1115,8 @@ used instead of `browse-url-new-window-flag'." `(lambda (process change) (browse-url-netscape-sentinel process ,url))))) +(function-put 'browse-url-netscape 'browse-url-browser-kind 'external) + (defun browse-url-netscape-sentinel (process url) "Handle a change to the process communicating with Netscape." (declare (obsolete nil "25.1")) @@ -1069,6 +1187,8 @@ used instead of `browse-url-new-window-flag'." `(lambda (process change) (browse-url-mozilla-sentinel process ,url))))) +(function-put 'browse-url-mozilla 'browse-url-browser-kind 'external) + (defun browse-url-mozilla-sentinel (process url) "Handle a change to the process communicating with Mozilla." (or (eq (process-exit-status process) 0) @@ -1109,6 +1229,8 @@ instead of `browse-url-new-window-flag'." '("-new-window"))) (list url))))) +(function-put 'browse-url-firefox 'browse-url-browser-kind 'external) + ;;;###autoload (defun browse-url-chromium (url &optional _new-window) "Ask the Chromium WWW browser to load URL. @@ -1126,6 +1248,8 @@ The optional argument NEW-WINDOW is not used." browse-url-chromium-arguments (list url))))) +(function-put 'browse-url-chromium 'browse-url-browser-kind 'external) + (defun browse-url-chrome (url &optional _new-window) "Ask the Google Chrome WWW browser to load URL. Default to the URL around or before point. The strings in @@ -1142,6 +1266,8 @@ The optional argument NEW-WINDOW is not used." browse-url-chrome-arguments (list url))))) +(function-put 'browse-url-chrome 'browse-url-browser-kind 'external) + ;;;###autoload (defun browse-url-galeon (url &optional new-window) "Ask the Galeon WWW browser to load URL. @@ -1179,6 +1305,8 @@ used instead of `browse-url-new-window-flag'." `(lambda (process change) (browse-url-galeon-sentinel process ,url))))) +(function-put 'browse-url-galeon 'browse-url-browser-kind 'external) + (defun browse-url-galeon-sentinel (process url) "Handle a change to the process communicating with Galeon." (declare (obsolete nil "25.1")) @@ -1225,6 +1353,8 @@ used instead of `browse-url-new-window-flag'." `(lambda (process change) (browse-url-epiphany-sentinel process ,url))))) +(function-put 'browse-url-epiphany 'browse-url-browser-kind 'external) + (defun browse-url-epiphany-sentinel (process url) "Handle a change to the process communicating with Epiphany." (or (eq (process-exit-status process) 0) @@ -1249,6 +1379,8 @@ currently selected window instead." file-name-handler-alist))) (if same-window (find-file url) (find-file-other-window url)))) +(function-put 'browse-url-emacs 'browse-url-browser-kind 'internal) + ;;;###autoload (defun browse-url-gnome-moz (url &optional new-window) "Ask Mozilla/Netscape to load URL via the GNOME program `gnome-moz-remote'. @@ -1273,88 +1405,7 @@ used instead of `browse-url-new-window-flag'." '("--newwin")) (list "--raise" url)))) -;; --- Mosaic --- - -;;;###autoload -(defun browse-url-mosaic (url &optional new-window) - "Ask the XMosaic WWW browser to load URL. - -Default to the URL around or before point. The strings in variable -`browse-url-mosaic-arguments' are also passed to Mosaic and the -program is invoked according to the variable -`browse-url-mosaic-program'. - -When called interactively, if variable `browse-url-new-window-flag' is -non-nil, load the document in a new Mosaic window, otherwise use a -random existing one. A non-nil interactive prefix argument reverses -the effect of `browse-url-new-window-flag'. - -When called non-interactively, optional second argument NEW-WINDOW is -used instead of `browse-url-new-window-flag'." - (declare (obsolete nil "25.1")) - (interactive (browse-url-interactive-arg "Mosaic URL: ")) - (let ((pidfile (expand-file-name browse-url-mosaic-pidfile)) - pid) - (if (file-readable-p pidfile) - (with-temp-buffer - (insert-file-contents pidfile) - (setq pid (read (current-buffer))))) - (if (and (integerp pid) (zerop (signal-process pid 0))) ; Mosaic running - (progn - (with-temp-buffer - (insert (if (browse-url-maybe-new-window new-window) - "newwin\n" - "goto\n") - url "\n") - (with-file-modes ?\700 - (if (file-exists-p - (setq pidfile (format "/tmp/Mosaic.%d" pid))) - (delete-file pidfile)) - ;; https://debbugs.gnu.org/17428. Use O_EXCL. - (write-region nil nil pidfile nil 'silent nil 'excl))) - ;; Send signal SIGUSR to Mosaic - (message "Signaling Mosaic...") - (signal-process pid 'SIGUSR1) - ;; Or you could try: - ;; (call-process "kill" nil 0 nil "-USR1" (int-to-string pid)) - (message "Signaling Mosaic...done")) - ;; Mosaic not running - start it - (message "Starting %s..." browse-url-mosaic-program) - (apply 'start-process "xmosaic" nil browse-url-mosaic-program - (append browse-url-mosaic-arguments (list url))) - (message "Starting %s...done" browse-url-mosaic-program)))) - -;; --- Mosaic using CCI --- - -;;;###autoload -(defun browse-url-cci (url &optional new-window) - "Ask the XMosaic WWW browser to load URL. -Default to the URL around or before point. - -This function only works for XMosaic version 2.5 or later. You must -select `CCI' from XMosaic's File menu, set the CCI Port Address to the -value of variable `browse-url-CCI-port', and enable `Accept requests'. - -When called interactively, if variable `browse-url-new-window-flag' is -non-nil, load the document in a new browser window, otherwise use a -random existing one. A non-nil interactive prefix argument reverses -the effect of `browse-url-new-window-flag'. - -When called non-interactively, optional second argument NEW-WINDOW is -used instead of `browse-url-new-window-flag'." - (declare (obsolete nil "25.1")) - (interactive (browse-url-interactive-arg "Mosaic URL: ")) - (open-network-stream "browse-url" " *browse-url*" - browse-url-CCI-host browse-url-CCI-port) - ;; Todo: start browser if fails - (process-send-string "browse-url" - (concat "get url (" url ") output " - (if (browse-url-maybe-new-window new-window) - "new" - "current") - "\r\n")) - (process-send-string "browse-url" "disconnect\r\n") - (delete-process "browse-url")) +(function-put 'browse-url-gnome-moz 'browse-url-browser-kind 'external) ;; --- Conkeror --- ;;;###autoload @@ -1375,6 +1426,7 @@ new window, load it in a new buffer in an existing window instead. When called non-interactively, use optional second argument NEW-WINDOW instead of `browse-url-new-window-flag'." + (declare (obsolete nil "28.1")) (interactive (browse-url-interactive-arg "URL: ")) (setq url (browse-url-encode-url url)) (let* ((process-environment (browse-url-process-environment))) @@ -1392,6 +1444,9 @@ NEW-WINDOW instead of `browse-url-new-window-flag'." "window") "buffer") url)))))) + +(function-put 'browse-url-conkeror 'browse-url-browser-kind 'external) + ;; --- W3 --- ;; External. @@ -1415,6 +1470,8 @@ used instead of `browse-url-new-window-flag'." (w3-fetch-other-window url) (w3-fetch url))) +(function-put 'browse-url-w3 'browse-url-browser-kind 'internal) + ;;;###autoload (defun browse-url-w3-gnudoit (url &optional _new-window) ;; new-window ignored @@ -1429,6 +1486,8 @@ The `browse-url-gnudoit-program' program is used with options given by (list (concat "(w3-fetch \"" url "\")") "(raise-frame)")))) +(function-put 'browse-url-w3-gnudoit 'browse-url-browser-kind 'internal) + ;; --- Lynx in an xterm --- ;;;###autoload @@ -1446,6 +1505,8 @@ The optional argument NEW-WINDOW is not used." ,@browse-url-xterm-args "-e" ,browse-url-text-browser ,url))) +(function-put 'browse-url-text-xterm 'browse-url-browser-kind 'external) + ;; --- Lynx in an Emacs "term" window --- (declare-function term-char-mode "term" ()) @@ -1520,6 +1581,8 @@ used instead of `browse-url-new-window-flag'." url "\r"))))) +(function-put 'browse-url-text-emacs 'browse-url-browser-kind 'internal) + ;; --- mailto --- (autoload 'rfc2368-parse-mailto-url "rfc2368") @@ -1567,6 +1630,8 @@ used instead of `browse-url-new-window-flag'." (unless (bolp) (insert "\n")))))))) +(function-put 'browse-url-mail 'browse-url-browser-kind 'internal) + ;; --- man --- (defvar manual-program) @@ -1578,7 +1643,9 @@ used instead of `browse-url-new-window-flag'." (setq url (replace-regexp-in-string "\\`man:" "" url)) (cond ((executable-find manual-program) (man url)) - (t (woman (replace-regexp-in-string "([[:alnum:]]+)" "" url))))) + (t (woman (replace-regexp-in-string "([[:alnum:]]+)" "" url))))) + +(function-put 'browse-url-man 'browse-url-browser-kind 'internal) ;; --- Random browser --- @@ -1597,6 +1664,8 @@ don't offer a form of remote control." 0 nil (append browse-url-generic-args (list url)))) +(function-put 'browse-url-generic 'browse-url-browser-kind 'external) + ;;;###autoload (defun browse-url-kde (url &optional _new-window) "Ask the KDE WWW browser to load URL. @@ -1607,6 +1676,8 @@ The optional argument NEW-WINDOW is not used." (apply #'start-process (concat "KDE " url) nil browse-url-kde-program (append browse-url-kde-args (list url)))) +(function-put 'browse-url-kde 'browse-url-browser-kind 'external) + (defun browse-url-elinks-new-window (url) "Ask the Elinks WWW browser to load URL in a new window." (let ((process-environment (browse-url-process-environment))) @@ -1616,6 +1687,9 @@ The optional argument NEW-WINDOW is not used." browse-url-elinks-wrapper (list "elinks" url))))) +(function-put 'browse-url-elinks-new-window 'browse-url-browser-kind + 'external) + ;;;###autoload (defun browse-url-elinks (url &optional new-window) "Ask the Elinks WWW browser to load URL. @@ -1637,6 +1711,8 @@ from `browse-url-elinks-wrapper'." `(lambda (process change) (browse-url-elinks-sentinel process ,url)))))) +(function-put 'browse-url-elinks 'browse-url-browser-kind 'external) + (defun browse-url-elinks-sentinel (process url) "Determines if Elinks is running or a new one has to be started." ;; Try to determine if an instance is running or if we have to diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index 06bd9e567fe..fdd726ff613 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -51,9 +51,6 @@ (unless (boundp 'dbus-debug) (defvar dbus-debug nil)) -;; Pacify byte compiler. -(eval-when-compile (require 'cl-lib)) - (require 'xml) (defconst dbus-service-dbus "org.freedesktop.DBus" @@ -169,10 +166,7 @@ Otherwise, return result of last form in BODY, or all other errors." `(condition-case err (progn ,@body) (dbus-error (when dbus-debug (signal (car err) (cdr err)))))) -(font-lock-add-keywords 'emacs-lisp-mode '("\\<dbus-ignore-errors\\>")) -(define-obsolete-variable-alias 'dbus-event-error-hooks - 'dbus-event-error-functions "24.3") (defvar dbus-event-error-functions '(dbus-notice-synchronous-call-errors) "Functions to be called when a D-Bus error happens in the event handler. Every function must accept two arguments, the event and the error variable @@ -181,7 +175,7 @@ caught in `condition-case' by `dbus-error'.") ;;; Basic D-Bus message functions. -(defvar dbus-return-values-table (make-hash-table :test 'equal) +(defvar dbus-return-values-table (make-hash-table :test #'equal) "Hash table for temporarily storing arguments of reply messages. A key in this hash table is a list (:serial BUS SERIAL), like in `dbus-registered-objects-table'. BUS is either a Lisp symbol, @@ -301,8 +295,8 @@ object is returned instead of a list containing this single Lisp object. (check-interval 0.001) (key (apply - 'dbus-message-internal dbus-message-type-method-call - bus service path interface method 'dbus-call-method-handler args)) + #'dbus-message-internal dbus-message-type-method-call + bus service path interface method #'dbus-call-method-handler args)) (result (cons :pending nil))) ;; Wait until `dbus-call-method-handler' has put the result into @@ -338,10 +332,6 @@ object is returned instead of a list containing this single Lisp object. (cdr result)) (remhash key dbus-return-values-table)))) -;; `dbus-call-method' works non-blocking now. -(defalias 'dbus-call-method-non-blocking 'dbus-call-method) -(make-obsolete 'dbus-call-method-non-blocking 'dbus-call-method "24.3") - (defun dbus-call-method-asynchronously (bus service path interface method handler &rest args) "Call METHOD on the D-Bus BUS asynchronously. @@ -406,7 +396,7 @@ Example: (or (null handler) (functionp handler) (signal 'wrong-type-argument (list 'functionp handler))) - (apply 'dbus-message-internal dbus-message-type-method-call + (apply #'dbus-message-internal dbus-message-type-method-call bus service path interface method handler args)) (defun dbus-send-signal (bus service path interface signal &rest args) @@ -454,7 +444,7 @@ Example: (or (stringp signal) (signal 'wrong-type-argument (list 'stringp signal))) - (apply 'dbus-message-internal dbus-message-type-signal + (apply #'dbus-message-internal dbus-message-type-signal bus service path interface signal args)) (defun dbus-method-return-internal (bus service serial &rest args) @@ -470,7 +460,7 @@ This is an internal function, it shall not be used outside dbus.el." (or (natnump serial) (signal 'wrong-type-argument (list 'natnump serial))) - (apply 'dbus-message-internal dbus-message-type-method-return + (apply #'dbus-message-internal dbus-message-type-method-return bus service serial args)) (defun dbus-method-error-internal (bus service serial &rest args) @@ -486,7 +476,7 @@ This is an internal function, it shall not be used outside dbus.el." (or (natnump serial) (signal 'wrong-type-argument (list 'natnump serial))) - (apply 'dbus-message-internal dbus-message-type-error + (apply #'dbus-message-internal dbus-message-type-error bus service serial args)) @@ -552,13 +542,13 @@ placed in the queue. `:already-owner': Service is already the primary owner." ;; Add Peer handler. - (dbus-register-method - bus service nil dbus-interface-peer "Ping" 'dbus-peer-handler 'dont-register) + (dbus-register-method bus service nil dbus-interface-peer "Ping" + #'dbus-peer-handler 'dont-register) ;; Add ObjectManager handler. (dbus-register-method bus service nil dbus-interface-objectmanager "GetManagedObjects" - 'dbus-managed-objects-handler 'dont-register) + #'dbus-managed-objects-handler 'dont-register) (let ((arg 0) reply) @@ -681,7 +671,7 @@ Example: (if (and (stringp service) (not (zerop (length service))) (not (string-equal service dbus-service-dbus)) - (not (string-match "^:" service))) + (/= (string-to-char service) ?:)) (setq uname (dbus-get-name-owner bus service)) (setq uname service)) @@ -710,7 +700,7 @@ Example: ;; `:arg0' .. `:arg63', `:path0' .. `:path63'. ((and (keywordp key) (string-match - "^:\\(arg\\|path\\)\\([[:digit:]]+\\)$" + "\\`:\\(arg\\|path\\)\\([[:digit:]]+\\)\\'" (symbol-name key))) (setq counter (match-string 2 (symbol-name key)) args (cdr args) @@ -726,9 +716,7 @@ Example: "path" "") value)) ;; `:arg-namespace', `:path-namespace'. - ((and (keywordp key) - (string-match - "^:\\(arg\\|path\\)-namespace$" (symbol-name key))) + ((memq key '(:arg-namespace :path-namespace)) (setq args (cdr args) value (car args)) (unless (stringp value) @@ -736,8 +724,7 @@ Example: (list "Wrong argument" key value))) (format ",%s='%s'" - (if (string-equal (match-string 1 (symbol-name key)) "path") - "path_namespace" "arg0namespace") + (if (eq key :path-namespace) "path_namespace" "arg0namespace") value)) ;; `:eavesdrop'. ((eq key :eavesdrop) @@ -751,11 +738,11 @@ Example: bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus "AddMatch" rule) (dbus-error - (if (not (string-match "eavesdrop" rule)) + (if (not (string-match-p "eavesdrop" rule)) (signal (car err) (cdr err)) ;; The D-Bus spec says we shall fall back to a rule without eavesdrop. (when dbus-debug (message "Removing eavesdrop from rule %s" rule)) - (setq rule (replace-regexp-in-string ",eavesdrop='true'" "" rule)) + (setq rule (replace-regexp-in-string ",eavesdrop='true'" "" rule t t)) (dbus-call-method bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus "AddMatch" rule)))) @@ -893,9 +880,7 @@ association to the service from D-Bus." STRING shall be UTF-8 coded." (if (zerop (length string)) '(:array :signature "y") - (let (result) - (dolist (elt (string-to-list string) (append '(:array) result)) - (setq result (append result (list :byte elt))))))) + (cons :array (mapcan (lambda (c) (list :byte c)) string)))) (defun dbus-byte-array-to-string (byte-array &optional multibyte) "Transform BYTE-ARRAY into UTF-8 coded string. @@ -903,12 +888,9 @@ BYTE-ARRAY must be a list of structure (c1 c2 ...), or a byte array as produced by `dbus-string-to-byte-array'. The resulting string is unibyte encoded, unless MULTIBYTE is non-nil." (apply - (if multibyte 'string 'unibyte-string) - (if (equal byte-array '(:array :signature "y")) - nil - (let (result) - (dolist (elt byte-array result) - (when (characterp elt) (setq result (append result `(,elt))))))))) + (if multibyte #'string #'unibyte-string) + (unless (equal byte-array '(:array :signature "y")) + (seq-filter #'characterp byte-array)))) (defun dbus-escape-as-identifier (string) "Escape an arbitrary STRING so it follows the rules for a C identifier. @@ -930,9 +912,9 @@ telepathy-glib's `tp_escape_as_identifier'." (if (zerop (length string)) "_" (replace-regexp-in-string - "^[0-9]\\|[^A-Za-z0-9]" + "\\`[0-9]\\|[^A-Za-z0-9]" (lambda (x) (format "_%2x" (aref x 0))) - string))) + string nil t))) (defun dbus-unescape-from-identifier (string) "Retrieve the original string from the encoded STRING as unibyte string. @@ -942,7 +924,7 @@ STRING must have been encoded with `dbus-escape-as-identifier'." (replace-regexp-in-string "_.." (lambda (x) (byte-to-string (string-to-number (substring x 1) 16))) - string))) + string nil t))) ;;; D-Bus events. @@ -1020,7 +1002,7 @@ If the HANDLER returns a `dbus-error', it is propagated as return message." (if (eq result :ignore) (dbus-method-return-internal (nth 1 event) (nth 4 event) (nth 3 event)) - (apply 'dbus-method-return-internal + (apply #'dbus-method-return-internal (nth 1 event) (nth 4 event) (nth 3 event) (if (consp result) result (list result))))))) ;; Error handling. @@ -1119,10 +1101,9 @@ unique names for services." (defun dbus-list-known-names (bus) "Retrieve all services which correspond to a known name in BUS. A service has a known name if it doesn't start with \":\"." - (let (result) - (dolist (name (dbus-list-names bus) (nreverse result)) - (unless (string-equal ":" (substring name 0 1)) - (push name result))))) + (seq-remove (lambda (name) + (= (string-to-char name) ?:)) + (dbus-list-names bus))) (defun dbus-list-queued-owners (bus service) "Return the unique names registered at D-Bus BUS and queued for SERVICE. @@ -1182,6 +1163,18 @@ It will be registered for all objects created by `dbus-register-service'." ;;; D-Bus introspection. +(defsubst dbus--introspect-names (object tag) + "Return the names of the children of OBJECT with TAG." + (mapcar (lambda (elt) + (dbus-introspect-get-attribute elt "name")) + (xml-get-children object tag))) + +(defsubst dbus--introspect-name (object tag name) + "Return the first child of OBJECT with TAG, whose name is NAME." + (seq-find (lambda (elt) + (string-equal (dbus-introspect-get-attribute elt "name") name)) + (xml-get-children object tag))) + (defun dbus-introspect (bus service path) "Return all interfaces and sub-nodes of SERVICE, registered at object path PATH at bus BUS. @@ -1197,17 +1190,25 @@ XML format." bus service path dbus-interface-introspectable "Introspect" :timeout 1000))) +(defalias 'dbus--parse-xml-buffer + (if (libxml-available-p) + (lambda () + (xml-remove-comments (point-min) (point-max)) + (libxml-parse-xml-region (point-min) (point-max))) + (lambda () + (car (xml-parse-region (point-min) (point-max))))) + "Compatibility shim for `libxml-parse-xml-region'.") + (defun dbus-introspect-xml (bus service path) "Return the introspection data of SERVICE in D-Bus BUS at object path PATH. The data are a parsed list. The root object is a \"node\", representing the object path PATH. The root object can contain \"interface\" and further \"node\" objects." - ;; We don't want to raise errors. - (xml-node-name - (ignore-errors - (with-temp-buffer - (insert (dbus-introspect bus service path)) - (xml-parse-region (point-min) (point-max)))))) + (with-temp-buffer + ;; We don't want to raise errors. + (ignore-errors + (insert (dbus-introspect bus service path)) + (dbus--parse-xml-buffer)))) (defun dbus-introspect-get-attribute (object attribute) "Return the ATTRIBUTE value of D-Bus introspection OBJECT. @@ -1219,21 +1220,15 @@ the D-Bus specification." "Return all node names of SERVICE in D-Bus BUS at object path PATH. It returns a list of strings. The node names stand for further object paths of the D-Bus service." - (let ((object (dbus-introspect-xml bus service path)) - result) - (dolist (elt (xml-get-children object 'node) (nreverse result)) - (push (dbus-introspect-get-attribute elt "name") result)))) + (dbus--introspect-names (dbus-introspect-xml bus service path) 'node)) (defun dbus-introspect-get-all-nodes (bus service path) "Return all node names of SERVICE in D-Bus BUS at object path PATH. It returns a list of strings, which are further object paths of SERVICE." - (let ((result (list path))) - (dolist (elt - (dbus-introspect-get-node-names bus service path) - result) - (setq elt (expand-file-name elt path)) - (setq result - (append result (dbus-introspect-get-all-nodes bus service elt)))))) + (cons path (mapcan (lambda (elt) + (setq elt (expand-file-name elt path)) + (dbus-introspect-get-all-nodes bus service elt)) + (dbus-introspect-get-node-names bus service path)))) (defun dbus-introspect-get-interface-names (bus service path) "Return all interface names of SERVICE in D-Bus BUS at object path PATH. @@ -1244,10 +1239,7 @@ always present. Another default interface is \"org.freedesktop.DBus.Properties\". If present, \"interface\" objects can also have \"property\" objects as children, beside \"method\" and \"signal\" objects." - (let ((object (dbus-introspect-xml bus service path)) - result) - (dolist (elt (xml-get-children object 'interface) (nreverse result)) - (push (dbus-introspect-get-attribute elt "name") result)))) + (dbus--introspect-names (dbus-introspect-xml bus service path) 'interface)) (defun dbus-introspect-get-interface (bus service path interface) "Return the INTERFACE of SERVICE in D-Bus BUS at object path PATH. @@ -1256,22 +1248,14 @@ and a member of the list returned by `dbus-introspect-get-interface-names'. The resulting \"interface\" object can contain \"method\", \"signal\", \"property\" and \"annotation\" children." - (let ((elt (xml-get-children - (dbus-introspect-xml bus service path) 'interface))) - (while (and elt - (not (string-equal - interface - (dbus-introspect-get-attribute (car elt) "name")))) - (setq elt (cdr elt))) - (car elt))) + (dbus--introspect-name (dbus-introspect-xml bus service path) + 'interface interface)) (defun dbus-introspect-get-method-names (bus service path interface) "Return a list of strings of all method names of INTERFACE. SERVICE is a service of D-Bus BUS at object path PATH." - (let ((object (dbus-introspect-get-interface bus service path interface)) - result) - (dolist (elt (xml-get-children object 'method) (nreverse result)) - (push (dbus-introspect-get-attribute elt "name") result)))) + (dbus--introspect-names + (dbus-introspect-get-interface bus service path interface) 'method)) (defun dbus-introspect-get-method (bus service path interface method) "Return method METHOD of interface INTERFACE as an XML object. @@ -1279,22 +1263,15 @@ It must be located at SERVICE in D-Bus BUS at object path PATH. METHOD must be a string and a member of the list returned by `dbus-introspect-get-method-names'. The resulting \"method\" object can contain \"arg\" and \"annotation\" children." - (let ((elt (xml-get-children - (dbus-introspect-get-interface bus service path interface) - 'method))) - (while (and elt - (not (string-equal - method (dbus-introspect-get-attribute (car elt) "name")))) - (setq elt (cdr elt))) - (car elt))) + (dbus--introspect-name + (dbus-introspect-get-interface bus service path interface) + 'method method)) (defun dbus-introspect-get-signal-names (bus service path interface) "Return a list of strings of all signal names of INTERFACE. SERVICE is a service of D-Bus BUS at object path PATH." - (let ((object (dbus-introspect-get-interface bus service path interface)) - result) - (dolist (elt (xml-get-children object 'signal) (nreverse result)) - (push (dbus-introspect-get-attribute elt "name") result)))) + (dbus--introspect-names + (dbus-introspect-get-interface bus service path interface) 'signal)) (defun dbus-introspect-get-signal (bus service path interface signal) "Return signal SIGNAL of interface INTERFACE as an XML object. @@ -1302,22 +1279,15 @@ It must be located at SERVICE in D-Bus BUS at object path PATH. SIGNAL must be a string, element of the list returned by `dbus-introspect-get-signal-names'. The resulting \"signal\" object can contain \"arg\" and \"annotation\" children." - (let ((elt (xml-get-children - (dbus-introspect-get-interface bus service path interface) - 'signal))) - (while (and elt - (not (string-equal - signal (dbus-introspect-get-attribute (car elt) "name")))) - (setq elt (cdr elt))) - (car elt))) + (dbus--introspect-name + (dbus-introspect-get-interface bus service path interface) + 'signal signal)) (defun dbus-introspect-get-property-names (bus service path interface) "Return a list of strings of all property names of INTERFACE. SERVICE is a service of D-Bus BUS at object path PATH." - (let ((object (dbus-introspect-get-interface bus service path interface)) - result) - (dolist (elt (xml-get-children object 'property) (nreverse result)) - (push (dbus-introspect-get-attribute elt "name") result)))) + (dbus--introspect-names + (dbus-introspect-get-interface bus service path interface) 'property)) (defun dbus-introspect-get-property (bus service path interface property) "Return PROPERTY of INTERFACE as an XML object. @@ -1325,15 +1295,9 @@ It must be located at SERVICE in D-Bus BUS at object path PATH. PROPERTY must be a string and a member of the list returned by `dbus-introspect-get-property-names'. The resulting PROPERTY object can contain \"annotation\" children." - (let ((elt (xml-get-children - (dbus-introspect-get-interface bus service path interface) - 'property))) - (while (and elt - (not (string-equal - property - (dbus-introspect-get-attribute (car elt) "name")))) - (setq elt (cdr elt))) - (car elt))) + (dbus--introspect-name + (dbus-introspect-get-interface bus service path interface) + 'property property)) (defun dbus-introspect-get-annotation-names (bus service path interface &optional name) @@ -1341,15 +1305,13 @@ object can contain \"annotation\" children." If NAME is nil, the annotations are children of INTERFACE, otherwise NAME must be a \"method\", \"signal\", or \"property\" object, where the annotations belong to." - (let ((object - (if name - (or (dbus-introspect-get-method bus service path interface name) - (dbus-introspect-get-signal bus service path interface name) - (dbus-introspect-get-property bus service path interface name)) - (dbus-introspect-get-interface bus service path interface))) - result) - (dolist (elt (xml-get-children object 'annotation) (nreverse result)) - (push (dbus-introspect-get-attribute elt "name") result)))) + (dbus--introspect-names + (if name + (or (dbus-introspect-get-method bus service path interface name) + (dbus-introspect-get-signal bus service path interface name) + (dbus-introspect-get-property bus service path interface name)) + (dbus-introspect-get-interface bus service path interface)) + 'annotation)) (defun dbus-introspect-get-annotation (bus service path interface name annotation) @@ -1357,22 +1319,13 @@ object, where the annotations belong to." If NAME is nil, ANNOTATION is a child of INTERFACE, otherwise NAME must be the name of a \"method\", \"signal\", or \"property\" object, where the ANNOTATION belongs to." - (let ((elt (xml-get-children - (if name - (or (dbus-introspect-get-method - bus service path interface name) - (dbus-introspect-get-signal - bus service path interface name) - (dbus-introspect-get-property - bus service path interface name)) - (dbus-introspect-get-interface bus service path interface)) - 'annotation))) - (while (and elt - (not (string-equal - annotation - (dbus-introspect-get-attribute (car elt) "name")))) - (setq elt (cdr elt))) - (car elt))) + (dbus--introspect-name + (if name + (or (dbus-introspect-get-method bus service path interface name) + (dbus-introspect-get-signal bus service path interface name) + (dbus-introspect-get-property bus service path interface name)) + (dbus-introspect-get-interface bus service path interface)) + 'annotation annotation)) (defun dbus-introspect-get-argument-names (bus service path interface name) "Return a list of all argument names as a list of strings. @@ -1380,27 +1333,20 @@ NAME must be a \"method\" or \"signal\" object. Argument names are optional, the function can return nil therefore, even if the method or signal has arguments." - (let ((object - (or (dbus-introspect-get-method bus service path interface name) - (dbus-introspect-get-signal bus service path interface name))) - result) - (dolist (elt (xml-get-children object 'arg) (nreverse result)) - (push (dbus-introspect-get-attribute elt "name") result)))) + (dbus--introspect-names + (or (dbus-introspect-get-method bus service path interface name) + (dbus-introspect-get-signal bus service path interface name)) + 'arg)) (defun dbus-introspect-get-argument (bus service path interface name arg) "Return argument ARG as XML object. NAME must be a \"method\" or \"signal\" object. ARG must be a string and a member of the list returned by `dbus-introspect-get-argument-names'." - (let ((elt (xml-get-children - (or (dbus-introspect-get-method bus service path interface name) - (dbus-introspect-get-signal bus service path interface name)) - 'arg))) - (while (and elt - (not (string-equal - arg (dbus-introspect-get-attribute (car elt) "name")))) - (setq elt (cdr elt))) - (car elt))) + (dbus--introspect-name + (or (dbus-introspect-get-method bus service path interface name) + (dbus-introspect-get-signal bus service path interface name)) + 'arg arg)) (defun dbus-introspect-get-signature (bus service path interface name &optional direction) @@ -1469,13 +1415,10 @@ name of the property, and its value. If there are no properties, nil is returned." (dbus-ignore-errors ;; "GetAll" returns "a{sv}". - (let (result) - (dolist (dict - (dbus-call-method - bus service path dbus-interface-properties - "GetAll" :timeout 500 interface) - (nreverse result)) - (push (cons (car dict) (cl-caadr dict)) result))))) + (mapcar (lambda (dict) + (cons (car dict) (caadr dict))) + (dbus-call-method bus service path dbus-interface-properties + "GetAll" :timeout 500 interface)))) (defun dbus-register-property (bus service path interface property access value @@ -1520,13 +1463,13 @@ clients from discovering the still incomplete interface." ;; Add handlers for the three property-related methods. (dbus-register-method bus service path dbus-interface-properties "Get" - 'dbus-property-handler 'dont-register) + #'dbus-property-handler 'dont-register) (dbus-register-method bus service path dbus-interface-properties "GetAll" - 'dbus-property-handler 'dont-register) + #'dbus-property-handler 'dont-register) (dbus-register-method bus service path dbus-interface-properties "Set" - 'dbus-property-handler 'dont-register) + #'dbus-property-handler 'dont-register) ;; Register SERVICE. (unless (or dont-register-service (member service (dbus-list-names bus))) @@ -1673,7 +1616,7 @@ and \"org.freedesktop.DBus.Properties.GetAll\", which is slow." (if (cadr entry2) ;; "sv". (dolist (entry3 (cadr entry2)) - (setcdr entry3 (cl-caadr entry3))) + (setcdr entry3 (caadr entry3))) (setcdr entry2 nil))))) ;; Fallback: collect the information. Slooow! @@ -1730,7 +1673,7 @@ It will be registered for all objects created by `dbus-register-service'." (append (butlast last-input-event 4) (list object dbus-interface-properties - "GetAll" 'dbus-property-handler)))) + "GetAll" #'dbus-property-handler)))) (dbus-property-handler interface)))) (cdr (assoc object result))))))))) dbus-registered-objects-table) diff --git a/lisp/net/dig.el b/lisp/net/dig.el index 852d8ae0491..f36999119f2 100644 --- a/lisp/net/dig.el +++ b/lisp/net/dig.el @@ -1,4 +1,4 @@ -;;; dig.el --- Domain Name System dig interface +;;; dig.el --- Domain Name System dig interface -*- lexical-binding:t -*- ;; Copyright (C) 2000-2020 Free Software Foundation, Inc. @@ -42,15 +42,13 @@ (defcustom dig-program "dig" "Name of dig (domain information groper) binary." - :type 'file - :group 'dig) + :type 'file) (defcustom dig-dns-server nil "DNS server to query. If nil, use system defaults." :type '(choice (const :tag "System defaults") - string) - :group 'dig) + string)) (defcustom dig-font-lock-keywords '(("^;; [A-Z]+ SECTION:" 0 font-lock-keyword-face) @@ -58,8 +56,7 @@ If nil, use system defaults." ("^; <<>>.*" 0 font-lock-type-face) ("^;.*" 0 font-lock-function-name-face)) "Default expressions to highlight in dig mode." - :type 'sexp - :group 'dig) + :type 'sexp) (defun dig-invoke (domain &optional query-type query-class query-option diff --git a/lisp/net/dns.el b/lisp/net/dns.el index cefe0851f03..c368cd773c2 100644 --- a/lisp/net/dns.el +++ b/lisp/net/dns.el @@ -1,4 +1,4 @@ -;;; dns.el --- Domain Name Service lookups +;;; dns.el --- Domain Name Service lookups -*- lexical-binding:t -*- ;; Copyright (C) 2002-2020 Free Software Foundation, Inc. @@ -24,6 +24,8 @@ ;;; Code: +(require 'cl-lib) + (defvar dns-timeout 5 "How many seconds to wait when doing DNS queries.") @@ -73,7 +75,7 @@ updated. Set this variable to t to disable the check.") (defun dns-write-bytes (value &optional length) (let (bytes) - (dotimes (i (or length 1)) + (dotimes (_ (or length 1)) (push (% value 256) bytes) (setq value (/ value 256))) (dolist (byte bytes) @@ -81,7 +83,7 @@ updated. Set this variable to t to disable the check.") (defun dns-read-bytes (length) (let ((value 0)) - (dotimes (i length) + (dotimes (_ length) (setq value (logior (* value 256) (following-char))) (forward-char 1)) value)) @@ -138,7 +140,7 @@ updated. Set this variable to t to disable the check.") (defun dns-write (spec &optional tcp-p) "Write a DNS packet according to SPEC. -If TCP-P, the first two bytes of the package with be the length field." +If TCP-P, the first two bytes of the packet will be the length field." (with-temp-buffer (set-buffer-multibyte nil) (dns-write-bytes (dns-get 'id spec) 2) @@ -189,13 +191,15 @@ If TCP-P, the first two bytes of the package with be the length field." (dns-write-bytes (buffer-size) 2)) (buffer-string))) -(defun dns-read (packet) +(defun dns-read (packet &optional tcp-p) (with-temp-buffer (set-buffer-multibyte nil) (let ((spec nil) queries answers authorities additionals) (insert packet) - (goto-char (point-min)) + ;; When using TCP we have a 2 byte length field to ignore. + (goto-char (+ (point-min) + (if tcp-p 2 0))) (push (list 'id (dns-read-bytes 2)) spec) (let ((byte (dns-read-bytes 1))) (push (list 'response-p (if (zerop (logand byte (ash 1 7))) nil t)) @@ -227,7 +231,7 @@ If TCP-P, the first two bytes of the package with be the length field." (setq authorities (dns-read-bytes 2)) (setq additionals (dns-read-bytes 2)) (let ((qs nil)) - (dotimes (i queries) + (dotimes (_ queries) (push (list (dns-read-name) (list 'type (dns-inverse-get (dns-read-bytes 2) dns-query-types)) @@ -235,33 +239,36 @@ If TCP-P, the first two bytes of the package with be the length field." dns-classes))) qs)) (push (list 'queries qs) spec)) - (dolist (slot '(answers authorities additionals)) - (let ((qs nil) - type) - (dotimes (i (symbol-value slot)) - (push (list (dns-read-name) - (list 'type - (setq type (dns-inverse-get (dns-read-bytes 2) - dns-query-types))) - (list 'class (dns-inverse-get (dns-read-bytes 2) - dns-classes)) - (list 'ttl (dns-read-bytes 4)) - (let ((length (dns-read-bytes 2))) - (list 'data - (dns-read-type - (buffer-substring - (point) - (progn (forward-char length) (point))) - type)))) - qs)) - (push (list slot qs) spec))) + (cl-loop for (slot length) in `((answers ,answers) + (authorities ,authorities) + (additionals ,additionals)) + do (let ((qs nil) + type) + (dotimes (_ length) + (push (list (dns-read-name) + (list 'type + (setq type (dns-inverse-get + (dns-read-bytes 2) + dns-query-types))) + (list 'class (dns-inverse-get + (dns-read-bytes 2) + dns-classes)) + (list 'ttl (dns-read-bytes 4)) + (let ((length (dns-read-bytes 2))) + (list 'data + (dns-read-type + (buffer-substring + (point) + (progn (forward-char length) + (point))) + type)))) + qs)) + (push (list slot qs) spec))) (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)) @@ -274,23 +281,23 @@ If TCP-P, the first two bytes of the package with be the length field." (cond ((eq type 'A) (let ((bytes nil)) - (dotimes (i 4) + (dotimes (_ 4) (push (dns-read-bytes 1) bytes)) (mapconcat 'number-to-string (nreverse bytes) "."))) ((eq type 'AAAA) (let (hextets) - (dotimes (i 8) + (dotimes (_ 8) (push (dns-read-bytes 2) hextets)) (mapconcat (lambda (n) (format "%x" n)) (nreverse hextets) ":"))) ((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)) @@ -309,16 +316,14 @@ If TCP-P, the first two bytes of the package with be the length field." "Return false if we need to recheck the list of DNS servers." (and dns-servers (or (eq dns-servers-valid-for-interfaces t) - ;; `network-interface-list' was introduced in Emacs 22.1. - (not (fboundp 'network-interface-list)) (equal dns-servers-valid-for-interfaces (network-interface-list))))) (defun dns-set-servers () "Set `dns-servers' to a list of DNS servers or nil if none are found. Parses \"/etc/resolv.conf\" or calls \"nslookup\"." + (setq dns-servers nil) (or (when (file-exists-p "/etc/resolv.conf") - (setq dns-servers nil) (with-temp-buffer (insert-file-contents "/etc/resolv.conf") (goto-char (point-min)) @@ -329,11 +334,10 @@ Parses \"/etc/resolv.conf\" or calls \"nslookup\"." (with-temp-buffer (call-process "nslookup" nil t nil "localhost") (goto-char (point-min)) - (re-search-forward - "^Address:[ \t]*\\([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\\)" nil t) - (setq dns-servers (list (match-string 1)))))) - (when (fboundp 'network-interface-list) - (setq dns-servers-valid-for-interfaces (network-interface-list)))) + (when (re-search-forward + "^Address:[ \t]*\\([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\\|[[:xdigit:]:]*\\)" nil t) + (setq dns-servers (list (match-string 1))))))) + (setq dns-servers-valid-for-interfaces (network-interface-list))) (defun dns-read-txt (string) (if (> (length string) 1) @@ -355,23 +359,6 @@ Parses \"/etc/resolv.conf\" or calls \"nslookup\"." result)) ;;; Interface functions. -(defmacro dns-make-network-process (server) - `(let ((server ,server) - (coding-system-for-read 'binary) - (coding-system-for-write 'binary)) - (if (fboundp 'make-network-process) - (make-network-process - :name "dns" - :coding 'binary - :buffer (current-buffer) - :host server - :service "domain" - :type 'datagram) - ;; Older versions of Emacs doesn't have - ;; `make-network-process', so we fall back on opening a TCP - ;; connection to the DNS server. - (open-network-stream "dns" (current-buffer) server "domain")))) - (defvar dns-cache (make-vector 4096 0)) (defun dns-query-cached (name &optional type fullp reversep) @@ -384,64 +371,141 @@ Parses \"/etc/resolv.conf\" or calls \"nslookup\"." (set (intern key dns-cache) result) result)))) -;; The old names `query-dns' and `query-dns-cached' weren't used in Emacs 23 -;; yet, so no alias are provided. --rsteib - -(defun dns-query (name &optional type fullp reversep) +(defun dns-query-asynchronous (name callback &optional type full reverse) "Query a DNS server for NAME of TYPE. -If FULLP, return the entire record returned. -If REVERSEP, look up an IP address." +CALLBACK will be called with a single parameter: The result. + +If there's no result, or `dns-timeout' has passed, CALLBACK will +be called with nil as the parameter. + +If FULL, return the entire record. +If REVERSE, look up an IP address." (setq type (or type 'A)) (unless (dns-servers-up-to-date-p) (dns-set-servers)) - (when reversep + (when reverse (setq name (concat (mapconcat 'identity (nreverse (split-string name "\\.")) ".") ".in-addr.arpa") type 'PTR)) (if (not dns-servers) - (message "No DNS server configuration found") - (with-temp-buffer - (set-buffer-multibyte nil) - (let ((process (condition-case () - (dns-make-network-process (car dns-servers)) - (error - (message - "dns: Got an error while trying to talk to %s" - (car dns-servers)) - nil))) - (step 100) - (times (* dns-timeout 1000)) - (id (random 65000))) - (when process - (process-send-string - process - (dns-write `((id ,id) - (opcode query) - (queries ((,name (type ,type)))) - (recursion-desired-p t)))) - (while (and (zerop (buffer-size)) - (> times 0)) - (let ((step-sec (/ step 1000.0))) - (sit-for step-sec) - (accept-process-output process step-sec)) - (setq times (- times step))) - (condition-case nil - (delete-process process) - (error nil)) - (when (and (>= (buffer-size) 2) - ;; We had a time-out. - (> times 0)) - (let ((result (dns-read (buffer-string)))) - (if fullp - result - (let ((answer (car (dns-get 'answers result)))) - (when (eq type (dns-get 'type answer)) - (if (eq type 'TXT) - (dns-get-txt-answer (dns-get 'answers result)) - (dns-get 'data answer)))))))))))) + (progn + (message "No DNS server configuration found") + nil) + (dns--lookup name callback type full))) + +(defun dns--lookup (name callback type full) + (with-current-buffer (generate-new-buffer " *dns*") + (set-buffer-multibyte nil) + (let* ((tcp nil) + (process + (condition-case () + (let ((server (car dns-servers)) + (coding-system-for-read 'binary) + (coding-system-for-write 'binary)) + (if (featurep 'make-network-process '(:type datagram)) + (make-network-process + :name "dns" + :coding 'binary + :buffer (current-buffer) + :host server + :service "domain" + :type 'datagram) + ;; On MS-Windows datagram sockets are not + ;; supported, so we fall back on opening a TCP + ;; connection to the DNS server. + (progn + (setq tcp t) + (open-network-stream "dns" (current-buffer) + server "domain")))) + (error + (message + "dns: Got an error while trying to talk to %s" + (car dns-servers)) + nil))) + (triggered nil) + (buffer (current-buffer)) + timer) + (if (not process) + (progn + (kill-buffer buffer) + (funcall callback nil)) + ;; Call the callback if we don't get any response at all. + (setq timer (run-at-time dns-timeout nil + (lambda () + (unless triggered + (setq triggered t) + (delete-process process) + (kill-buffer buffer) + (funcall callback nil))))) + (process-send-string + process + (dns-write `((id ,(random 65000)) + (opcode query) + (queries ((,name (type ,type)))) + (recursion-desired-p t)) + tcp)) + (set-process-filter + process + (lambda (process string) + (with-current-buffer (process-buffer process) + (goto-char (point-max)) + (insert string) + (goto-char (point-min)) + ;; If this is DNS, then we always get the full data in + ;; one packet. If it's TCP, we may only get part of the + ;; data, but the first two bytes says how long the data + ;; is supposed to be. + (when (or (not tcp) + (>= (buffer-size) (dns-read-bytes 2))) + (setq triggered t) + (cancel-timer timer) + (dns--filter process callback type full tcp))))) + ;; In case we the process is deleted for some reason, then do + ;; a failure callback. + (set-process-sentinel + process + (lambda (_ state) + (when (and (eq state 'deleted) + ;; Ensure we don't trigger this callback twice. + (not triggered)) + (setq triggered t) + (cancel-timer timer) + (kill-buffer buffer) + (funcall callback nil)))))))) + +(defun dns--filter (process callback type full tcp) + (let ((message (buffer-string))) + (when (process-live-p process) + (delete-process process)) + (kill-buffer (current-buffer)) + (when (>= (length message) 2) + (let ((result (dns-read message tcp))) + (funcall callback + (if full + result + (let ((answer (car (dns-get 'answers result)))) + (when (eq type (dns-get 'type answer)) + (if (eq type 'TXT) + (dns-get-txt-answer (dns-get 'answers result)) + (dns-get 'data answer)))))))))) + +(defun dns-query (name &optional type full reverse) + "Query a DNS server for NAME of TYPE. +If FULL, return the entire record returned. +If REVERSE, look up an IP address." + (let ((result nil)) + (dns-query-asynchronous + name + (lambda (response) + (setq result (list response))) + type full reverse) + ;; Loop until we get the callback. + (while (not result) + (sleep-for 0.01)) + (car result))) (provide 'dns) diff --git a/lisp/net/eudc-bob.el b/lisp/net/eudc-bob.el index 20a5c5f6075..56ea033a963 100644 --- a/lisp/net/eudc-bob.el +++ b/lisp/net/eudc-bob.el @@ -71,7 +71,7 @@ `("EUDC Sound Menu" ["---" nil nil] ["Play sound" eudc-bob-play-sound-at-point - (fboundp 'play-sound)] + (fboundp 'play-sound-internal)] ,@(cdr (cdr eudc-bob-generic-menu)))) (defun eudc-jump-to-event (event) @@ -197,7 +197,7 @@ display a button." (let (sound) (if (null (setq sound (eudc-bob-get-overlay-prop 'object-data))) (error "No sound data available here") - (unless (fboundp 'play-sound) + (unless (fboundp 'play-sound-internal) (error "Playing sounds not supported on this system")) (play-sound (list 'sound :data sound))))) @@ -214,8 +214,7 @@ display a button." (let ((data (eudc-bob-get-overlay-prop 'object-data)) (buffer (generate-new-buffer "*eudc-tmp*"))) (save-excursion - (if (fboundp 'set-buffer-file-coding-system) - (set-buffer-file-coding-system 'binary)) + (set-buffer-file-coding-system 'binary) (set-buffer buffer) (set-buffer-multibyte nil) (insert data) @@ -231,8 +230,7 @@ display a button." viewer) (condition-case nil (save-excursion - (if (fboundp 'set-buffer-file-coding-system) - (set-buffer-file-coding-system 'binary)) + (set-buffer-file-coding-system 'binary) (set-buffer buffer) (insert data) (setq program (completing-read "Viewer: " eudc-external-viewers)) diff --git a/lisp/net/eudcb-macos-contacts.el b/lisp/net/eudcb-macos-contacts.el new file mode 100644 index 00000000000..e2d10e33d49 --- /dev/null +++ b/lisp/net/eudcb-macos-contacts.el @@ -0,0 +1,122 @@ +;;; eudcb-macos-contacts.el --- EUDC - macOS Contacts backend + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Alexander Adolf + +;; 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 library provides an interface to the macOS Contacts app as +;; an EUDC data source. It uses AppleScript to interface with the +;; Contacts app on localhost, so no 3rd party tools are needed. + +;;; Usage: +;; (require 'eudcb-macos-contacts) +;; (eudc-macos-contacts-set-server "localhost") + +;;; Code: + +(require 'eudc) +(require 'executable) + +;;{{{ Internal cooking + +(defvar eudc-macos-contacts-conversion-alist nil) + +;; hook ourselves into the EUDC framework +(eudc-protocol-set 'eudc-query-function + 'eudc-macos-contacts-query-internal + 'macos-contacts) +(eudc-protocol-set 'eudc-list-attributes-function + nil + 'macos-contacts) +(eudc-protocol-set 'eudc-macos-contacts-conversion-alist + nil + 'macos-contacts) +(eudc-protocol-set 'eudc-protocol-has-default-query-attributes + nil + 'macos-contacts) + +(defun eudc-macos-contacts-search-helper (str) + "Helper function to query the Contacts app via AppleScript. +Searches for all persons with a case-insensitive substring match +of STR in any of their name fields (first, middle, or last)." + (if (executable-find "osascript") + (call-process "osascript" nil t nil + "-e" + (format " +set results to {} +tell application \"Address Book\" + set pList to every person whose (name contains \"%s\") + repeat with pers in pList + repeat with emailAddr in emails of pers + set results to results & {name of pers & \":\" & value ¬ + of emailAddr & \"\n\"} + end repeat + end repeat + get results as text +end tell" str)) + (message (concat "[eudc] Error in macOS Contacts backend: " + "`osascript' executable not found. " + "Is this is a macOS 10.0 or later system?")))) + +(defun eudc-macos-contacts-query-internal (query &optional return-attrs) + "Query macOS Contacts with QUERY. +QUERY is a list of cons cells (ATTR . VALUE) where ATTRs should be valid +macOS Contacts attribute names. +RETURN-ATTRS is a list of attributes to return, defaulting to +`eudc-default-return-attributes'." + (let ((macos-contacts-buffer (get-buffer-create " *macOS Contacts*")) + result) + (with-current-buffer macos-contacts-buffer + (erase-buffer) + (dolist (term query) + (eudc-macos-contacts-search-helper (cdr term))) + (delete-duplicate-lines (point-min) (point-max)) + (goto-char (point-min)) + (while (not (eobp)) + (if (not (equal (line-beginning-position) (line-end-position))) + (let* ((args (split-string (buffer-substring + (point) (line-end-position)) + ":")) + (name (nth 0 args)) + (email (nth 1 args))) + (setq result (cons `((name . ,name) + (email . ,email)) result)))) + (forward-line)) + result))) + +;;}}} + +;;{{{ High-level interfaces (interactive functions) + +(defun eudc-macos-contacts-set-server (dummy) + "Set the EUDC server to macOS Contacts app. +The server in DUMMY is not actually used, since this backend +always and implicitly connetcs to an instance of the Contacts app +running on the local host." + (interactive) + (eudc-set-server dummy 'macos-contacts) + (message "[eudc] macOS Contacts app server selected")) + +;;}}} + +(eudc-register-protocol 'macos-contacts) + +(provide 'eudcb-macos-contacts) + +;;; eudcb-macos-contacts.el ends here diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 568b96f4d58..e7170b3e6d1 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -25,14 +25,15 @@ ;;; Code: (require 'cl-lib) -(require 'format-spec) +(require 'mm-url) +(require 'puny) (require 'shr) +(require 'text-property-search) +(require 'thingatpt) (require 'url) (require 'url-queue) -(require 'thingatpt) -(require 'mm-url) -(require 'puny) -(eval-when-compile (require 'subr-x)) ;; for string-trim +(require 'xdg) +(eval-when-compile (require 'subr-x)) (defgroup eww nil "Emacs Web Wowser" @@ -55,11 +56,24 @@ :group 'eww :type 'string) -(defcustom eww-download-directory "~/Downloads/" - "Directory where files will downloaded." - :version "24.4" +(defun erc--download-directory () + "Return the name of the download directory. +If ~/Downloads/ exists, that will be used, and if not, the +DOWNLOAD XDG user directory will be returned. If that's +undefined, ~/Downloads/ is returned anyway." + (or (and (file-exists-p "~/Downloads/") + "~/Downloads/") + (when-let ((dir (xdg-user-dir "DOWNLOAD"))) + (file-name-as-directory dir)) + "~/Downloads/")) + +(defcustom eww-download-directory 'erc--download-directory + "Directory where files will downloaded. +This should either be a directory name or a function (called with +no parameters) that returns a directory name." + :version "28.1" :group 'eww - :type 'directory) + :type '(choice directory function)) ;;;###autoload (defcustom eww-suggest-uris @@ -263,13 +277,35 @@ This list can be customized via `eww-suggest-uris'." (nreverse uris))) ;;;###autoload -(defun eww (url &optional arg) +(defun eww-browse () + "Function to be run to parse command line URLs. +This is meant to be used for MIME handlers or command line use. + +Setting the handler for \"text/x-uri;\" to +\"emacs -f eww-browse %u\" will then start up Emacs and call eww +to browse the url. + +This can also be used on the command line directly: + + emacs -f eww-browse https://gnu.org + +will start Emacs and browse the GNU web site." + (interactive) + (eww (pop command-line-args-left))) + + +;;;###autoload +(defun eww (url &optional arg buffer) "Fetch URL and render the page. If the input doesn't look like an URL or a domain name, the word(s) will be searched for via `eww-search-prefix'. If called with a prefix ARG, use a new buffer instead of reusing -the default EWW buffer." +the default EWW buffer. + +If BUFFER, the data to be rendered is in that buffer. In that +case, this function doesn't actually fetch URL. BUFFER will be +killed after rendering." (interactive (let* ((uris (eww-suggested-uris)) (prompt (concat "Enter URL or keywords" @@ -307,8 +343,14 @@ the default EWW buffer." (insert (format "Loading %s..." url)) (goto-char (point-min))) (let ((url-mime-accept-string eww-accept-content-types)) - (url-retrieve url 'eww-render - (list url nil (current-buffer))))) + (if buffer + (let ((eww-buffer (current-buffer))) + (with-current-buffer buffer + (eww-render nil url nil eww-buffer))) + (url-retrieve url #'eww-render + (list url nil (current-buffer)))))) + +(function-put 'eww 'browse-url-browser-kind 'internal) (defun eww--dwim-expand-url (url) (setq url (string-trim url)) @@ -359,7 +401,19 @@ the default EWW buffer." (eww (concat "file://" (and (memq system-type '(windows-nt ms-dos)) "/") - (expand-file-name file)))) + (expand-file-name file)) + nil + ;; The file name may be a non-local Tramp file. The URL + ;; library doesn't understand these file names, so use the + ;; normal Emacs machinery to load the file. + (with-current-buffer (generate-new-buffer " *eww file*") + (set-buffer-multibyte nil) + (insert "Content-type: " (or (mailcap-extension-to-mime + (url-file-extension file)) + "application/octet-stream") + "\n\n") + (insert-file-contents file) + (current-buffer)))) ;;;###autoload (defun eww-search-words () @@ -373,8 +427,8 @@ engine used." (let ((region-string (buffer-substring (region-beginning) (region-end)))) (if (not (string-match-p "\\`[ \n\t\r\v\f]*\\'" region-string)) (eww region-string) - (call-interactively 'eww))) - (call-interactively 'eww))) + (call-interactively #'eww))) + (call-interactively #'eww))) (defun eww-open-in-new-buffer () "Fetch link at point in a new EWW buffer." @@ -541,10 +595,10 @@ Currently this means either text/html or application/xhtml+xml." (goto-char point)) (shr-target-id (goto-char (point-min)) - (let ((point (next-single-property-change - (point-min) 'shr-target-id))) - (when point - (goto-char point)))) + (let ((match (text-property-search-forward + 'shr-target-id shr-target-id t))) + (when match + (goto-char (prop-match-beginning match))))) (t (goto-char (point-min)) ;; Don't leave point inside forms, because the normal eww @@ -1011,7 +1065,7 @@ just re-display the HTML already fetched." (eww-display-html 'utf-8 url (plist-get eww-data :dom) (point) (current-buffer))) (let ((url-mime-accept-string eww-accept-content-types)) - (url-retrieve url 'eww-render + (url-retrieve url #'eww-render (list url (point) (current-buffer) encode)))))) ;; Form support. @@ -1111,11 +1165,13 @@ just re-display the HTML already fetched." (defun eww-form-submit (dom) (let ((start (point)) (value (dom-attr dom 'value))) - (setq value - (if (zerop (length value)) - "Submit" - value)) - (insert value) + (if (null value) + (shr-generic dom) + (insert value)) + ;; If the contents of the <button>...</button> turns out to be + ;; empty, or the value was blank, default to this: + (when (= (point) start) + (insert "Submit")) (add-face-text-property start (point) 'eww-form-submit) (put-text-property start (point) 'eww-form (list :eww-form eww-form @@ -1256,7 +1312,7 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.") (defun eww-tag-textarea (dom) (let ((start (point)) - (value (or (dom-attr dom 'value) "")) + (value (or (dom-text dom) "")) (lines (string-to-number (or (dom-attr dom 'rows) "10"))) (width (string-to-number (or (dom-attr dom 'cols) "10"))) end) @@ -1572,8 +1628,10 @@ If EXTERNAL is double prefix, browse in new buffer." (cond ((not url) (message "No link under point")) - ((string-match "^mailto:" url) - (browse-url-mail url)) + ((string-match-p "\\`mailto:" url) + ;; This respects the user options `browse-url-handlers' + ;; and `browse-url-mailto-function'. + (browse-url url)) ((and (consp external) (<= (car external) 4)) (funcall browse-url-secondary-browser-function url) (shr--blink-link)) @@ -1606,20 +1664,23 @@ Differences in #targets are ignored." "Download URL to `eww-download-directory'. Use link at point if there is one, else the current page's URL." (interactive) - (access-file eww-download-directory "Download failed") - (let ((url (or (get-text-property (point) 'shr-url) - (eww-current-url)))) - (if (not url) - (message "No URL under point") - (url-retrieve url 'eww-download-callback (list url))))) - -(defun eww-download-callback (status url) + (let ((dir (if (stringp eww-download-directory) + eww-download-directory + (funcall eww-download-directory)))) + (access-file dir "Download failed") + (let ((url (or (get-text-property (point) 'shr-url) + (eww-current-url)))) + (if (not url) + (message "No URL under point") + (url-retrieve url #'eww-download-callback (list url dir)))))) + +(defun eww-download-callback (status url dir) (unless (plist-get status :error) (let* ((obj (url-generic-parse-url url)) (path (directory-file-name (car (url-path-and-query obj)))) (file (eww-make-unique-file-name (eww-decode-url-file-name (file-name-nondirectory path)) - eww-download-directory))) + dir))) (goto-char (point-min)) (re-search-forward "\r?\n\r?\n") (let ((coding-system-for-write 'no-conversion)) @@ -1735,28 +1796,30 @@ If CHARSET is nil then use UTF-8." (defun eww-write-bookmarks () (with-temp-file (expand-file-name "eww-bookmarks" eww-bookmarks-directory) - (insert ";; Auto-generated file; don't edit\n") + (insert ";; Auto-generated file; don't edit -*- mode: lisp-data -*-\n") (pp eww-bookmarks (current-buffer)))) -(defun eww-read-bookmarks () +(defun eww-read-bookmarks (&optional error-out) + "Read bookmarks from `eww-bookmarks'. +If ERROR-OUT, signal user-error if there are no bookmarks." (let ((file (expand-file-name "eww-bookmarks" eww-bookmarks-directory))) (setq eww-bookmarks (unless (zerop (or (file-attribute-size (file-attributes file)) 0)) (with-temp-buffer (insert-file-contents file) - (read (current-buffer))))))) + (read (current-buffer))))) + (when (and error-out (not eww-bookmarks)) + (user-error "No bookmarks are defined")))) ;;;###autoload (defun eww-list-bookmarks () "Display the bookmarks." (interactive) + (eww-read-bookmarks t) (pop-to-buffer "*eww bookmarks*") (eww-bookmark-prepare)) (defun eww-bookmark-prepare () - (eww-read-bookmarks) - (unless eww-bookmarks - (user-error "No bookmarks are defined")) (set-buffer (get-buffer-create "*eww bookmarks*")) (eww-bookmark-mode) (let* ((width (/ (window-width) 2)) @@ -1824,6 +1887,7 @@ If CHARSET is nil then use UTF-8." bookmark) (unless (get-buffer "*eww bookmarks*") (setq first t) + (eww-read-bookmarks t) (eww-bookmark-prepare)) (with-current-buffer (get-buffer "*eww bookmarks*") (when (and (not first) @@ -1842,6 +1906,7 @@ If CHARSET is nil then use UTF-8." bookmark) (unless (get-buffer "*eww bookmarks*") (setq first t) + (eww-read-bookmarks t) (eww-bookmark-prepare)) (with-current-buffer (get-buffer "*eww bookmarks*") (if first @@ -2124,12 +2189,12 @@ entries (if any) will be removed from the list. Only the properties listed in `eww-desktop-data-save' are included. Generally, the list should not include the (usually overly large) :dom, :source and :text properties." - (let ((history (mapcar 'eww-desktop-data-1 - (cons eww-data eww-history)))) - (list :history (if eww-desktop-remove-duplicates - (cl-remove-duplicates - history :test 'eww-desktop-history-duplicate) - history)))) + (let ((history (mapcar #'eww-desktop-data-1 + (cons eww-data eww-history)))) + (list :history (if eww-desktop-remove-duplicates + (cl-remove-duplicates + history :test #'eww-desktop-history-duplicate) + history)))) (defun eww-restore-desktop (file-name buffer-name misc-data) "Restore an eww buffer from its desktop file record. diff --git a/lisp/net/gnutls.el b/lisp/net/gnutls.el index 5212bf6a3f6..e713c94117b 100644 --- a/lisp/net/gnutls.el +++ b/lisp/net/gnutls.el @@ -170,8 +170,9 @@ Third arg HOST is the name of the host to connect to, or its IP address. Fourth arg SERVICE is the name of the service desired, or an integer specifying a port number to connect to. Fifth arg PARAMETERS is an optional list of keyword/value pairs. -Only :client-certificate and :nowait keywords are recognized, and -have the same meaning as for `open-network-stream'. +Only :client-certificate, :nowait, and :coding keywords are +recognized, and have the same meaning as for +`open-network-stream'. For historical reasons PARAMETERS can also be a symbol, which is interpreted the same as passing a list containing :nowait and the value of that symbol. @@ -209,7 +210,8 @@ trust and key files, and priority string." (gnutls-boot-parameters :type 'gnutls-x509pki :keylist keylist - :hostname (puny-encode-domain host))))))) + :hostname (puny-encode-domain host)))) + :coding (plist-get parameters :coding)))) (if nowait process (gnutls-negotiate :process process diff --git a/lisp/net/hmac-md5.el b/lisp/net/hmac-md5.el index 92efb6ba275..974ee0d3691 100644 --- a/lisp/net/hmac-md5.el +++ b/lisp/net/hmac-md5.el @@ -1,4 +1,4 @@ -;;; hmac-md5.el --- Compute HMAC-MD5. +;;; hmac-md5.el --- Compute HMAC-MD5. -*- lexical-binding:t -*- ;; Copyright (C) 1999, 2001, 2007-2020 Free Software Foundation, Inc. @@ -22,42 +22,8 @@ ;;; Commentary: -;; Test cases from RFC 2202, "Test Cases for HMAC-MD5 and HMAC-SHA-1". -;; -;; (encode-hex-string (hmac-md5 "Hi There" (make-string 16 ?\x0b))) -;; => "9294727a3638bb1c13f48ef8158bfc9d" -;; -;; (encode-hex-string (hmac-md5 "what do ya want for nothing?" "Jefe")) -;; => "750c783e6ab0b503eaa86e310a5db738" -;; -;; (encode-hex-string (hmac-md5 (make-string 50 ?\xdd) (make-string 16 ?\xaa))) -;; => "56be34521d144c88dbb8c733f0e8b3f6" -;; -;; (encode-hex-string -;; (hmac-md5 -;; (make-string 50 ?\xcd) -;; (decode-hex-string "0102030405060708090a0b0c0d0e0f10111213141516171819"))) -;; => "697eaf0aca3a3aea3a75164746ffaa79" -;; -;; (encode-hex-string -;; (hmac-md5 "Test With Truncation" (make-string 16 ?\x0c))) -;; => "56461ef2342edc00f9bab995690efd4c" -;; -;; (encode-hex-string -;; (hmac-md5-96 "Test With Truncation" (make-string 16 ?\x0c))) -;; => "56461ef2342edc00f9bab995" -;; -;; (encode-hex-string -;; (hmac-md5 -;; "Test Using Larger Than Block-Size Key - Hash Key First" -;; (make-string 80 ?\xaa))) -;; => "6b1ab7fe4bd7bf8f0b62e6ce61b9d0cd" -;; -;; (encode-hex-string -;; (hmac-md5 -;; "Test Using Larger Than Block-Size Key and Larger Than One Block-Size Data" -;; (make-string 80 ?\xaa))) -;; => "6f630fad67cda0ee1fb1f562db3aa53e" +;; Test cases from RFC 2202, "Test Cases for HMAC-MD5 and HMAC-SHA-1", +;; moved to lisp/test/net/hmac-md5-tests.el ;;; Code: diff --git a/lisp/net/imap.el b/lisp/net/imap.el index aa10f0291fd..22b59084004 100644 --- a/lisp/net/imap.el +++ b/lisp/net/imap.el @@ -134,9 +134,9 @@ ;; ;;; Code: +;;; Dependencies (eval-when-compile (require 'cl-lib)) -(require 'format-spec) (require 'utf7) (require 'rfc2104) ;; Hmm... digest-md5 is not part of Emacs. @@ -146,7 +146,7 @@ (declare-function digest-md5-digest-uri "ext:digest-md5") (declare-function digest-md5-challenge "ext:digest-md5") -;; User variables. +;;; User variables (defgroup imap nil "Low-level IMAP issues." @@ -258,7 +258,7 @@ Shorter values mean quicker response, but is more CPU intensive." :group 'imap :type 'boolean) -;; Various variables. +;;; Various variables (defvar imap-fetch-data-hook nil "Hooks called after receiving each FETCH response.") @@ -317,7 +317,9 @@ the value of this variable will be bound to a certain value to which an application program that uses this module specifies on a per-server basis.") -;; Internal constants. Change these and die. +;;; Internal constants + +;; Change these and die. (defconst imap-default-port 143) (defconst imap-default-ssl-port 993) @@ -349,7 +351,7 @@ basis.") (defconst imap-log-buffer "*imap-log*") (defconst imap-debug-buffer "*imap-debug*") -;; Internal variables. +;;; Internal variables (defvar imap-stream nil) (defvar imap-auth nil) @@ -438,7 +440,7 @@ This variable is set to t automatically per server if the canonical form fails.") -;; Utility functions: +;;; Utility functions (defun imap-remassoc (key alist) "Delete by side effect any elements of ALIST whose car is `equal' to KEY. @@ -490,7 +492,8 @@ sure of changing the value of `foo'." (nth 3 (car imap-failed-tags)))) -;; Server functions; stream stuff: +;;; Server functions +;;;; Stream functions (defun imap-log (string-or-buffer) (when imap-log @@ -517,12 +520,9 @@ sure of changing the value of `foo'." (process-connection-type imap-process-connection-type) (process (start-process name buffer shell-file-name shell-command-switch - (format-spec - cmd - (format-spec-make - ?s server - ?p (number-to-string port) - ?l imap-default-user)))) + (format-spec cmd `((?s . ,server) + (?p . ,(number-to-string port)) + (?l . ,imap-default-user))))) response) (when process (with-current-buffer buffer @@ -583,12 +583,9 @@ sure of changing the value of `foo'." (process-connection-type imap-process-connection-type) (process (start-process name buffer shell-file-name shell-command-switch - (format-spec - cmd - (format-spec-make - ?s server - ?p (number-to-string port) - ?l imap-default-user)))) + (format-spec cmd `((?s . ,server) + (?p . ,(number-to-string port)) + (?l . ,imap-default-user))))) response) (when process (with-current-buffer buffer @@ -701,13 +698,10 @@ sure of changing the value of `foo'." (process-connection-type imap-process-connection-type) (process (start-process name buffer shell-file-name shell-command-switch - (format-spec - cmd - (format-spec-make - ?s server - ?g imap-shell-host - ?p (number-to-string port) - ?l imap-default-user))))) + (format-spec cmd `((?s . ,server) + (?g . ,imap-shell-host) + (?p . ,(number-to-string port)) + (?l . ,imap-default-user)))))) (when process (while (and (memq (process-status process) '(open run)) (set-buffer buffer) ;; XXX "blue moon" nntp.el bug @@ -757,7 +751,7 @@ sure of changing the value of `foo'." (message "imap: Connecting with STARTTLS...%s" (if done "done" "failed")) done)) -;; Server functions; authenticator stuff: +;;;; Authenticator functions (defun imap-interactive-login (buffer loginfunc) "Login to server in BUFFER. @@ -881,7 +875,7 @@ t if it successfully authenticates, nil otherwise." (concat "LOGIN anonymous \"" (concat (user-login-name) "@" (system-name)) "\""))))) -;;; Compiler directives. +;;; Compiler directives (defvar imap-sasl-client) (defvar imap-sasl-step) @@ -979,7 +973,7 @@ t if it successfully authenticates, nil otherwise." (imap-send-command-1 "") (imap-ok-p (imap-wait-for-tag tag))))))) -;; Server functions: +;;; Server functions (defun imap-open-1 (buffer) (with-current-buffer buffer @@ -1238,7 +1232,7 @@ If BUFFER is nil, the current buffer is assumed." (imap-send-command-wait "LOGOUT" buffer))) -;; Mailbox functions: +;;; Mailbox functions (defun imap-mailbox-put (propname value &optional mailbox buffer) (with-current-buffer (or buffer (current-buffer)) @@ -1530,7 +1524,7 @@ or `unseen'. The IMAP command tag is returned." identifier)))))) -;; Message functions: +;;; Message functions (defun imap-current-message (&optional buffer) (with-current-buffer (or buffer (current-buffer)) @@ -1842,7 +1836,7 @@ on failure." (if (aref from 0) ">")))) -;; Internal functions. +;;; Internal functions (defun imap-add-callback (tag func) (setq imap-callbacks (append (list (cons tag func)) imap-callbacks))) @@ -1979,7 +1973,7 @@ Return nil if no complete line has arrived." (delete-region (point-min) (point-max))))))))) -;; Imap parser. +;;; Imap parser (defsubst imap-forward () (or (eobp) (forward-char))) @@ -2860,6 +2854,8 @@ Return nil if no complete line has arrived." (imap-forward) (nreverse body))))) +;;; Debug + (when imap-debug ; (untrace-all) (require 'trace) (buffer-disable-undo (get-buffer-create imap-debug-buffer)) 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/mailcap.el b/lisp/net/mailcap.el index 5fe5b4d3a54..f01a5deb7ec 100644 --- a/lisp/net/mailcap.el +++ b/lisp/net/mailcap.el @@ -29,6 +29,7 @@ ;;; Code: +(require 'cl-lib) (autoload 'mail-header-parse-content-type "mail-parse") (defgroup mailcap nil @@ -268,11 +269,6 @@ is consulted." (viewer . "display %s") (type . "image/*") (test . (eq window-system 'x)) - ("needsx11")) - (".*" - (viewer . "ee %s") - (type . "image/*") - (test . (eq window-system 'x)) ("needsx11"))) ("text" ("plain" @@ -337,6 +333,10 @@ is a string or list of strings, it represents a shell command to run to return a true or false shell value for the validity.") (put 'mailcap-mime-data 'risky-local-variable t) +(defvar mailcap--computed-mime-data nil + "Computed version of the mailcap data incorporating all sources. +Same format as `mailcap-mime-data'.") + (defcustom mailcap-download-directory nil "Directory to which `mailcap-save-binary-file' downloads files by default. nil means your home directory." @@ -422,7 +422,13 @@ MAILCAPS if set; otherwise (on Unix) use the path from RFC 1524, plus (when (or (not mailcap-parsed-p) force) ;; Clear out all old data. - (setq mailcap-mime-data nil) + (setq mailcap--computed-mime-data nil) + ;; Add the Emacs-distributed defaults (which will be used as + ;; fallbacks). Do it this way instead of just copying the list, + ;; since entries are destructively modified. + (cl-loop for (major . minors) in mailcap-mime-data + do (cl-loop for (minor . entry) in minors + do (mailcap-add-mailcap-entry major minor entry))) (cond (path nil) ((getenv "MAILCAPS") @@ -709,10 +715,13 @@ to supply to the test." (push (list otest result) mailcap-viewer-test-cache) result)))) -(defun mailcap-add-mailcap-entry (major minor info) - (let ((old-major (assoc major mailcap-mime-data))) +(defun mailcap-add-mailcap-entry (major minor info &optional storage) + (let* ((storage (or storage 'mailcap--computed-mime-data)) + (old-major (assoc major (symbol-value storage)))) (if (null old-major) ; New major area - (push (cons major (list (cons minor info))) mailcap-mime-data) + (set storage + (cons (cons major (list (cons minor info))) + (symbol-value storage))) (let ((cur-minor (assoc minor old-major))) (cond ((or (null cur-minor) ; New minor area, or @@ -736,11 +745,15 @@ If TEST is not given, it defaults to t." (when (or (not (car tl)) (not (cadr tl))) (error "%s is not a valid MIME type" type)) - (mailcap-add-mailcap-entry - (car tl) (cadr tl) - `((viewer . ,viewer) - (test . ,(if test test t)) - (type . ,type))))) + (let ((entry + `((viewer . ,viewer) + (test . ,(if test test t)) + (type . ,type)))) + ;; Store it. + (mailcap-add-mailcap-entry (car tl) (cadr tl) entry + 'mailcap-user-mime-data) + ;; Make it available for usage. + (mailcap-add-mailcap-entry (car tl) (cadr tl) entry)))) ;;; ;;; The main whabbo @@ -791,13 +804,13 @@ If NO-DECODE is non-nil, don't decode STRING." ;; NO-DECODE avoids calling `mail-header-parse-content-type' from ;; `mail-parse.el' (let ( - major ; Major encoding (text, etc) - minor ; Minor encoding (html, etc) - info ; Other info - major-info ; (assoc major mailcap-mime-data) - viewers ; Possible viewers - passed ; Viewers that passed the test - viewer ; The one and only viewer + major ; Major encoding (text, etc) + minor ; Minor encoding (html, etc) + info ; Other info + major-info ; (assoc major mailcap--computed-mime-data) + viewers ; Possible viewers + passed ; Viewers that passed the test + viewer ; The one and only viewer ctl) (save-excursion (setq ctl @@ -809,12 +822,12 @@ If NO-DECODE is non-nil, don't decode STRING." (if viewer (setq passed (list viewer)) ;; None found, so heuristically select some applicable viewer - ;; from `mailcap-mime-data'. + ;; from `mailcap--computed-mime-data'. (mailcap-parse-mailcaps nil t) (setq major (split-string (car ctl) "/")) (setq minor (cadr major) major (car major)) - (when (setq major-info (cdr (assoc major mailcap-mime-data))) + (when (setq major-info (cdr (assoc major mailcap--computed-mime-data))) (when (setq viewers (mailcap-possible-viewers major-info minor)) (setq info (mapcar (lambda (a) (cons (symbol-name (car a)) (cdr a))) @@ -847,7 +860,7 @@ If NO-DECODE is non-nil, don't decode STRING." ((eq request 'all) passed) (t - ;; MUST make a copy *sigh*, else we modify mailcap-mime-data + ;; MUST make a copy *sigh*, else we modify mailcap--computed-mime-data (setq viewer (copy-sequence viewer)) (let ((view (assq 'viewer viewer)) (test (assq 'test viewer))) @@ -1057,7 +1070,7 @@ For instance, \"foo.png\" will result in \"image/png\"." (nconc (mapcar 'cdr mailcap-mime-extensions) (let (res type) - (dolist (data mailcap-mime-data) + (dolist (data mailcap--computed-mime-data) (dolist (info (cdr data)) (setq type (cdr (assq 'type (cdr info)))) (unless (string-match-p "\\*" type) @@ -1117,7 +1130,7 @@ For instance, \"foo.png\" will result in \"image/png\"." (defun mailcap-view-mime (type) "View the data in the current buffer that has MIME type TYPE. -`mailcap-mime-data' determines the method to use." +`mailcap--computed-mime-data' determines the method to use." (let ((method (mailcap-mime-info type))) (if (stringp method) (shell-command-on-region (point-min) (point-max) diff --git a/lisp/net/network-stream.el b/lisp/net/network-stream.el index e99d7a372c0..e86426d4664 100644 --- a/lisp/net/network-stream.el +++ b/lisp/net/network-stream.el @@ -113,6 +113,10 @@ values: `ssl' -- Equivalent to `tls'. `shell' -- A shell connection. +:coding is a symbol or a cons used to specify the coding systems +used to decode and encode the data which the process reads and +writes. See `make-network-process' for details. + :return-list specifies this function's return value. If omitted or nil, return a process object. A non-nil means to return (PROC . PROPS), where PROC is a process object and PROPS @@ -135,7 +139,10 @@ values: :capability-command specifies a command used to query the HOST for its capabilities. For instance, for IMAP this should be - \"1 CAPABILITY\\r\\n\". + \"1 CAPABILITY\\r\\n\". This can either be a string (which will + then be sent verbatim to the server), or a function (called with + a single parameter; the \"greeting\" from the server when connecting), + and should return a string to send to the server. :starttls-function specifies a function for handling STARTTLS. This function should take one parameter, the response to the @@ -166,8 +173,8 @@ a greeting from the server. :nowait, if non-nil, says the connection should be made asynchronously, if possible. -:shell-command is a format-spec string that can be used if :type -is `shell'. It has two specs, %s for host and %p for port +:shell-command is a `format-spec' string that can be used if +:type is `shell'. It has two specs, %s for host and %p for port number. Example: \"ssh gateway nc %s %p\". :tls-parameters is a list that should be supplied if you're @@ -189,7 +196,8 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." :host (puny-encode-domain host) :service service :nowait (plist-get parameters :nowait) :tls-parameters - (plist-get parameters :tls-parameters)) + (plist-get parameters :tls-parameters) + :coding (plist-get parameters :coding)) (let ((work-buffer (or buffer (generate-new-buffer " *stream buffer*"))) (fun (cond ((and (eq type 'plain) @@ -249,7 +257,8 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." (stream (make-network-process :name name :buffer buffer :host (puny-encode-domain host) :service service - :nowait (plist-get parameters :nowait)))) + :nowait (plist-get parameters :nowait) + :coding (plist-get parameters :coding)))) (when (plist-get parameters :warn-unless-encrypted) (setq stream (nsm-verify-connection stream host service nil t))) (list stream @@ -270,11 +279,15 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." ;; Return (STREAM GREETING CAPABILITIES RESULTING-TYPE) (stream (make-network-process :name name :buffer buffer :host (puny-encode-domain host) - :service service)) + :service service + :coding (plist-get parameters :coding))) (greeting (and (not (plist-get parameters :nogreeting)) (network-stream-get-response stream start eoc))) - (capabilities (network-stream-command stream capability-command - eo-capa)) + (capabilities + (network-stream-command + stream + (network-stream--capability-command capability-command greeting) + eo-capa)) (resulting-type 'plain) starttls-available starttls-command error) @@ -322,7 +335,10 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." ;; Requery capabilities for protocols that require it; i.e., ;; EHLO for SMTP. (when (plist-get parameters :always-query-capabilities) - (network-stream-command stream capability-command eo-capa))) + (network-stream-command + stream + (network-stream--capability-command capability-command greeting) + eo-capa))) (when (let ((response (network-stream-command stream starttls-command eoc))) (and response (string-match success-string response))) @@ -350,14 +366,18 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." (setq stream (make-network-process :name name :buffer buffer :host (puny-encode-domain host) - :service service)) + :service service + :coding (plist-get parameters :coding))) (network-stream-get-response stream start eoc))) (unless (process-live-p stream) (error "Unable to negotiate a TLS connection with %s/%s" host service)) ;; Re-get the capabilities, which may have now changed. (setq capabilities - (network-stream-command stream capability-command eo-capa)))) + (network-stream-command + stream + (network-stream--capability-command capability-command greeting) + eo-capa)))) ;; If TLS is mandatory, close the connection if it's unencrypted. (when (and require-tls @@ -420,7 +440,8 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." parameters) (require 'tls) (open-tls-stream name buffer host service))) - (eoc (plist-get parameters :end-of-command))) + (eoc (plist-get parameters :end-of-command)) + greeting) (if (plist-get parameters :nowait) (list stream nil nil 'tls) ;; Check certificate validity etc. @@ -432,42 +453,58 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." ;; openssl/gnutls-cli. (when (and (not (gnutls-available-p)) eoc) - (network-stream-get-response stream start eoc) + (setq greeting (network-stream-get-response stream start eoc)) (goto-char (point-min)) (when (re-search-forward eoc nil t) (goto-char (match-beginning 0)) (delete-region (point-min) (line-beginning-position)))) - (let ((capability-command (plist-get parameters :capability-command)) + (let ((capability-command + (plist-get parameters :capability-command)) (eo-capa (or (plist-get parameters :end-of-capability) eoc))) (list stream (network-stream-get-response stream start eoc) - (network-stream-command stream capability-command eo-capa) + (network-stream-command + stream + (network-stream--capability-command + capability-command greeting) + eo-capa) 'tls))))))) -(declare-function format-spec "format-spec" (format spec)) -(declare-function format-spec-make "format-spec" (&rest pairs)) - (defun network-stream-open-shell (name buffer host service parameters) - (require 'format-spec) (let* ((capability-command (plist-get parameters :capability-command)) (eoc (plist-get parameters :end-of-command)) (start (with-current-buffer buffer (point))) + (coding (plist-get parameters :coding)) (stream (let ((process-connection-type nil)) (start-process name buffer shell-file-name shell-command-switch (format-spec (plist-get parameters :shell-command) - (format-spec-make - ?s host - ?p service)))))) + `((?s . ,host) + (?p . ,service)))))) + greeting) + (when coding (if (consp coding) + (set-process-coding-system stream + (car coding) + (cdr coding)) + (set-process-coding-system stream + coding + coding))) (list stream - (network-stream-get-response stream start eoc) - (network-stream-command stream capability-command - (or (plist-get parameters :end-of-capability) - eoc)) + (setq greeting (network-stream-get-response stream start eoc)) + (network-stream-command + stream + (network-stream--capability-command capability-command greeting) + (or (plist-get parameters :end-of-capability) + eoc)) 'plain))) +(defun network-stream--capability-command (command greeting) + (if (functionp command) + (funcall command greeting) + command)) + (provide 'network-stream) ;;; network-stream.el ends here 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..cc22427e6d1 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 @@ -964,6 +964,7 @@ protocol." (defun nsm-write-settings () (with-temp-file nsm-settings-file + (insert ";;;; -*- mode: lisp-data -*-\n") (insert "(\n") (dolist (setting nsm-permanent-host-settings) (insert " ") diff --git a/lisp/net/puny.el b/lisp/net/puny.el index 60a6c12e6c7..cc406076c58 100644 --- a/lisp/net/puny.el +++ b/lisp/net/puny.el @@ -1,4 +1,4 @@ -;;; puny.el --- translate non-ASCII domain names to ASCII +;;; puny.el --- translate non-ASCII domain names to ASCII -*- lexical-binding:t -*- ;; Copyright (C) 2015-2020 Free Software Foundation, Inc. @@ -35,7 +35,7 @@ For instance, \"fśf.org\" => \"xn--ff-2sa.org\"." ;; The vast majority of domain names are not IDNA domain names, so ;; add a check first to avoid doing unnecessary work. - (if (string-match "\\'[[:ascii:]]+\\'" domain) + (if (string-match "\\`[[:ascii:]]+\\'" domain) domain (mapconcat 'puny-encode-string (split-string domain "[.]") "."))) diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el index fff640bb675..1766e192f2d 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"))))) @@ -2421,7 +2421,7 @@ keywords when no KEYWORD is given." (concat "\\(?:" ;; Match paired parentheses, e.g. in Wikipedia URLs: - "[" chars punct "]+" "(" "[" chars punct "]+" "[" chars "]*)" "[" chars "]" + "[" chars punct "]+" "(" "[" chars punct "]+" ")" "[" chars "]" "\\|" "[" chars punct "]+" "[" chars "]" "\\)")) @@ -2626,12 +2626,16 @@ the only argument." (and ;; nickserv (string= sender "NickServ") (string= target rcirc-nick) - (member message - (list - (format "You are now identified for \C-b%s\C-b." rcirc-nick) - (format "You are successfully identified as \C-b%s\C-b." rcirc-nick) - "Password accepted - you are now recognized." - ))) + (cl-member + message + (list + (format "You are now identified for \C-b%s\C-b." rcirc-nick) + (format "You are successfully identified as \C-b%s\C-b." + rcirc-nick) + "Password accepted - you are now recognized.") + ;; The nick may have a different case, so match + ;; case-insensitively (Bug#39345). + :test #'cl-equalp)) (and ;; quakenet (string= sender "Q") (string= target rcirc-nick) 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..ddd81127213 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -95,15 +95,31 @@ If nil, don't draw horizontal table lines." :type 'character) (defcustom shr-width nil - "Frame width to use for rendering. + "Window width to use for HTML rendering. May either be an integer specifying a fixed width in characters, -or nil, meaning that the full width of the window should be used. -If `shr-use-fonts' is set, the mean character width is used to -compute the pixel width, which is used instead." +or nil, meaning use the full width of the window. +If `shr-use-fonts' is set, the value is interpreted as a multiple +of the mean character width of the default face's font. + +Also see `shr-max-width'." :version "25.1" :type '(choice (integer :tag "Fixed width in characters") (const :tag "Use the width of the window" nil))) +(defcustom shr-max-width 120 + "Maximum text width to use for HTML rendering. +May either be an integer specifying a fixed width in characters, +or nil, meaning that there is no width limit. + +If `shr-use-fonts' is set, the value of this variable is +interpreted as a multiple of the mean character width of the +default face's font. + +If `shr-width' is non-nil, it overrides this variable." + :version "28.1" + :type '(choice (integer :tag "Fixed width in characters") + (const :tag "No width limit" nil))) + (defcustom shr-bullet "* " "Bullet used for unordered lists. Alternative suggestions are: @@ -135,7 +151,7 @@ same domain as the main data." This is used for cid: URLs, and the function is called with the cid: URL as the argument.") -(defvar shr-put-image-function 'shr-put-image +(defvar shr-put-image-function #'shr-put-image "Function called to put image and alt string.") (defface shr-strike-through '((t :strike-through t)) @@ -185,13 +201,15 @@ and other things: (defvar shr-depth 0) (defvar shr-warning nil) (defvar shr-ignore-cache nil) -(defvar shr-target-id nil) (defvar shr-table-separator-length 1) (defvar shr-table-separator-pixel-width 0) (defvar shr-table-id nil) (defvar shr-current-font nil) (defvar shr-internal-bullet nil) +(defvar shr-target-id nil + "Target fragment identifier anchor.") + (defvar shr-map (let ((map (make-sparse-keymap))) (define-key map "a" 'shr-show-alt-text) @@ -265,30 +283,37 @@ DOM should be a parse tree as generated by (shr-table-separator-pixel-width (shr-string-pixel-width "-")) (shr-internal-bullet (cons shr-bullet (shr-string-pixel-width shr-bullet))) - (shr-internal-width (or (and shr-width - (if (not shr-use-fonts) - shr-width - (* shr-width (frame-char-width)))) - ;; We need to adjust the available - ;; width for when the user disables - ;; the fringes, which will cause the - ;; display engine usurp one column for - ;; the continuation glyph. - (if (not shr-use-fonts) - (- (window-body-width) 1 - (if (and (null shr-width) - (not (shr--have-one-fringe-p))) - 0 - 1)) - (- (window-body-width nil t) - (* 2 (frame-char-width)) - (if (and (null shr-width) - (not (shr--have-one-fringe-p))) - (* (frame-char-width) 2) - 0) - 1)))) + (shr-internal-width + (if shr-width + ;; Specified width; use it. + (if (not shr-use-fonts) + shr-width + (* shr-width (frame-char-width))) + ;; Compute the width based on the window width. We need to + ;; adjust the available width for when the user disables + ;; the fringes, which will cause the display engine usurp + ;; one column for the continuation glyph. + (if (not shr-use-fonts) + (- (window-body-width) 1 + (if (shr--have-one-fringe-p) + 1 + 0)) + (- (window-body-width nil t) + (* 2 (frame-char-width)) + (if (shr--have-one-fringe-p) + 0 + (* (frame-char-width) 2)) + 1)))) (max-specpdl-size max-specpdl-size) bidi-display-reordering) + ;; Adjust for max width specification. + (when (and shr-max-width + (not shr-width)) + (setq shr-internal-width + (min shr-internal-width + (if shr-use-fonts + (* shr-max-width (frame-char-width)) + shr-max-width)))) ;; If the window was hscrolled for some reason, shr-fill-lines ;; below will misbehave, because it silently assumes that it ;; starts with a non-hscrolled window (vertical-motion will move @@ -365,25 +390,20 @@ If the URL is already at the front of the kill ring act like (shr-copy-url url))) (defun shr--current-link-region () - (let ((current (get-text-property (point) 'shr-url)) - start) - (save-excursion - ;; Go to the beginning. - (while (and (not (bobp)) - (equal (get-text-property (point) 'shr-url) current)) - (forward-char -1)) - (unless (equal (get-text-property (point) 'shr-url) current) - (forward-char 1)) - (setq start (point)) - ;; Go to the end. - (while (and (not (eobp)) - (equal (get-text-property (point) 'shr-url) current)) - (forward-char 1)) - (list start (point))))) + "Return the start and end positions of the URL at point, if any. +Value is a pair of positions (START . END) if there is a non-nil +`shr-url' text property at point; otherwise nil." + (when (get-text-property (point) 'shr-url) + (let* ((end (or (next-single-property-change (point) 'shr-url) + (point-max))) + (beg (or (previous-single-property-change end 'shr-url) + (point-min)))) + (cons beg end)))) (defun shr--blink-link () - (let* ((region (shr--current-link-region)) - (overlay (make-overlay (car region) (cadr region)))) + "Briefly fontify URL at point with the face `shr-selected-link'." + (when-let* ((region (shr--current-link-region)) + (overlay (make-overlay (car region) (cdr region)))) (overlay-put overlay 'face 'shr-selected-link) (run-at-time 1 nil (lambda () (delete-overlay overlay))))) @@ -437,7 +457,7 @@ the URL of the image to the kill buffer instead." (if (not url) (message "No image under point") (message "Inserting %s..." url) - (url-retrieve url 'shr-image-fetched + (url-retrieve url #'shr-image-fetched (list (current-buffer) (1- (point)) (point-marker)) t)))) @@ -463,7 +483,7 @@ size, and full-buffer size." (when (> (- (point) start) 2) (delete-region start (1- (point))))) (message "Inserting %s..." url) - (url-retrieve url 'shr-image-fetched + (url-retrieve url #'shr-image-fetched (list (current-buffer) (1- (point)) (point-marker) (list (cons 'size (cond ((or (eq size 'default) @@ -493,7 +513,7 @@ size, and full-buffer size." ((fboundp function) (apply function dom args)) (t - (apply 'shr-generic dom args))))) + (apply #'shr-generic dom args))))) (defun shr-descend (dom) (let ((function @@ -531,13 +551,13 @@ size, and full-buffer size." (funcall function dom)) (t (shr-generic dom))) - (when (and shr-target-id - (equal (dom-attr dom 'id) shr-target-id)) + (when-let* ((id (dom-attr dom 'id))) ;; If the element was empty, we don't have anything to put the ;; anchor on. So just insert a dummy character. (when (= start (point)) - (insert "*")) - (put-text-property start (1+ start) 'shr-target-id shr-target-id)) + (insert ?*) + (put-text-property (1- (point)) (point) 'display "")) + (put-text-property start (1+ start) 'shr-target-id id)) ;; If style is set, then this node has set the color. (when style (shr-colorize-region @@ -730,9 +750,10 @@ size, and full-buffer size." (let ((gap-start (point)) (face (get-text-property (point) 'face))) ;; Extend the background to the end of the line. - (if face - (insert (propertize "\n" 'face (shr-face-background face))) - (insert "\n")) + (insert ?\n) + (when face + (put-text-property (1- (point)) (point) + 'face (shr-face-background face))) (shr-indent) (when (and (> (1- gap-start) (point-min)) (get-text-property (point) 'shr-url) @@ -838,7 +859,7 @@ size, and full-buffer size." ;; Always chop off anchors. (when (string-match "#.*" url) (setq url (substring url 0 (match-beginning 0)))) - ;; NB: <base href="" > URI may itself be relative to the document s URI + ;; NB: <base href=""> URI may itself be relative to the document's URI. (setq url (shr-expand-url url)) (let* ((parsed (url-generic-parse-url url)) (local (url-filename parsed))) @@ -935,12 +956,11 @@ size, and full-buffer size." (defun shr-indent () (when (> shr-indentation 0) - (insert - (if (not shr-use-fonts) - (make-string shr-indentation ?\s) - (propertize " " - 'display - `(space :width (,shr-indentation))))))) + (if (not shr-use-fonts) + (insert-char ?\s shr-indentation) + (insert ?\s) + (put-text-property (1- (point)) (point) + 'display `(space :width (,shr-indentation)))))) (defun shr-fontize-dom (dom &rest types) (let ((start (point))) @@ -987,16 +1007,11 @@ the mouse click event." (cond ((not url) (message "No link under point")) - ((string-match "^mailto:" url) - (browse-url-mail url)) + (external + (funcall browse-url-secondary-browser-function url) + (shr--blink-link)) (t - (if external - (progn - (funcall browse-url-secondary-browser-function url) - (shr--blink-link)) - (browse-url url (if new-window - (not browse-url-new-window-flag) - browse-url-new-window-flag))))))) + (browse-url url (xor new-window browse-url-new-window-flag)))))) (defun shr-save-contents (directory) "Save the contents from URL in a file." @@ -1005,7 +1020,7 @@ the mouse click event." (if (not url) (message "No link under point") (url-retrieve (shr-encode-url url) - 'shr-store-contents (list url directory))))) + #'shr-store-contents (list url directory))))) (defun shr-store-contents (status url directory) (unless (plist-get status :error) @@ -1156,7 +1171,6 @@ width/height instead." ;; url-cache-extract autoloads url-cache. (declare-function url-cache-create-filename "url-cache" (url)) -(autoload 'browse-url-mail "browse-url") (defun shr-get-image-data (url) "Get image data for URL. @@ -1230,7 +1244,7 @@ START, and END. Note that START and END should be markers." (funcall shr-put-image-function image (buffer-substring start end)) (delete-region (point) end)))) - (url-retrieve url 'shr-image-fetched + (url-retrieve url #'shr-image-fetched (list (current-buffer) start end) t t))))) @@ -1265,7 +1279,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 @@ -1438,7 +1454,7 @@ ones, in case fg and bg are nil." (shr-fontize-dom dom 'underline)) (defun shr-tag-code (dom) - (let ((shr-current-font 'default)) + (let ((shr-current-font 'fixed-pitch)) (shr-generic dom))) (defun shr-tag-tt (dom) @@ -1495,14 +1511,13 @@ ones, in case fg and bg are nil." (start (point)) shr-start) (shr-generic dom) - (when (and shr-target-id - (equal (dom-attr dom 'name) shr-target-id)) - ;; We have a zero-length <a name="foo"> element, so just - ;; insert... something. + (when-let* ((id (unless (dom-attr dom 'id) ; Handled by `shr-descend'. + (dom-attr dom 'name)))) ; Obsolete since HTML5. + ;; We have an empty element, so just insert... something. (when (= start (point)) - (shr-ensure-newline) - (insert " ")) - (put-text-property start (1+ start) 'shr-target-id shr-target-id)) + (insert ?\s) + (put-text-property (1- (point)) (point) 'display "")) + (put-text-property start (1+ start) 'shr-target-id id)) (when url (shr-urlify (or shr-start start) (shr-expand-url url) title)))) @@ -1677,7 +1692,7 @@ The preference is a float determined from `shr-prefer-media-type'." (or alt ""))) (insert " ") (url-queue-retrieve - (shr-encode-url url) 'shr-image-fetched + (shr-encode-url url) #'shr-image-fetched (list (current-buffer) start (set-marker (make-marker) (point)) (list :width width :height height)) t @@ -2004,12 +2019,11 @@ BASE is the URL of the HTML being rendered." (cond ((null tbodies) dom) - ((= (length tbodies) 1) + ((null (cdr tbodies)) (car tbodies)) (t ;; Table with multiple tbodies. Convert into a single tbody. - `(tbody nil ,@(cl-reduce 'append - (mapcar 'dom-non-text-children tbodies))))))) + `(tbody nil ,@(mapcan #'dom-non-text-children tbodies)))))) (defun shr--fix-tbody (tbody) (nconc (list 'tbody (dom-attributes tbody)) @@ -2309,8 +2323,8 @@ flags that control whether to collect or render objects." (dolist (column row) (aset natural-widths i (max (aref natural-widths i) column)) (setq i (1+ i))))) - (let ((extra (- (apply '+ (append suggested-widths nil)) - (apply '+ (append widths nil)) + (let ((extra (- (apply #'+ (append suggested-widths nil)) + (apply #'+ (append widths nil)) (* shr-table-separator-pixel-width (1+ (length widths))))) (expanded-columns 0)) ;; We have extra, unused space, so divide this space amongst the @@ -2585,12 +2599,28 @@ flags that control whether to collect or render objects." i)) (defun shr-max-columns (dom) - (let ((max 0)) + (let ((max 0) + (this 0) + (rowspans nil)) (dolist (row (dom-children dom)) (when (and (not (stringp row)) (eq (dom-tag row) 'tr)) - (setq max (max max (+ (shr-count row 'td) - (shr-count row 'th)))))) + (setq this 0) + (dolist (column (dom-children row)) + (when (and (not (stringp column)) + (memq (dom-tag column) '(td th))) + (setq this (+ 1 this (length rowspans))) + ;; We have a rowspan, which we emulate later in rendering + ;; by adding an extra column to the following rows. + (when-let* ((span (dom-attr column 'rowspan))) + (push (string-to-number span) rowspans)))) + (setq max (max max this))) + ;; Count down the rowspans in effect. + (let ((new nil)) + (dolist (span rowspans) + (when (> span 1) + (push (1- span) new))) + (setq rowspans new))) max)) (provide 'shr) diff --git a/lisp/net/telnet.el b/lisp/net/telnet.el index e8c0c1bbdf4..29c415e6a65 100644 --- a/lisp/net/telnet.el +++ b/lisp/net/telnet.el @@ -149,7 +149,7 @@ rejecting one login and prompting again for a username and password.") ((string-match "passw" string) (telnet-filter proc string) (setq telnet-count 0) - (process-send-string proc (concat (comint-read-noecho "Password: " t) + (process-send-string proc (concat (read-passwd "Password: ") telnet-new-line)) (clear-this-command-keys)) (t (telnet-check-software-type-initialize string) diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 5cfcb81708f..49ecaa58ee8 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -35,6 +35,8 @@ (require 'tramp) +(defvar process-file-return-signal-string) + ;;;###tramp-autoload (defcustom tramp-adb-program "adb" "Name of the Android Debug Bridge program." @@ -55,15 +57,27 @@ It is used for TCP/IP devices." "When this method name is used, forward all calls to Android Debug Bridge.") ;;;###tramp-autoload -(defcustom tramp-adb-prompt - "^[[:digit:]]*|?[[:alnum:]\e;[]*@?[[:alnum:]]*[^#\\$]*[#\\$][[:space:]]" +(defcustom tramp-adb-prompt "^[^#$\n\r]*[#$][[:space:]]" "Regexp used as prompt in almquist shell." :type 'regexp - :version "24.4" + :version "28.1" :group 'tramp) +(eval-and-compile + (defconst tramp-adb-ls-date-year-regexp + "[[:digit:]]\\{4\\}-[[:digit:]]\\{2\\}-[[:digit:]]\\{2\\}" + "Regexp for date year format in ls output.")) + +(eval-and-compile + (defconst tramp-adb-ls-date-time-regexp + "[[:digit:]]\\{2\\}:[[:digit:]]\\{2\\}" + "Regexp for date time format in ls output.")) + (defconst tramp-adb-ls-date-regexp - "[[:space:]][0-9]\\{4\\}-[0-9][0-9]-[0-9][0-9][[:space:]][0-9][0-9]:[0-9][0-9][[:space:]]" + (concat + "[[:space:]]" tramp-adb-ls-date-year-regexp + "[[:space:]]" tramp-adb-ls-date-time-regexp + "[[:space:]]") "Regexp for date format in ls output.") (defconst tramp-adb-ls-toolbox-regexp @@ -73,7 +87,8 @@ It is used for TCP/IP devices." "[[:space:]]*\\([^[:space:]]+\\)" ; \2 username "[[:space:]]+\\([^[:space:]]+\\)" ; \3 group "[[:space:]]+\\([[:digit:]]+\\)" ; \4 size - "[[:space:]]+\\([-[:digit:]]+[[:space:]][:[:digit:]]+\\)" ; \5 date + "[[:space:]]+\\(" tramp-adb-ls-date-year-regexp + "[[:space:]]" tramp-adb-ls-date-time-regexp "\\)" ; \5 date "[[:space:]]\\(.*\\)$") ; \6 filename "Regexp for ls output.") @@ -81,8 +96,10 @@ It is used for TCP/IP devices." (tramp--with-startup (add-to-list 'tramp-methods `(,tramp-adb-method - (tramp-tmpdir "/data/local/tmp") - (tramp-default-port 5555))) + (tramp-login-program ,tramp-adb-program) + (tramp-login-args (("shell"))) + (tramp-tmpdir "/data/local/tmp") + (tramp-default-port 5555))) (add-to-list 'tramp-default-host-alist `(,tramp-adb-method nil "")) @@ -136,7 +153,7 @@ It is used for TCP/IP devices." (file-selinux-context . tramp-handle-file-selinux-context) (file-symlink-p . tramp-handle-file-symlink-p) (file-system-info . tramp-adb-handle-file-system-info) - (file-truename . tramp-adb-handle-file-truename) + (file-truename . tramp-handle-file-truename) (file-writable-p . tramp-adb-handle-file-writable-p) (find-backup-file-name . tramp-handle-find-backup-file-name) ;; `get-file-buffer' performed by default handler. @@ -160,6 +177,8 @@ It is used for TCP/IP devices." (start-file-process . tramp-handle-start-file-process) (substitute-in-file-name . tramp-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-get-remote-gid . ignore) + (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) (vc-registered . ignore) @@ -181,10 +200,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 @@ -214,11 +232,10 @@ ARGUMENTS to pass to the OPERATION." (goto-char (point-min)) (forward-line) (when (looking-at - (eval-when-compile - (concat "[[:space:]]*[^[:space:]]+" - "[[:space:]]+\\([[:digit:]]+\\)" - "[[:space:]]+\\([[:digit:]]+\\)" - "[[:space:]]+\\([[:digit:]]+\\)"))) + (concat "[[:space:]]*[^[:space:]]+" + "[[:space:]]+\\([[:digit:]]+\\)" + "[[:space:]]+\\([[:digit:]]+\\)" + "[[:space:]]+\\([[:digit:]]+\\)")) ;; The values are given as 1k numbers, so we must change ;; them to number of bytes. (list (* 1024 (string-to-number (match-string 1))) @@ -228,105 +245,6 @@ ARGUMENTS to pass to the OPERATION." (string-to-number (match-string 2)))) (* 1024 (string-to-number (match-string 3))))))))) -;; This is derived from `tramp-sh-handle-file-truename'. Maybe the -;; code could be shared? -(defun tramp-adb-handle-file-truename (filename) - "Like `file-truename' for Tramp files." - ;; Preserve trailing "/". - (funcall - (if (tramp-compat-directory-name-p filename) - #'file-name-as-directory #'identity) - ;; Quote properly. - (funcall - (if (tramp-compat-file-name-quoted-p filename) - #'tramp-compat-file-name-quote #'identity) - (with-parsed-tramp-file-name - (tramp-compat-file-name-unquote (expand-file-name filename)) nil - (tramp-make-tramp-file-name - v - (with-tramp-file-property v localname "file-truename" - (let (result) ; result steps in reverse order - (tramp-message v 4 "Finding true name for `%s'" filename) - (let* ((steps (split-string localname "/" 'omit)) - (localnamedir (tramp-run-real-handler - 'file-name-as-directory (list localname))) - (is-dir (string= localname localnamedir)) - (thisstep nil) - (numchase 0) - ;; Don't make the following value larger than - ;; necessary. People expect an error message in a - ;; timely fashion when something is wrong; otherwise - ;; they might think that Emacs is hung. Of course, - ;; correctness has to come first. - (numchase-limit 20) - symlink-target) - (while (and steps (< numchase numchase-limit)) - (setq thisstep (pop steps)) - (tramp-message - v 5 "Check %s" - (string-join - (append '("") (reverse result) (list thisstep)) "/")) - (setq symlink-target - (tramp-compat-file-attribute-type - (file-attributes - (tramp-make-tramp-file-name - v - (string-join - (append - '("") (reverse result) (list thisstep)) "/"))))) - (cond ((string= "." thisstep) - (tramp-message v 5 "Ignoring step `.'")) - ((string= ".." thisstep) - (tramp-message v 5 "Processing step `..'") - (pop result)) - ((stringp symlink-target) - ;; It's a symlink, follow it. - (tramp-message v 5 "Follow symlink to %s" symlink-target) - (setq numchase (1+ numchase)) - (when (file-name-absolute-p symlink-target) - (setq result nil)) - ;; If the symlink was absolute, we'll get a string - ;; like "/user@host:/some/target"; extract the - ;; "/some/target" part from it. - (when (tramp-tramp-file-p symlink-target) - (unless (tramp-equal-remote filename symlink-target) - (tramp-error - v 'file-error - "Symlink target `%s' on wrong host" symlink-target)) - (setq symlink-target localname)) - (setq steps - (append (split-string symlink-target "/" 'omit) - steps))) - (t - ;; It's a file. - (setq result (cons thisstep result))))) - (when (>= numchase numchase-limit) - (tramp-error - v 'file-error - "Maximum number (%d) of symlinks exceeded" numchase-limit)) - (setq result (reverse result)) - ;; Combine list to form string. - (setq result - (if result - (string-join (cons "" result) "/") - "/")) - (when (and is-dir (or (string-empty-p result) - (not (string= (substring result -1) "/")))) - (setq result (concat result "/")))) - - ;; Detect cycle. - (when (and (file-symlink-p filename) - (string-equal result localname)) - (tramp-error - v 'file-error - "Apparent cycle of symbolic links for %s" filename)) - ;; If the resulting localname looks remote, we must quote it - ;; for security reasons. - (when (file-remote-p result) - (setq result (tramp-compat-file-name-quote result 'top))) - (tramp-message v 4 "True name of `%s' is `%s'" localname result) - result))))))) - (defun tramp-adb-handle-file-attributes (filename &optional id-format) "Like `file-attributes' for Tramp files." (unless id-format (setq id-format 'integer)) @@ -370,7 +288,9 @@ ARGUMENTS to pass to the OPERATION." (if (eq id-format 'integer) 0 uid) (if (eq id-format 'integer) 0 gid) tramp-time-dont-know ; atime - (date-to-time date) ; mtime + ;; `date-to-time' checks `iso8601-parse', which might fail. + (let (signal-hook-function) + (date-to-time date)) ; mtime tramp-time-dont-know ; ctime size mod-string @@ -449,21 +369,6 @@ ARGUMENTS to pass to the OPERATION." "ls --color=never") (t "ls")))) -(defun tramp-adb--gnu-switches-to-ash (switches) - "Almquist shell can't handle multiple arguments. -Convert (\"-al\") to (\"-a\" \"-l\"). Remove arguments like \"--dired\"." - (split-string - (apply #'concat - (mapcar (lambda (s) - (replace-regexp-in-string - "\\(.\\)" " -\\1" (replace-regexp-in-string "^-" "" s))) - ;; FIXME: Warning about removed switches (long and non-dash). - (delq nil - (mapcar - (lambda (s) - (and (not (string-match-p "\\(^--\\|^[^-]\\)" s)) s)) - switches)))))) - (defun tramp-adb-sh-fix-ls-output (&optional sort-by-time) "Insert dummy 0 in empty size columns. Android's \"ls\" command doesn't insert size column for directories: @@ -473,10 +378,16 @@ Emacs dired can't find files." (goto-char (point-min)) (while (search-forward-regexp - "[[:space:]]\\([[:space:]][0-9]\\{4\\}-[0-9][0-9]-[0-9][0-9][[:space:]]\\)" nil t) + (eval-when-compile + (concat + "[[:space:]]" + "\\([[:space:]]" tramp-adb-ls-date-year-regexp "[[:space:]]\\)")) + nil t) (replace-match "0\\1" "\\1" nil) ;; Insert missing "/". - (when (looking-at-p "[0-9][0-9]:[0-9][0-9][[:space:]]+$") + (when (looking-at-p + (eval-when-compile + (concat tramp-adb-ls-date-time-regexp "[[:space:]]+$"))) (end-of-line) (insert "/"))) ;; Sort entries. @@ -587,9 +498,10 @@ Emacs dired can't find files." (with-tramp-progress-reporter v 3 (format "Fetching %s to tmp file %s" filename tmpfile) ;; "adb pull ..." does not always return an error code. - (when (or (tramp-adb-execute-adb-command - v "pull" (tramp-compat-file-name-unquote localname) tmpfile) - (not (file-exists-p tmpfile))) + (unless + (and (tramp-adb-execute-adb-command + v "pull" (tramp-compat-file-name-unquote localname) tmpfile) + (file-exists-p tmpfile)) (ignore-errors (delete-file tmpfile)) (tramp-error v 'file-error "Cannot make local copy of file `%s'" filename)) @@ -631,9 +543,6 @@ But handle the case, if the \"test\" command is not available." (format "File %s exists; overwrite anyway? " filename))))) (tramp-error v 'file-already-exists filename)) - ;; We must also flush the cache of the directory, because - ;; `file-attributes' reads the values from there. - (tramp-flush-file-properties v localname) (let* ((curbuf (current-buffer)) (tmpfile (tramp-compat-make-temp-file filename))) (when (and append (file-exists-p filename)) @@ -645,11 +554,15 @@ But handle the case, if the \"test\" command is not available." v 3 (format-message "Moving tmp file `%s' to `%s'" tmpfile filename) (unwind-protect - (when (tramp-adb-execute-adb-command - v "push" tmpfile (tramp-compat-file-name-unquote localname)) + (unless (tramp-adb-execute-adb-command + v "push" tmpfile (tramp-compat-file-name-unquote localname)) (tramp-error v 'file-error "Cannot write: `%s'" filename)) (delete-file tmpfile))) + ;; We must also flush the cache of the directory, because + ;; `file-attributes' reads the values from there. + (tramp-flush-file-properties v localname) + (unless (equal curbuf (current-buffer)) (tramp-error v 'file-error @@ -667,13 +580,16 @@ But handle the case, if the \"test\" command is not available." (tramp-message v 0 "Wrote %s" filename)) (run-hooks 'tramp-handle-write-region-hook)))) -(defun tramp-adb-handle-set-file-modes (filename mode) +(defun tramp-adb-handle-set-file-modes (filename mode &optional flag) "Like `set-file-modes' for Tramp files." (with-parsed-tramp-file-name filename nil - (tramp-flush-file-properties v localname) - (tramp-adb-send-command-and-check v (format "chmod %o %s" mode localname)))) + ;; ADB shell does not support "chmod -h". + (unless (and (eq flag 'nofollow) (file-symlink-p filename)) + (tramp-flush-file-properties v localname) + (tramp-adb-send-command-and-check + v (format "chmod %o %s" mode (tramp-shell-quote-argument localname)))))) -(defun tramp-adb-handle-set-file-times (filename &optional time) +(defun tramp-adb-handle-set-file-times (filename &optional time flag) "Like `set-file-times' for Tramp files." (with-parsed-tramp-file-name filename nil (tramp-flush-file-properties v localname) @@ -682,21 +598,23 @@ But handle the case, if the \"test\" command is not available." (tramp-compat-time-equal-p time tramp-time-dont-know)) (current-time) time)) + (nofollow (if (eq flag 'nofollow) "-h" "")) (quoted-name (tramp-shell-quote-argument localname))) ;; Older versions of toybox 'touch' mishandle nanoseconds and/or ;; trailing "Z", so fall back on plain seconds if nanoseconds+Z ;; fails. Also, fall back on old POSIX 'touch -t' if 'touch -d' ;; (introduced in POSIX.1-2008) fails. (tramp-adb-send-command-and-check - v (format (concat "touch -d %s %s 2>/dev/null || " - "touch -d %s %s 2>/dev/null || " - "touch -t %s %s") - (format-time-string "%Y-%m-%dT%H:%M:%S.%NZ" time t) - quoted-name - (format-time-string "%Y-%m-%dT%H:%M:%S" time t) - quoted-name - (format-time-string "%Y%m%d%H%M.%S" time t) - quoted-name))))) + v (format + (concat "touch -d %s %s %s 2>/dev/null || " + "touch -d %s %s %s 2>/dev/null || " + "touch -t %s %s %s") + (format-time-string "%Y-%m-%dT%H:%M:%S.%NZ" time t) + nofollow quoted-name + (format-time-string "%Y-%m-%dT%H:%M:%S" time t) + nofollow quoted-name + (format-time-string "%Y%m%d%H%M.%S" time t) + nofollow quoted-name))))) (defun tramp-adb-handle-copy-file (filename newname &optional ok-if-already-exists keep-date @@ -719,14 +637,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,46 +657,45 @@ 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 + (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) + (unless (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))))))))) + (tramp-error + v 'file-error + "Cannot copy `%s' `%s'" filename newname)))))))) ;; KEEP-DATE handling. (when keep-date - (set-file-times + (tramp-compat-set-file-times newname (tramp-compat-file-attribute-modification-time - (file-attributes filename)))))) + (file-attributes filename)) + (unless ok-if-already-exists 'nofollow))))) (defun tramp-adb-handle-rename-file (filename newname &optional ok-if-already-exists) @@ -801,7 +718,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 +726,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) @@ -828,6 +745,33 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." filename newname ok-if-already-exists 'keep-time 'preserve-uid-gid) (delete-file filename))))))) +(defun tramp-adb-get-signal-strings (vec) + "Strings to return by `process-file' in case of signals." + (with-tramp-connection-property vec "signal-strings" + (let ((default-directory (tramp-make-tramp-file-name vec 'localname)) + ;; `shell-file-name' and `shell-command-switch' are needed + ;; for Emacs < 27.1, which doesn't support connection-local + ;; variables in `shell-command'. + (shell-file-name "/system/bin/sh") + (shell-command-switch "-c") + process-file-return-signal-string signals result) + (dotimes (i 128) (push (format "Signal %d" i) result)) + (setq result (reverse result) + signals (split-string + (shell-command-to-string "COLUMNS=40 kill -l") "\n" 'omit)) + (setcar result 0) + (dolist (line signals) + (when (string-match + (concat + "^[[:space:]]*\\([[:digit:]]+\\)" + "[[:space:]]+\\S-+[[:space:]]+" + "\\([[:alpha:]].*\\)$") + line) + (setcar + (nthcdr (string-to-number (match-string 1 line)) result) + (match-string 2 line)))) + result))) + (defun tramp-adb-handle-process-file (program &optional infile destination display &rest args) "Like `process-file' for Tramp files." @@ -846,7 +790,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 +821,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) @@ -895,14 +838,13 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; it. Call it in a subshell, in order to preserve working ;; directory. (condition-case nil - (progn - (setq ret - (if (tramp-adb-send-command-and-check - v - (format "(cd %s; %s)" - (tramp-shell-quote-argument localname) command)) - ;; Set return status accordingly. - 0 1)) + (unwind-protect + (setq ret (tramp-adb-send-command-and-check + v (format + "(cd %s; %s)" + (tramp-shell-quote-argument localname) command) + t)) + (unless (natnump ret) (setq ret 1)) ;; We should add the output anyway. (when outbuf (with-current-buffer outbuf @@ -918,6 +860,12 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (kill-buffer (tramp-get-connection-buffer v)) (setq ret 1))) + ;; Handle signals. `process-file-return-signal-string' exists + ;; since Emacs 28.1. + (when (and (bound-and-true-p process-file-return-signal-string) + (natnump ret) (> ret 128)) + (setq ret (nth (- ret 128) (tramp-adb-get-signal-strings v)))) + ;; Provide error file. (when tmpstderr (rename-file tmpstderr (cadr destination) t)) @@ -936,124 +884,171 @@ 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 - (with-parsed-tramp-file-name (expand-file-name default-directory) nil - (let ((name (plist-get args :name)) - (buffer (plist-get args :buffer)) - (command (plist-get args :command)) - (coding (plist-get args :coding)) - (noquery (plist-get args :noquery)) - (connection-type (plist-get args :connection-type)) - (filter (plist-get args :filter)) - (sentinel (plist-get args :sentinel)) - (stderr (plist-get args :stderr))) - (unless (stringp name) - (signal 'wrong-type-argument (list #'stringp name))) - (unless (or (null buffer) (bufferp buffer) (stringp buffer)) - (signal 'wrong-type-argument (list #'stringp buffer))) - (unless (consp command) - (signal 'wrong-type-argument (list #'consp command))) - (unless (or (null coding) - (and (symbolp coding) (memq coding coding-system-list)) - (and (consp coding) - (memq (car coding) coding-system-list) - (memq (cdr coding) coding-system-list))) - (signal 'wrong-type-argument (list #'symbolp coding))) - (unless (or (null connection-type) (memq connection-type '(pipe pty))) - (signal 'wrong-type-argument (list #'symbolp connection-type))) - (unless (or (null filter) (functionp filter)) - (signal 'wrong-type-argument (list #'functionp filter))) - (unless (or (null sentinel) (functionp sentinel)) - (signal 'wrong-type-argument (list #'functionp sentinel))) - (unless (or (null stderr) (bufferp stderr) (stringp stderr)) - (signal 'wrong-type-argument (list #'stringp stderr))) - - (let* ((buffer - (if buffer - (get-buffer-create buffer) - ;; BUFFER can be nil. We use a temporary buffer. - (generate-new-buffer tramp-temp-buffer-name))) - (program (car command)) - (args (cdr command)) - (command - (format "cd %s && exec %s" - (tramp-shell-quote-argument localname) - (mapconcat #'tramp-shell-quote-argument - (cons program args) " "))) - (tramp-process-connection-type - (or (null program) tramp-process-connection-type)) - (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer))) - (name1 name) - (i 0)) - - (while (get-process name1) - ;; NAME must be unique as process name. - (setq i (1+ i) - name1 (format "%s<%d>" name i))) - (setq name name1) - ;; Set the new process properties. - (tramp-set-connection-property v "process-name" name) - (tramp-set-connection-property v "process-buffer" buffer) - - (with-current-buffer (tramp-get-connection-buffer v) - (unwind-protect - ;; We catch this event. Otherwise, `make-process' - ;; could be called on the local host. - (save-excursion - (save-restriction - ;; Activate narrowing in order to save BUFFER - ;; contents. Clear also the modification time; - ;; otherwise we might be interrupted by - ;; `verify-visited-file-modtime'. - (let ((buffer-undo-list t) - (inhibit-read-only t)) - (clear-visited-file-modtime) - (narrow-to-region (point-max) (point-max)) - ;; We call `tramp-adb-maybe-open-connection', in - ;; order to cleanup the prompt afterwards. - (tramp-adb-maybe-open-connection v) - (delete-region (point-min) (point-max)) - ;; Send the command. - (let* ((p (tramp-get-connection-process v))) - (tramp-adb-send-command v command nil t) ; nooutput - ;; Set sentinel and filter. - (when sentinel - (set-process-sentinel p sentinel)) - (when filter - (set-process-filter p filter)) - ;; Set query flag and process marker for this - ;; process. We ignore errors, because the - ;; process could have finished already. - (ignore-errors - (set-process-query-on-exit-flag p (null noquery)) - (set-marker (process-mark p) (point))) - ;; Read initial output. Remove the first line, - ;; which is the command echo. - (while - (progn - (goto-char (point-min)) - (not (re-search-forward "[\n]" nil t))) - (tramp-accept-process-output p 0)) - (delete-region (point-min) (point)) - ;; Return process. - p)))) - - ;; Save exit. - (if (string-match-p tramp-temp-buffer-name (buffer-name)) - (ignore-errors - (set-process-buffer (tramp-get-connection-process v) nil) - (kill-buffer (current-buffer))) - (set-buffer-modified-p bmp)) - (tramp-flush-connection-property v "process-name") - (tramp-flush-connection-property v "process-buffer")))))))) + "Like `make-process' for Tramp files. +If connection property \"direct-async-process\" is non-nil, an +alternative implementation will be used." + (if (tramp-direct-async-process-p args) + (apply #'tramp-handle-make-process args) + (when args + (with-parsed-tramp-file-name (expand-file-name default-directory) nil + (let ((name (plist-get args :name)) + (buffer (plist-get args :buffer)) + (command (plist-get args :command)) + (coding (plist-get args :coding)) + (noquery (plist-get args :noquery)) + (connection-type (plist-get args :connection-type)) + (filter (plist-get args :filter)) + (sentinel (plist-get args :sentinel)) + (stderr (plist-get args :stderr))) + (unless (stringp name) + (signal 'wrong-type-argument (list #'stringp name))) + (unless (or (null buffer) (bufferp buffer) (stringp buffer)) + (signal 'wrong-type-argument (list #'stringp buffer))) + (unless (consp command) + (signal 'wrong-type-argument (list #'consp command))) + (unless (or (null coding) + (and (symbolp coding) (memq coding coding-system-list)) + (and (consp coding) + (memq (car coding) coding-system-list) + (memq (cdr coding) coding-system-list))) + (signal 'wrong-type-argument (list #'symbolp coding))) + (unless (or (null connection-type) (memq connection-type '(pipe pty))) + (signal 'wrong-type-argument (list #'symbolp connection-type))) + (unless (or (null filter) (functionp filter)) + (signal 'wrong-type-argument (list #'functionp filter))) + (unless (or (null sentinel) (functionp sentinel)) + (signal 'wrong-type-argument (list #'functionp sentinel))) + (unless (or (null stderr) (bufferp stderr) (stringp stderr)) + (signal 'wrong-type-argument (list #'stringp stderr))) + (when (and (stringp stderr) (tramp-tramp-file-p stderr) + (not (tramp-equal-remote default-directory stderr))) + (signal 'file-error (list "Wrong stderr" stderr))) + + (let* ((buffer + (if buffer + (get-buffer-create buffer) + ;; BUFFER can be nil. We use a temporary buffer. + (generate-new-buffer tramp-temp-buffer-name))) + ;; STDERR can also be a file name. + (tmpstderr + (and stderr + (if (and (stringp stderr) (tramp-tramp-file-p stderr)) + (tramp-unquote-file-local-name stderr) + (tramp-make-tramp-temp-file v)))) + (remote-tmpstderr + (and tmpstderr (tramp-make-tramp-file-name v tmpstderr))) + (program (car command)) + (args (cdr command)) + (command + (format "cd %s && exec %s %s" + (tramp-shell-quote-argument localname) + (if tmpstderr (format "2>'%s'" tmpstderr) "") + (mapconcat #'tramp-shell-quote-argument + (cons program args) " "))) + (tramp-process-connection-type + (or (null program) tramp-process-connection-type)) + (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer))) + (name1 name) + (i 0)) + + (while (get-process name1) + ;; NAME must be unique as process name. + (setq i (1+ i) + name1 (format "%s<%d>" name i))) + (setq name name1) + ;; Set the new process properties. + (tramp-set-connection-property v "process-name" name) + (tramp-set-connection-property v "process-buffer" buffer) + + (with-current-buffer (tramp-get-connection-buffer v) + (unwind-protect + ;; We catch this event. Otherwise, `make-process' + ;; could be called on the local host. + (save-excursion + (save-restriction + ;; Activate narrowing in order to save BUFFER + ;; contents. Clear also the modification time; + ;; otherwise we might be interrupted by + ;; `verify-visited-file-modtime'. + (let ((buffer-undo-list t) + (inhibit-read-only t)) + (clear-visited-file-modtime) + (narrow-to-region (point-max) (point-max)) + ;; We call `tramp-adb-maybe-open-connection', + ;; in order to cleanup the prompt afterwards. + (tramp-adb-maybe-open-connection v) + (delete-region (point-min) (point-max)) + ;; Send the command. + (let* ((p (tramp-get-connection-process v))) + (tramp-adb-send-command v command nil t) ; nooutput + ;; Set sentinel and filter. + (when sentinel + (set-process-sentinel p sentinel)) + (when filter + (set-process-filter p filter)) + ;; Set query flag and process marker for + ;; this process. We ignore errors, because + ;; the process could have finished already. + (ignore-errors + (set-process-query-on-exit-flag p (null noquery)) + (set-marker (process-mark p) (point))) + ;; We must flush them here already; + ;; otherwise `rename-file', `delete-file' or + ;; `insert-file-contents' will fail. + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer") + ;; Copy tmpstderr file. + (when (and (stringp stderr) + (not (tramp-tramp-file-p stderr))) + (add-function + :after (process-sentinel p) + (lambda (_proc _msg) + (rename-file remote-tmpstderr stderr)))) + ;; Read initial output. Remove the first + ;; line, which is the command echo. + (while + (progn + (goto-char (point-min)) + (not (re-search-forward "[\n]" nil t))) + (tramp-accept-process-output p 0)) + (delete-region (point-min) (point)) + ;; Provide error buffer. This shows only + ;; initial error messages; messages arriving + ;; later on will be inserted when the + ;; process is deleted. The temporary file + ;; will exist until the process is deleted. + (when (bufferp stderr) + (with-current-buffer stderr + (insert-file-contents-literally + remote-tmpstderr 'visit)) + ;; Delete tmpstderr file. + (add-function + :after (process-sentinel p) + (lambda (_proc _msg) + (with-current-buffer stderr + (insert-file-contents-literally + remote-tmpstderr 'visit nil nil 'replace)) + (delete-file remote-tmpstderr)))) + ;; Return process. + p)))) + + ;; Save exit. + (if (string-match-p tramp-temp-buffer-name (buffer-name)) + (ignore-errors + (set-process-buffer (tramp-get-connection-process v) nil) + (kill-buffer (current-buffer))) + (set-buffer-modified-p bmp)) + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer"))))))))) (defun tramp-adb-handle-exec-path () "Like `exec-path' for Tramp files." (append (with-parsed-tramp-file-name default-directory nil - (with-tramp-connection-property v "remote-path" + (with-tramp-connection-property (tramp-get-process v) "remote-path" (tramp-adb-send-command v "echo \\\"$PATH\\\"") (split-string (with-current-buffer (tramp-get-connection-buffer v) @@ -1062,17 +1057,13 @@ 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. E.g. a host name \"192.168.1.1#5555\" returns \"192.168.1.1:5555\" a host name \"R38273882DE\" returns \"R38273882DE\"." - ;; Sometimes this is called before there is a connection process - ;; yet. In order to work with the connection cache, we flush all - ;; unwanted entries first. - (tramp-flush-connection-properties nil) - (with-tramp-connection-property (tramp-get-connection-process vec) "device" + (with-tramp-connection-property (tramp-get-process vec) "device" (let* ((host (tramp-file-name-host vec)) (port (tramp-file-name-port-or-default vec)) (devices (mapcar #'cadr (tramp-adb-parse-device-names nil)))) @@ -1090,10 +1081,10 @@ E.g. a host name \"192.168.1.1#5555\" returns \"192.168.1.1:5555\" ;; Try to connect device. ((and tramp-adb-connect-if-not-connected (not (zerop (length host))) - (not (tramp-adb-execute-adb-command - vec "connect" - (replace-regexp-in-string - tramp-prefix-port-format ":" host)))) + (tramp-adb-execute-adb-command + vec "connect" + (replace-regexp-in-string + tramp-prefix-port-format ":" host))) ;; When new device connected, running other adb command (e.g. ;; adb shell) immediately will fail. To get around this ;; problem, add sleep 0.1 second here. @@ -1103,18 +1094,18 @@ E.g. a host name \"192.168.1.1#5555\" returns \"192.168.1.1:5555\" vec 'file-error "Could not find device %s" host))))))) (defun tramp-adb-execute-adb-command (vec &rest args) - "Return nil on success error-output on failure." + "Execute an adb command. +Insert the result into the connection buffer. Return nil on +error and non-nil on success." (when (and (> (length (tramp-file-name-host vec)) 0) ;; The -s switch is only available for ADB device commands. (not (member (car args) '("connect" "disconnect")))) (setq args (append (list "-s" (tramp-adb-get-device vec)) args))) - (with-temp-buffer - (prog1 - (unless - (zerop - (apply #'tramp-call-process vec tramp-adb-program nil t nil args)) - (buffer-string)) - (tramp-message vec 6 "%s" (buffer-string))))) + (with-current-buffer (tramp-get-connection-buffer vec) + ;; Clean up the buffer. We cannot call `erase-buffer' because + ;; narrowing might be in effect. + (let ((inhibit-read-only t)) (delete-region (point-min) (point-max))) + (zerop (apply #'tramp-call-process vec tramp-adb-program nil t nil args)))) (defun tramp-adb-find-test-command (vec) "Check whether the ash has a builtin \"test\" command. @@ -1126,42 +1117,52 @@ This happens for Android >= 4.0." (defun tramp-adb-send-command (vec command &optional neveropen nooutput) "Send the COMMAND to connection VEC." - (unless neveropen (tramp-adb-maybe-open-connection vec)) - (tramp-message vec 6 "%s" command) - (tramp-send-string vec command) - (unless nooutput - ;; FIXME: Race condition. - (tramp-adb-wait-for-output (tramp-get-connection-process vec)) - (with-current-buffer (tramp-get-connection-buffer vec) - (save-excursion - (goto-char (point-min)) - ;; We can't use stty to disable echo of command. stty is said - ;; to be added to toybox 0.7.6. busybox shall have it, but this - ;; isn't used any longer for Android. - (delete-matching-lines (regexp-quote command)) - ;; When the local machine is W32, there are still trailing ^M. - ;; There must be a better solution by setting the correct coding - ;; system, but this requires changes in core Tramp. - (goto-char (point-min)) - (while (re-search-forward "\r+$" nil t) - (replace-match "" nil nil)))))) + (if (string-match-p "[[:multibyte:]]" command) + ;; Multibyte codepoints with four bytes are not supported at + ;; least by toybox. + (tramp-adb-execute-adb-command vec "shell" command) + + (unless neveropen (tramp-adb-maybe-open-connection vec)) + (tramp-message vec 6 "%s" command) + (tramp-send-string vec command) + (unless nooutput + ;; FIXME: Race condition. + (tramp-adb-wait-for-output (tramp-get-connection-process vec)) + (with-current-buffer (tramp-get-connection-buffer vec) + (save-excursion + (goto-char (point-min)) + ;; We can't use stty to disable echo of command. stty is said + ;; to be added to toybox 0.7.6. busybox shall have it, but this + ;; isn't used any longer for Android. + (delete-matching-lines (regexp-quote command)) + ;; When the local machine is W32, there are still trailing ^M. + ;; There must be a better solution by setting the correct coding + ;; system, but this requires changes in core Tramp. + (goto-char (point-min)) + (while (re-search-forward "\r+$" nil t) + (replace-match "" nil nil))))))) -(defun tramp-adb-send-command-and-check (vec command) +(defun tramp-adb-send-command-and-check (vec command &optional exit-status) "Run COMMAND and check its exit status. Sends `echo $?' along with the COMMAND for checking the exit status. If COMMAND is nil, just sends `echo $?'. Returns nil if -the exit status is not equal 0, and t otherwise." +the exit status is not equal 0, and t otherwise. + +Optional argument EXIT-STATUS, if non-nil, triggers the return of +the exit status." (tramp-adb-send-command vec (if command (format "%s; echo tramp_exit_status $?" command) "echo tramp_exit_status $?")) (with-current-buffer (tramp-get-connection-buffer vec) - (unless (tramp-search-regexp "tramp_exit_status [0-9]+") + (unless (tramp-search-regexp "tramp_exit_status [[:digit:]]+") (tramp-error vec 'file-error "Couldn't find exit status of `%s'" command)) (skip-chars-forward "^ ") (prog1 - (zerop (read (current-buffer))) + (if exit-status + (read (current-buffer)) + (zerop (read (current-buffer)))) (let ((inhibit-read-only t)) (delete-region (match-beginning 0) (point-max)))))) @@ -1258,12 +1259,24 @@ connection if a previous connection has died for some reason." (tramp-adb-send-command vec (format "PS1=\"///\"\"%s\"\"#$\"" prompt)) + ;; Disable line editing. + (tramp-adb-send-command + vec "set +o vi +o vi-esccomplete +o vi-tabcomplete +o emacs") + + ;; Dump option settings in the traces. + (when (>= tramp-verbose 9) + (tramp-adb-send-command vec "set -o")) + ;; Check whether the properties have been changed. If ;; yes, this is a strong indication that we must expire all ;; connection properties. We start again. (tramp-message vec 5 "Checking system information") (tramp-adb-send-command - vec "echo \\\"`getprop ro.product.model` `getprop ro.product.version` `getprop ro.build.version.release`\\\"") + vec + (concat + "echo \\\"`getprop ro.product.model` " + "`getprop ro.product.version` " + "`getprop ro.build.version.release`\\\"")) (let ((old-getprop (tramp-get-connection-property vec "getprop" nil)) (new-getprop @@ -1287,7 +1300,8 @@ connection if a previous connection has died for some reason." (tramp-adb-send-command vec (format "su %s" user)) (unless (tramp-adb-send-command-and-check vec nil) (delete-process p) - (tramp-flush-file-property vec "" "su-command-p") + ;; Do not flush, we need the nil value. + (tramp-set-file-property vec "" "su-command-p" nil) (tramp-error vec 'file-error "Cannot switch to user `%s'" user))) @@ -1321,4 +1335,9 @@ connection if a previous connection has died for some reason." (provide 'tramp-adb) +;;; TODO: +;; +;; * Support file names with multibyte codepoints. Use as fallback +;; "adb shell COMMAND". +;; ;;; tramp-adb.el ends here diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index b9bf6180a5d..9502cc35300 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -109,7 +109,7 @@ (eval-when-compile (require 'cl-lib)) ;; Sometimes, compilation fails with "Variable binding depth exceeds -;; max-specpdl-size". +;; max-specpdl-size". Shall be fixed in Emacs 27. (eval-and-compile (let ((max-specpdl-size (* 2 max-specpdl-size))) (require 'tramp-gvfs))) @@ -279,7 +279,9 @@ It must be supported by libarchive(3).") (start-file-process . tramp-archive-handle-not-implemented) ;; `substitute-in-file-name' performed by default handler. (temporary-file-directory . tramp-archive-handle-temporary-file-directory) - ;; `tramp-set-file-uid-gid' performed by default handler. + (tramp-get-remote-gid . ignore) + (tramp-get-remote-uid . ignore) + (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) @@ -318,7 +320,10 @@ arguments to pass to the OPERATION." (let* ((filename (apply #'tramp-archive-file-name-for-operation operation args)) - (archive (tramp-archive-file-name-archive filename))) + (archive (tramp-archive-file-name-archive filename)) + ;; Sometimes, it fails with "Variable binding depth exceeds + ;; max-specpdl-size". Shall be fixed in Emacs 27. + (max-specpdl-size (* 2 max-specpdl-size))) ;; `filename' could be a quoted file name. Or the file ;; archive could be a directory, see Bug#30293. @@ -350,7 +355,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 +371,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 +522,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..970e2eea0ac 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -31,13 +31,13 @@ ;; a process, has a unique cache. We distinguish 4 kind of caches, ;; depending on the key: ;; -;; - localname is NIL. This are reusable properties. Examples: +;; - localname is nil. These are reusable properties. Examples: ;; "remote-shell" identifies the POSIX shell to be called on the ;; remote host, or "perl" is the command to be called on the remote ;; host when starting a Perl script. These properties are saved in ;; the file `tramp-persistency-file-name'. ;; -;; - localname is a string. This are temporary properties, which are +;; - localname is a string. These are temporary properties, which are ;; related to the file localname is referring to. Examples: ;; "file-exists-p" is t or nil, depending on the file existence, or ;; "file-attributes" caches the result of the function @@ -45,21 +45,32 @@ ;; expire after `remote-file-name-inhibit-cache' seconds if this ;; variable is set. ;; -;; - The key is a process. This are temporary properties related to +;; - The key is a process. These are temporary properties related to ;; an open connection. Examples: "scripts" keeps shell script ;; definitions already sent to the remote shell, "last-cmd-time" is ;; the time stamp a command has been sent to the remote process. ;; -;; - The key is nil. This are temporary properties related to the +;; - The key is nil. These are temporary properties related to the ;; local machine. Examples: "parse-passwd" and "parse-group" keep ;; the results of parsing "/etc/passwd" and "/etc/group", ;; "{uid,gid}-{integer,string}" are the local uid and gid, and ;; "locale" is the used shell locale. +;; +;; - The key is `tramp-cache-undefined'. All functions return the +;; expected values, but nothing is cached. ;; Some properties are handled special: ;; ;; - "process-name", "process-buffer" and "first-password-request" are -;; not saved in the file `tramp-persistency-file-name'. +;; not saved in the file `tramp-persistency-file-name', although +;; being connection properties related to a `tramp-file-name' +;; structure. +;; +;; - Reusable properties, which should not be saved, are kept in the +;; process key retrieved by `tramp-get-process' (the main connection +;; process). Other processes could reuse these properties, avoiding +;; recomputation when a new asynchronous process is created by +;; `make-process'. Examples are "remote-path" or "device" (tramp-adb.el). ;;; Code: @@ -96,25 +107,31 @@ details see the info pages." (defvar tramp-cache-data-changed nil "Whether persistent cache data have been changed.") +;;;###tramp-autoload +(defconst tramp-cache-undefined 'undef + "The symbol marking undefined hash keys and values.") + (defun tramp-get-hash-table (key) "Return the hash table for KEY. If it doesn't exist yet, it is created and initialized with -matching entries of `tramp-connection-properties'." - (or (gethash key tramp-cache-data) - (let ((hash - (puthash key (make-hash-table :test #'equal) tramp-cache-data))) - (when (tramp-file-name-p key) - (dolist (elt tramp-connection-properties) - (when (string-match-p - (or (nth 0 elt) "") - (tramp-make-tramp-file-name key 'noloc 'nohop)) - (tramp-set-connection-property key (nth 1 elt) (nth 2 elt))))) - hash))) +matching entries of `tramp-connection-properties'. +If KEY is `tramp-cache-undefined', don't create anything, and return nil." + (unless (eq key tramp-cache-undefined) + (or (gethash key tramp-cache-data) + (let ((hash + (puthash key (make-hash-table :test #'equal) tramp-cache-data))) + (when (tramp-file-name-p key) + (dolist (elt tramp-connection-properties) + (when (string-match-p + (or (nth 0 elt) "") + (tramp-make-tramp-file-name key 'noloc 'nohop)) + (tramp-set-connection-property key (nth 1 elt) (nth 2 elt))))) + hash)))) ;;;###tramp-autoload (defun tramp-get-file-property (key file property default) "Get the PROPERTY of FILE from the cache context of KEY. -Returns DEFAULT if not set." +Return DEFAULT if not set." ;; Unify localname. Remove hop from `tramp-file-name' structure. (setq file (tramp-compat-file-name-unquote file) key (copy-tramp-file-name key)) @@ -122,31 +139,32 @@ Returns DEFAULT if not set." (tramp-run-real-handler #'directory-file-name (list file)) (tramp-file-name-hop key) nil) (let* ((hash (tramp-get-hash-table key)) - (value (when (hash-table-p hash) (gethash property hash)))) - (if ;; We take the value only if there is any, and - ;; `remote-file-name-inhibit-cache' indicates that it is still - ;; valid. Otherwise, DEFAULT is set. - (and (consp value) + (cached (and (hash-table-p hash) (gethash property hash))) + (cached-at (and (consp cached) (format-time-string "%T" (car cached)))) + (value default) + cache-used) + + (when ;; We take the value only if there is any, and + ;; `remote-file-name-inhibit-cache' indicates that it is + ;; still valid. Otherwise, DEFAULT is set. + (and (consp cached) (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 cached) remote-file-name-inhibit-cache))) (and (consp remote-file-name-inhibit-cache) (time-less-p - remote-file-name-inhibit-cache (car value))))) - (setq value (cdr value)) - (setq value default)) + remote-file-name-inhibit-cache (car cached))))) + (setq value (cdr cached) + cache-used t)) - (tramp-message key 8 "%s %s %s" file property value) + (tramp-message + key 8 "%s %s %s; inhibit: %s; cache used: %s; cached at: %s" + file property value remote-file-name-inhibit-cache cache-used cached-at) (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))) @@ -157,7 +175,7 @@ Returns DEFAULT if not set." ;;;###tramp-autoload (defun tramp-set-file-property (key file property value) "Set the PROPERTY of FILE to VALUE, in the cache context of KEY. -Returns VALUE." +Return VALUE." ;; Unify localname. Remove hop from `tramp-file-name' structure. (setq file (tramp-compat-file-name-unquote file) key (copy-tramp-file-name key)) @@ -170,7 +188,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 +220,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 +255,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)))) @@ -292,8 +306,9 @@ This is suppressed for temporary buffers." "Get the named PROPERTY for the connection. KEY identifies the connection, it is either a process or a `tramp-file-name' structure. A special case is nil, which is -used to cache connection properties of the local machine. If the -value is not set for the connection, returns DEFAULT." +used to cache connection properties of the local machine. +If KEY is `tramp-cache-undefined', or if the value is not set for +the connection, return DEFAULT." ;; Unify key by removing localname and hop from `tramp-file-name' ;; structure. Work with a copy in order to avoid side effects. (when (tramp-file-name-p key) @@ -301,15 +316,19 @@ value is not set for the connection, returns DEFAULT." (setf (tramp-file-name-localname key) nil (tramp-file-name-hop key) nil)) (let* ((hash (tramp-get-hash-table key)) - (value - ;; If the key is an auxiliary process object, check whether - ;; the process is still alive. - (if (and (processp key) (not (process-live-p key))) - default - (if (hash-table-p hash) - (gethash property hash default) - default)))) - (tramp-message key 7 "%s %s" property value) + (cached (if (hash-table-p hash) + (gethash property hash tramp-cache-undefined) + tramp-cache-undefined)) + (value default) + cache-used) + + (when (and (not (eq cached tramp-cache-undefined)) + ;; If the key is an auxiliary process object, check + ;; whether the process is still alive. + (not (and (processp key) (not (process-live-p key))))) + (setq value cached + cache-used t)) + (tramp-message key 7 "%s %s; cache used: %s" property value cache-used) value)) ;;;###tramp-autoload @@ -317,19 +336,22 @@ value is not set for the connection, returns DEFAULT." "Set the named PROPERTY of a connection to VALUE. KEY identifies the connection, it is either a process or a `tramp-file-name' structure. A special case is nil, which is -used to cache connection properties of the local machine. -PROPERTY is set persistent when KEY is a `tramp-file-name' structure." +used to cache connection properties of the local machine. If KEY +is `tramp-cache-undefined', nothing is set. +PROPERTY is set persistent when KEY is a `tramp-file-name' structure. +Return VALUE." ;; Unify key by removing localname and hop from `tramp-file-name' ;; structure. Work with a copy in order to avoid side effects. (when (tramp-file-name-p key) (setq key (copy-tramp-file-name key)) (setf (tramp-file-name-localname key) nil (tramp-file-name-hop key) nil)) - (let ((hash (tramp-get-hash-table key))) - (puthash property value hash) - (setq tramp-cache-data-changed t) - (tramp-message key 7 "%s %s" property value) - value)) + (when-let ((hash (tramp-get-hash-table key))) + (puthash property value hash)) + (setq tramp-cache-data-changed + (or tramp-cache-data-changed (tramp-file-name-p key))) + (tramp-message key 7 "%s %s" property value) + value) ;;;###tramp-autoload (defun tramp-connection-property-p (key property) @@ -337,7 +359,8 @@ PROPERTY is set persistent when KEY is a `tramp-file-name' structure." KEY identifies the connection, it is either a process or a `tramp-file-name' structure. A special case is nil, which is used to cache connection properties of the local machine." - (not (eq (tramp-get-connection-property key property 'undef) 'undef))) + (not (eq (tramp-get-connection-property key property tramp-cache-undefined) + tramp-cache-undefined))) ;;;###tramp-autoload (defun tramp-flush-connection-property (key property) @@ -352,8 +375,10 @@ PROPERTY is set persistent when KEY is a `tramp-file-name' structure." (setq key (copy-tramp-file-name key)) (setf (tramp-file-name-localname key) nil (tramp-file-name-hop key) nil)) - (remhash property (tramp-get-hash-table key)) - (setq tramp-cache-data-changed t) + (when-let ((hash (tramp-get-hash-table key))) + (remhash property hash)) + (setq tramp-cache-data-changed + (or tramp-cache-data-changed (tramp-file-name-p key))) (tramp-message key 7 "%s" property)) ;;;###tramp-autoload @@ -370,12 +395,10 @@ 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)) - (setq tramp-cache-data-changed t) + (when-let ((hash (gethash key tramp-cache-data))) + (hash-table-keys hash))) + (setq tramp-cache-data-changed + (or tramp-cache-data-changed (tramp-file-name-p key))) (remhash key tramp-cache-data)) ;;;###tramp-autoload @@ -386,20 +409,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,18 +439,18 @@ 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'." + "Write persistent connection properties into file \ +`tramp-persistency-file-name'." ;; We shouldn't fail, otherwise Emacs might not be able to be closed. (ignore-errors (when (and (hash-table-p tramp-cache-data) @@ -464,15 +482,10 @@ used to cache connection properties of the local machine." ;; Dump it. (with-temp-file tramp-persistency-file-name (insert - ";; -*- emacs-lisp -*-" - ;; `time-stamp-string' might not exist in all Emacs flavors. - (condition-case nil - (progn - (format - " <%s %s>\n" - (time-stamp-string "%02y/%02m/%02d %02H:%02M:%02S") - tramp-persistency-file-name)) - (error "\n")) + ;; Starting with Emacs 28, we could use `lisp-data'. + (format ";; -*- emacs-lisp -*- <%s %s>\n" + (time-stamp-string "%02y/%02m/%02d %02H:%02M:%02S") + tramp-persistency-file-name) ";; Tramp connection history. Don't change this file.\n" ";; Run `M-x tramp-cleanup-all-connections' instead.\n\n" (with-output-to-string @@ -490,17 +503,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 +524,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..52cc186ecf7 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -74,11 +74,13 @@ SYNTAX can be one of the symbols `default' (default), Each function is called with the current vector as argument.") ;;;###tramp-autoload -(defun tramp-cleanup-connection (vec &optional keep-debug keep-password) +(defun tramp-cleanup-connection + (vec &optional keep-debug keep-password keep-processes) "Flush all connection related objects. This includes password cache, file cache, connection cache, -buffers. KEEP-DEBUG non-nil preserves the debug buffer. -KEEP-PASSWORD non-nil preserves the password cache. +buffers, processes. KEEP-DEBUG non-nil preserves the debug +buffer. KEEP-PASSWORD non-nil preserves the password cache. +KEEP-PROCESSES non-nil preserves the asynchronous processes. When called interactively, a Tramp connection has to be selected." (interactive ;; When interactive, select the Tramp remote identification. @@ -107,21 +109,21 @@ When called interactively, a Tramp connection has to be selected." ;; suppressed. (setq tramp-current-connection nil) - ;; Flush file cache. - (tramp-flush-directory-properties vec "") - - ;; Flush connection cache. - (when (processp (tramp-get-connection-process vec)) - (tramp-flush-connection-properties (tramp-get-connection-process vec)) - (delete-process (tramp-get-connection-process vec))) - (tramp-flush-connection-properties vec) - ;; Cancel timer. (dolist (timer timer-list) (when (and (eq (timer--function timer) 'tramp-timeout-session) (tramp-file-name-equal-p vec (car (timer--args timer)))) (cancel-timer timer))) + ;; Delete processes. + (dolist (key (hash-table-keys tramp-cache-data)) + (when (and (processp key) + (tramp-file-name-equal-p (process-get key 'vector) vec) + (or (not keep-processes) + (eq key (tramp-get-process vec)))) + (tramp-flush-connection-properties key) + (delete-process key))) + ;; Remove buffers. (dolist (buf (list (get-buffer (tramp-buffer-name vec)) @@ -130,6 +132,12 @@ When called interactively, a Tramp connection has to be selected." (tramp-get-connection-property vec "process-buffer" nil))) (when (bufferp buf) (kill-buffer buf))) + ;; Flush file cache. + (tramp-flush-directory-properties vec "") + + ;; Flush connection cache. + (tramp-flush-connection-properties vec) + ;; The end. (run-hook-with-args 'tramp-cleanup-connection-hook vec))) @@ -176,8 +184,9 @@ This includes password cache, file cache, connection cache, buffers." ;; Cancel timers. (cancel-function-timers 'tramp-timeout-session) - ;; Remove buffers. + ;; Remove processes and buffers. (dolist (name (tramp-list-tramp-buffers)) + (when (processp (get-buffer-process name)) (delete-process name)) (when (bufferp (get-buffer name)) (kill-buffer name))) ;; The end. @@ -350,15 +359,14 @@ The remote connection identified by SOURCE is flushed by (or (setq target (tramp-default-rename-file source)) (tramp-user-error nil - (eval-when-compile - (concat "There is no target specified. " - "Check `tramp-default-rename-alist' for a proper entry."))))) + (concat "There is no target specified. " + "Check `tramp-default-rename-alist' for a proper entry.")))) (when (tramp-equal-remote source target) (tramp-user-error nil "Source and target must have different remote.")) ;; 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)) @@ -557,11 +565,10 @@ buffer in your bug report. ;; Remove string quotation. (forward-line -1) (when (looking-at - (eval-when-compile - (concat "\\(^.*\\)" "\"" ;; \1 " - "\\((base64-decode-string \\)" "\\\\" ;; \2 \ - "\\(\".*\\)" "\\\\" ;; \3 \ - "\\(\")\\)" "\"$"))) ;; \4 " + (concat "\\(^.*\\)" "\"" ;; \1 " + "\\((base64-decode-string \\)" "\\\\" ;; \2 \ + "\\(\".*\\)" "\\\\" ;; \3 \ + "\\(\")\\)" "\"$")) ;; \4 " (replace-match "\\1\\2\\3\\4") (beginning-of-line) (insert " ;; Variable encoded due to non-printable characters.\n")) diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index 723b8cfa1e3..218594b551c 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,7 +41,9 @@ (require 'shell) (require 'subr-x) +;; `temporary-file-directory' as function is introduced with Emacs 26.1. (declare-function tramp-handle-temporary-file-directory "tramp") +(defvar tramp-temp-name-prefix) ;; For not existing functions, obsolete functions, or functions with a ;; changed argument list, there are compiler warnings. We want to @@ -51,6 +53,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'." @@ -58,15 +62,19 @@ It is the default value of `temporary-file-directory'." ;; into an infloop. (eval (car (get 'temporary-file-directory 'standard-value)))) +(defsubst tramp-compat-make-temp-name () + "Generate a local temporary file name (compat function)." + (make-temp-name + (expand-file-name + tramp-temp-name-prefix (tramp-compat-temporary-file-directory)))) + (defsubst tramp-compat-make-temp-file (f &optional dir-flag) "Create a local temporary file (compat function). Add the extension of F, if existing." - (let* (file-name-handler-alist - (prefix (expand-file-name - (symbol-value 'tramp-temp-name-prefix) - (tramp-compat-temporary-file-directory))) - (extension (file-name-extension f t))) - (make-temp-file prefix dir-flag extension))) + (make-temp-file + (expand-file-name + tramp-temp-name-prefix (tramp-compat-temporary-file-directory)) + dir-flag (file-name-extension f t))) ;; `temporary-file-directory' as function is introduced with Emacs 26.1. (defalias 'tramp-compat-temporary-file-directory-function @@ -74,31 +82,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,31 +164,13 @@ 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) "The error symbol for the `file-missing' error.") ;; `file-local-name', `file-name-quoted-p', `file-name-quote' and -;; `file-name-unquote' are introduced in Emacs 26. +;; `file-name-unquote' are introduced in Emacs 26.1. (defalias 'tramp-compat-file-local-name (if (fboundp 'file-local-name) #'file-local-name @@ -214,7 +180,8 @@ It returns a file name which can be used directly as argument of `process-file', `start-file-process', or `shell-command'." (or (file-remote-p name 'localname) name)))) -;; `file-name-quoted-p' got a second argument in Emacs 27.1. +;; `file-name-quoted-p', `file-name-quote' and `file-name-unquote' got +;; a second argument in Emacs 27.1. (defalias 'tramp-compat-file-name-quoted-p (if (and (fboundp 'file-name-quoted-p) @@ -256,7 +223,7 @@ NAME is unquoted." localname (if (= (length localname) 2) "/" (substring localname 2)))) (concat (file-remote-p name) localname))))) -;; `tramp-syntax' has changed its meaning in Emacs 26. We still +;; `tramp-syntax' has changed its meaning in Emacs 26.1. We still ;; support old settings. (defsubst tramp-compat-tramp-syntax () "Return proper value of `tramp-syntax'." @@ -265,13 +232,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 +244,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 @@ -322,16 +281,38 @@ A nil value for either argument stands for the current time." (lambda (reporter &optional value _suffix) (progress-reporter-update reporter value)))) +;; `file-modes', `set-file-modes' and `set-file-times' got argument +;; FLAG in Emacs 28.1. +(defalias 'tramp-compat-file-modes + (if (equal (tramp-compat-funcall 'func-arity #'file-modes) '(1 . 2)) + #'file-modes + (lambda (filename &optional _flag) + (file-modes filename)))) + +(defalias 'tramp-compat-set-file-modes + (if (equal (tramp-compat-funcall 'func-arity #'set-file-modes) '(2 . 3)) + #'set-file-modes + (lambda (filename mode &optional _flag) + (set-file-modes filename mode)))) + +(defalias 'tramp-compat-set-file-times + (if (equal (tramp-compat-funcall 'func-arity #'set-file-times) '(1 . 3)) + #'set-file-times + (lambda (filename &optional timestamp _flag) + (set-file-times filename timestamp)))) + (add-hook 'tramp-unload-hook (lambda () (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) +;; * `func-arity' exists since Emacs 26.1. +;; +;; * 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-crypt.el b/lisp/net/tramp-crypt.el new file mode 100644 index 00000000000..c9788fcff52 --- /dev/null +++ b/lisp/net/tramp-crypt.el @@ -0,0 +1,838 @@ +;;; tramp-crypt.el --- Tramp crypt utilities -*- lexical-binding:t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Michael Albinus <michael.albinus@gmx.de> +;; Keywords: comm, processes +;; Package: tramp + +;; 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: + +;; Access functions for crypted remote files. It uses encfs to +;; encrypt / decrypt the files on a remote directory. A remote +;; directory, which shall include crypted files, must be declared in +;; `tramp-crypt-directories' via command `tramp-crypt-add-directory'. +;; All files in that directory, including all subdirectories, are +;; stored there encrypted. This includes file names and directory +;; names. + +;; This package is just responsible for the encryption part. Copying +;; of the crypted files is still the responsibility of the remote file +;; name handlers. + +;; A password protected encfs configuration file is created the very +;; first time you access a crypted remote directory. It is kept in +;; your user directory "~/.emacs.d/" with the url-encoded directory +;; name as part of the basename, and ".encfs6.xml" as suffix. Do not +;; loose this file and the corresponding password; otherwise there is +;; no way to decrypt your crypted files. + +;; If the user option `tramp-crypt-save-encfs-config-remote' is +;; non-nil (the default), the encfs configuration file ".encfs6.xml" +;; is also kept in the crypted remote directory. It depends on you, +;; whether you regard the password protection of this file as +;; sufficient. + +;; If you use a remote file name with a quoted localname part, this +;; localname and the corresponding file will not be encrypted/ +;; decrypted. For example, if you have a crypted remote directory +;; "/nextcloud:user@host:/crypted_dir", the command +;; +;; C-x d /nextcloud:user@host:/crypted_dir +;; +;; will show the directory listing with the plain file names, and the +;; command +;; +;; C-x d /nextcloud:user@host:/:/crypted_dir +;; +;; will show the directory with the encrypted file names, and visiting +;; a file will show its crypted contents. However, it is highly +;; discouraged to mix crypted and not crypted files in the same +;; directory. + +;; If a remote directory shall not include crypted files anymore, it +;; must be indicated by the command `tramp-crypt-remove-directory'. + +;;; Code: + +(eval-when-compile (require 'cl-lib)) +(require 'tramp) + +(autoload 'prop-match-beginning "text-property-search") +(autoload 'prop-match-end "text-property-search") +(autoload 'text-property-search-forward "text-property-search") + +(defconst tramp-crypt-method "crypt" + "Method name for crypted remote directories.") + +(defcustom tramp-crypt-encfs-program "encfs" + "Name of the encfs program." + :group 'tramp + :version "28.1" + :type 'string) + +(defcustom tramp-crypt-encfsctl-program "encfsctl" + "Name of the encfsctl program." + :group 'tramp + :version "28.1" + :type 'string) + +(defcustom tramp-crypt-encfs-option "--standard" + "Configuration option for encfs. +This could be either \"--standard\" or \"--paranoia\". The file +name IV chaining mode mode will always be disabled when +initializing a new crypted remote directory." + :group 'tramp + :version "28.1" + :type '(choice (const "--standard") + (const "--paranoia"))) + +;; We check only for encfs, assuming that encfsctl will be available +;; as well. The autoloaded value is nil, the check will run when +;; tramp-crypt.el is loaded by `tramp-crypt-add-directory'. It is a +;; common technique to let-bind this variable to nil in order to +;; suppress the file name operation of this package. +;;;###tramp-autoload +(defvar tramp-crypt-enabled nil + "Non-nil when encryption support is available.") +(setq tramp-crypt-enabled (executable-find tramp-crypt-encfs-program)) + +;;;###tramp-autoload +(defconst tramp-crypt-encfs-config ".encfs6.xml" + "Encfs configuration file name.") + +(defcustom tramp-crypt-save-encfs-config-remote t + "Whether to keep the encfs configuration file in the crypted remote directory." + :group 'tramp + :version "28.1" + :type 'booleanp) + +;;;###tramp-autoload +(defvar tramp-crypt-directories nil + "List of crypted remote directories.") + +;; It must be a `defsubst' in order to push the whole code into +;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading. +;;;###tramp-autoload +(defsubst tramp-crypt-file-name-p (name) + "Return the crypted remote directory NAME belongs to. +If NAME doesn't belong to a crypted remote directory, retun nil." + (catch 'crypt-file-name-p + (and tramp-crypt-enabled (stringp name) + (not (tramp-compat-file-name-quoted-p name)) + (not (string-suffix-p tramp-crypt-encfs-config name)) + (dolist (dir tramp-crypt-directories) + (and (string-prefix-p + dir (file-name-as-directory (expand-file-name name))) + (throw 'crypt-file-name-p dir)))))) + + +;; New handlers should be added here. +;;;###tramp-autoload +(defconst tramp-crypt-file-name-handler-alist + '((access-file . tramp-crypt-handle-access-file) + (add-name-to-file . tramp-handle-add-name-to-file) + ;; `byte-compiler-base-file-name' performed by default handler. + (copy-directory . tramp-handle-copy-directory) + (copy-file . tramp-crypt-handle-copy-file) + (delete-directory . tramp-crypt-handle-delete-directory) + (delete-file . tramp-crypt-handle-delete-file) + ;; `diff-latest-backup-file' performed by default handler. + ;; `directory-file-name' performed by default handler. + (directory-files . tramp-crypt-handle-directory-files) + (directory-files-and-attributes + . tramp-handle-directory-files-and-attributes) + (dired-compress-file . ignore) + (dired-uncache . tramp-handle-dired-uncache) + (exec-path . ignore) + ;; `expand-file-name' performed by default handler. + (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) + (file-acl . ignore) + (file-attributes . tramp-crypt-handle-file-attributes) + (file-directory-p . tramp-handle-file-directory-p) + (file-equal-p . tramp-handle-file-equal-p) + (file-executable-p . tramp-crypt-handle-file-executable-p) + (file-exists-p . tramp-handle-file-exists-p) + (file-in-directory-p . tramp-handle-file-in-directory-p) + (file-local-copy . tramp-handle-file-local-copy) + (file-modes . tramp-handle-file-modes) + (file-name-all-completions . tramp-crypt-handle-file-name-all-completions) + ;; `file-name-as-directory' performed by default handler. + (file-name-case-insensitive-p . ignore) + (file-name-completion . tramp-handle-file-name-completion) + ;; `file-name-directory' performed by default handler. + ;; `file-name-nondirectory' performed by default handler. + ;; `file-name-sans-versions' performed by default handler. + (file-newer-than-file-p . tramp-handle-file-newer-than-file-p) + (file-notify-add-watch . ignore) + (file-notify-rm-watch . ignore) + (file-notify-valid-p . ignore) + (file-ownership-preserved-p . tramp-crypt-handle-file-ownership-preserved-p) + (file-readable-p . tramp-crypt-handle-file-readable-p) + (file-regular-p . tramp-handle-file-regular-p) + ;; `file-remote-p' performed by default handler. + (file-selinux-context . ignore) + (file-symlink-p . tramp-handle-file-symlink-p) + (file-system-info . tramp-crypt-handle-file-system-info) + ;; `file-truename' performed by default handler. + (file-writable-p . tramp-crypt-handle-file-writable-p) + (find-backup-file-name . tramp-handle-find-backup-file-name) + ;; `get-file-buffer' performed by default handler. + (insert-directory . tramp-crypt-handle-insert-directory) + ;; `insert-file-contents' performed by default handler. + (load . tramp-handle-load) + (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) + (make-directory . tramp-crypt-handle-make-directory) + (make-directory-internal . ignore) + (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) + (make-process . ignore) + (make-symbolic-link . tramp-handle-make-symbolic-link) + (process-file . ignore) + (rename-file . tramp-crypt-handle-rename-file) + (set-file-acl . ignore) + (set-file-modes . tramp-crypt-handle-set-file-modes) + (set-file-selinux-context . ignore) + (set-file-times . tramp-crypt-handle-set-file-times) + (set-visited-file-modtime . tramp-handle-set-visited-file-modtime) + (shell-command . ignore) + (start-file-process . ignore) + ;; `substitute-in-file-name' performed by default handler. + (temporary-file-directory . tramp-handle-temporary-file-directory) + ;; `tramp-get-remote-gid' performed by default handler. + ;; `tramp-get-remote-uid' performed by default handler. + (tramp-set-file-uid-gid . tramp-crypt-handle-set-file-uid-gid) + (unhandled-file-name-directory . ignore) + (vc-registered . ignore) + (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) + (write-region . tramp-handle-write-region)) + "Alist of handler functions for crypt method. +Operations not mentioned here will be handled by the default Emacs primitives.") + +(defsubst tramp-crypt-file-name-for-operation (operation &rest args) + "Like `tramp-file-name-for-operation', but for crypted remote files." + (let ((tfnfo (apply #'tramp-file-name-for-operation operation args))) + ;; `tramp-file-name-for-operation' returns already the first argument + ;; if it is remote. So we check a possible second argument. + (unless (tramp-crypt-file-name-p tfnfo) + (setq tfnfo (apply + #'tramp-file-name-for-operation operation + (cons (tramp-compat-temporary-file-directory) (cdr args))))) + tfnfo)) + +(defun tramp-crypt-run-real-handler (operation args) + "Invoke normal file name handler for OPERATION. +First arg specifies the OPERATION, second arg ARGS is a list of +arguments to pass to the OPERATION." + (let* ((inhibit-file-name-handlers + `(tramp-crypt-file-name-handler + . + ,(and (eq inhibit-file-name-operation operation) + inhibit-file-name-handlers))) + (inhibit-file-name-operation operation)) + (apply operation args))) + +;;;###tramp-autoload +(defun tramp-crypt-file-name-handler (operation &rest args) + "Invoke the crypted remote file related OPERATION. +First arg specifies the OPERATION, second arg ARGS is a list of +arguments to pass to the OPERATION." + (if-let ((filename + (apply #'tramp-crypt-file-name-for-operation operation args)) + (fn (and (tramp-crypt-file-name-p filename) + (assoc operation tramp-crypt-file-name-handler-alist)))) + (save-match-data (apply (cdr fn) args)) + (tramp-crypt-run-real-handler operation args))) + +;;;###tramp-autoload +(progn (defun tramp-register-crypt-file-name-handler () + "Add crypt file name handler to `file-name-handler-alist'." + (when (and tramp-crypt-enabled tramp-crypt-directories) + (add-to-list 'file-name-handler-alist + (cons tramp-file-name-regexp #'tramp-crypt-file-name-handler)) + (put #'tramp-crypt-file-name-handler 'safe-magic t)))) + +(tramp-register-file-name-handlers) + +;; Mark `operations' the handler is responsible for. +(put #'tramp-crypt-file-name-handler 'operations + (mapcar #'car tramp-crypt-file-name-handler-alist)) + + +;; File name conversions. + +(defun tramp-crypt-config-file-name (vec) + "Return the encfs config file name for VEC." + (expand-file-name + (concat "tramp-" (tramp-file-name-host vec) tramp-crypt-encfs-config) + user-emacs-directory)) + +(defun tramp-crypt-maybe-open-connection (vec) + "Maybe open a connection VEC. +Does not do anything if a connection is already open, but re-opens the +connection if a previous connection has died for some reason." + ;; For password handling, we need a process bound to the connection + ;; buffer. Therefore, we create a dummy process. Maybe there is a + ;; better solution? + (unless (get-buffer-process (tramp-get-connection-buffer vec)) + (let ((p (make-network-process + :name (tramp-get-connection-name vec) + :buffer (tramp-get-connection-buffer vec) + :server t :host 'local :service t :noquery t))) + (process-put p 'vector vec) + (set-process-query-on-exit-flag p nil))) + + ;; The following operations must be performed w/o + ;; `tramp-crypt-file-name-handler'. + (let* (tramp-crypt-enabled + ;; Don't check for a proper method. + (non-essential t) + (remote-config + (expand-file-name + tramp-crypt-encfs-config (tramp-crypt-get-remote-dir vec))) + (local-config (tramp-crypt-config-file-name vec))) + ;; There is no local encfs6 config file. + (when (not (file-exists-p local-config)) + (if (and tramp-crypt-save-encfs-config-remote + (file-exists-p remote-config)) + ;; Copy remote encfs6 config file if possible. + (copy-file remote-config local-config 'ok 'keep) + + ;; Create local encfs6 config file otherwise. + (let* ((default-directory (tramp-compat-temporary-file-directory)) + (tmpdir1 (file-name-as-directory + (tramp-compat-make-temp-file " .crypt" 'dir-flag))) + (tmpdir2 (file-name-as-directory + (tramp-compat-make-temp-file " .nocrypt" 'dir-flag)))) + ;; Enable `auth-source', unless "emacs -Q" has been called. + (tramp-set-connection-property + vec "first-password-request" tramp-cache-read-persistent-data) + (with-temp-buffer + (insert + (tramp-read-passwd + (tramp-get-connection-process vec) + (format + "New EncFS Password for %s " (tramp-crypt-get-remote-dir vec)))) + (when + (zerop + (tramp-call-process-region + vec (point-min) (point-max) + tramp-crypt-encfs-program nil (tramp-get-connection-buffer vec) + nil tramp-crypt-encfs-option "--extpass=cat" tmpdir1 tmpdir2)) + ;; Save the password. + (ignore-errors + (and (functionp tramp-password-save-function) + (funcall tramp-password-save-function))))) + + ;; Write local config file. Suppress file name IV chaining mode. + (with-temp-file local-config + (insert-file-contents + (expand-file-name tramp-crypt-encfs-config tmpdir1)) + (when (search-forward + "<chainedNameIV>1</chainedNameIV>" nil 'noerror) + (replace-match "<chainedNameIV>0</chainedNameIV>"))) + + ;; Unmount encfs. Delete temporary directories. + (tramp-call-process + vec tramp-crypt-encfs-program nil nil nil + "--unmount" tmpdir1 tmpdir2) + (delete-directory tmpdir1 'recursive) + (delete-directory tmpdir2) + + ;; Copy local encfs6 config file to remote. + (when tramp-crypt-save-encfs-config-remote + (copy-file local-config remote-config 'ok 'keep))))))) + +(defun tramp-crypt-send-command (vec &rest args) + "Send encfsctl command to connection VEC. +ARGS are the arguments. It returns t if ran successful, and nil otherwise." + (tramp-crypt-maybe-open-connection vec) + (with-current-buffer (tramp-get-connection-buffer vec) + (erase-buffer) + (set-buffer-multibyte nil)) + (with-temp-buffer + (let* (;; Don't check for a proper method. + (non-essential t) + (default-directory (tramp-compat-temporary-file-directory)) + ;; We cannot add it to `process-environment', because + ;; `tramp-call-process-region' doesn't use it. + (encfs-config + (format "ENCFS6_CONFIG=%s" (tramp-crypt-config-file-name vec))) + (args (delq nil args))) + ;; Enable `auth-source', unless "emacs -Q" has been called. + (tramp-set-connection-property + vec "first-password-request" tramp-cache-read-persistent-data) + (insert + (tramp-read-passwd + (tramp-get-connection-process vec) + (format "EncFS Password for %s " (tramp-crypt-get-remote-dir vec)))) + (when (zerop + (apply + #'tramp-call-process-region vec (point-min) (point-max) + "env" nil (tramp-get-connection-buffer vec) + nil encfs-config tramp-crypt-encfsctl-program + (car args) "--extpass=cat" (cdr args))) + ;; Save the password. + (ignore-errors + (and (functionp tramp-password-save-function) + (funcall tramp-password-save-function))) + t)))) + +(defun tramp-crypt-do-encrypt-or-decrypt-file-name (op name) + "Return encrypted / decrypted NAME if NAME belongs to a crypted directory. +OP must be `encrypt' or `decrypt'. Raise an error if this fails. +Otherwise, return NAME." + (if-let ((tramp-crypt-enabled t) + (dir (tramp-crypt-file-name-p name)) + ;; It must be absolute for the cache. + (localname (substring name (1- (length dir)))) + (crypt-vec (tramp-crypt-dissect-file-name dir))) + ;; Preserve trailing "/". + (funcall + (if (directory-name-p name) #'file-name-as-directory #'identity) + (concat + dir + (unless (string-equal localname "/") + (with-tramp-file-property + crypt-vec localname (concat (symbol-name op) "-file-name") + (unless (tramp-crypt-send-command + crypt-vec (if (eq op 'encrypt) "encode" "decode") + (tramp-compat-temporary-file-directory) localname) + (tramp-error + crypt-vec 'file-error "%s of file name %s failed." + (if (eq op 'encrypt) "Encoding" "Decoding") name)) + (with-current-buffer (tramp-get-connection-buffer crypt-vec) + (goto-char (point-min)) + (buffer-substring (point-min) (point-at-eol))))))) + ;; Nothing to do. + name)) + +(defsubst tramp-crypt-encrypt-file-name (name) + "Return encrypted NAME if NAME belongs to a crypted directory. +Otherwise, return NAME." + (tramp-crypt-do-encrypt-or-decrypt-file-name 'encrypt name)) + +(defsubst tramp-crypt-decrypt-file-name (name) + "Return decrypted NAME if NAME belongs to a crypted directory. +Otherwise, return NAME." + (tramp-crypt-do-encrypt-or-decrypt-file-name 'decrypt name)) + +(defun tramp-crypt-do-encrypt-or-decrypt-file (op root infile outfile) + "Encrypt / decrypt file INFILE to OUTFILE according to crypted directory ROOT. +Both files must be local files. OP must be `encrypt' or `decrypt'. +If OP ist `decrypt', the basename of INFILE must be an encrypted file name. +Raise an error if this fails." + (when-let ((tramp-crypt-enabled t) + (dir (tramp-crypt-file-name-p root)) + (crypt-vec (tramp-crypt-dissect-file-name dir))) + (let ((coding-system-for-read + (if (eq op 'decrypt) 'binary coding-system-for-read)) + (coding-system-for-write + (if (eq op 'encrypt) 'binary coding-system-for-write))) + (unless (tramp-crypt-send-command + crypt-vec "cat" (and (eq op 'encrypt) "--reverse") + (file-name-directory infile) + (concat "/" (file-name-nondirectory infile))) + (tramp-error + crypt-vec 'file-error "%s of file %s failed." + (if (eq op 'encrypt) "Encrypting" "Decrypting") infile)) + (with-current-buffer (tramp-get-connection-buffer crypt-vec) + (write-region nil nil outfile))))) + +(defsubst tramp-crypt-encrypt-file (root infile outfile) + "Encrypt file INFILE to OUTFILE according to crypted directory ROOT. +See `tramp-crypt-do-encrypt-or-decrypt-file'." + (tramp-crypt-do-encrypt-or-decrypt-file 'encrypt root infile outfile)) + +(defsubst tramp-crypt-decrypt-file (root infile outfile) + "Decrypt file INFILE to OUTFILE according to crypted directory ROOT. +See `tramp-crypt-do-encrypt-or-decrypt-file'." + (tramp-crypt-do-encrypt-or-decrypt-file 'decrypt root infile outfile)) + +;;;###tramp-autoload +(defun tramp-crypt-add-directory (name) + "Mark remote directory NAME for encryption. +Files in that directory and all subdirectories will be encrypted +before copying to, and decrypted after copying from that +directory. File names will be also encrypted." + (interactive "DRemote directory name: ") + (unless tramp-crypt-enabled + (tramp-user-error nil "Feature is not enabled.")) + (unless (and (tramp-tramp-file-p name) (file-directory-p name)) + (tramp-user-error nil "%s must be an existing remote directory." name)) + (when (tramp-compat-file-name-quoted-p name) + (tramp-user-error nil "%s must not be quoted." name)) + (setq name (file-name-as-directory (expand-file-name name))) + (unless (member name tramp-crypt-directories) + (setq tramp-crypt-directories (cons name tramp-crypt-directories))) + (tramp-register-file-name-handlers)) + +(defun tramp-crypt-remove-directory (name) + "Unmark remote directory NAME for encryption. +Existing files in that directory and its subdirectories will be +kept in their encrypted form." + (interactive "DRemote directory name: ") + (unless tramp-crypt-enabled + (tramp-user-error nil "Feature is not enabled.")) + (setq name (file-name-as-directory (expand-file-name name))) + (when (and (member name tramp-crypt-directories) + (delete + tramp-crypt-encfs-config + (directory-files name nil directory-files-no-dot-files-regexp)) + (yes-or-no-p + "There exist encrypted files, do you want to continue? ")) + (setq tramp-crypt-directories (delete name tramp-crypt-directories)) + (tramp-register-file-name-handlers))) + +;; `auth-source' requires a user. +(defun tramp-crypt-dissect-file-name (name) + "Return a `tramp-file-name' structure for NAME. +The structure consists of the `tramp-crypt-method' method, the +local user name, the hexlified directory NAME as host, and the +localname." + (save-match-data + (if-let ((dir (tramp-crypt-file-name-p name))) + (make-tramp-file-name + :method tramp-crypt-method :user (user-login-name) + :host (url-hexify-string dir)) + (tramp-user-error nil "Not a crypted remote directory: \"%s\"" name)))) + +(defun tramp-crypt-get-remote-dir (vec) + "Return the name of the crypted remote directory to be used for encfs." + (url-unhex-string (tramp-file-name-host vec))) + + +;; File name primitives. + +(defun tramp-crypt-handle-access-file (filename string) + "Like `access-file' for Tramp files." + (let* ((encrypt-filename (tramp-crypt-encrypt-file-name filename)) + (encrypt-regexp (concat (regexp-quote encrypt-filename) "\\'")) + tramp-crypt-enabled) + (condition-case err + (access-file encrypt-filename string) + (error + (when (and (eq (car err) 'file-missing) (stringp (cadr err)) + (string-match-p encrypt-regexp (cadr err))) + (setcar + (cdr err) + (replace-regexp-in-string encrypt-regexp filename (cadr err)))) + (signal (car err) (cdr err)))))) + +(defun tramp-crypt-do-copy-or-rename-file + (op filename newname &optional ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes) + "Copy or rename a remote file. +OP must be `copy' or `rename' and indicates the operation to perform. +FILENAME specifies the file to copy or rename, NEWNAME is the name of +the new file (for copy) or the new name of the file (for rename). +OK-IF-ALREADY-EXISTS means don't barf if NEWNAME exists already. +KEEP-DATE means to make sure that NEWNAME has the same timestamp +as FILENAME. PRESERVE-UID-GID, when non-nil, instructs to keep +the uid and gid if both files are on the same host. +PRESERVE-EXTENDED-ATTRIBUTES is ignored. + +This function is invoked by `tramp-crypt-handle-copy-file' and +`tramp-crypt-handle-rename-file'. It is an error if OP is +neither of `copy' and `rename'. FILENAME and NEWNAME must be +absolute file names." + (unless (memq op '(copy rename)) + (error "Unknown operation `%s', must be `copy' or `rename'" op)) + + (setq filename (file-truename filename)) + (let ((t1 (tramp-crypt-file-name-p filename)) + (t2 (tramp-crypt-file-name-p newname)) + (encrypt-filename (tramp-crypt-encrypt-file-name filename)) + (encrypt-newname (tramp-crypt-encrypt-file-name newname)) + (msg-operation (if (eq op 'copy) "Copying" "Renaming"))) + + (if (file-directory-p filename) + (progn + (copy-directory filename newname keep-date t) + (when (eq op 'rename) + (delete-directory filename 'recursive))) + + (with-parsed-tramp-file-name (if t1 filename newname) nil + (unless (file-exists-p filename) + (tramp-error + v tramp-file-missing + "%s file" msg-operation "No such file or directory" filename)) + (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 (directory-name-p newname))) + (tramp-error v 'file-error "File is a directory %s" newname)) + + (with-tramp-progress-reporter + v 0 (format "%s %s to %s" msg-operation filename newname) + (if (and t1 t2 (string-equal t1 t2)) + ;; Both files are on the same crypted remote directory. + (let (tramp-crypt-enabled) + (if (eq op 'copy) + (copy-file + encrypt-filename encrypt-newname ok-if-already-exists + keep-date preserve-uid-gid preserve-extended-attributes) + (rename-file + encrypt-filename encrypt-newname ok-if-already-exists))) + + (let* ((tmpdir (tramp-compat-make-temp-file filename 'dir)) + (tmpfile1 + (expand-file-name + (file-name-nondirectory encrypt-filename) tmpdir)) + (tmpfile2 + (expand-file-name + (file-name-nondirectory encrypt-newname) tmpdir)) + tramp-crypt-enabled) + (cond + ;; Source and target file are on a crypted remote directory. + ((and t1 t2) + (if (eq op 'copy) + (copy-file + encrypt-filename encrypt-newname ok-if-already-exists + keep-date preserve-uid-gid preserve-extended-attributes) + (rename-file + encrypt-filename encrypt-newname ok-if-already-exists))) + ;; Source file is on a crypted remote directory. + (t1 + (if (eq op 'copy) + (copy-file + encrypt-filename tmpfile1 t keep-date preserve-uid-gid + preserve-extended-attributes) + (rename-file encrypt-filename tmpfile1 t)) + (tramp-crypt-decrypt-file t1 tmpfile1 tmpfile2) + (rename-file tmpfile2 newname ok-if-already-exists)) + ;; Target file is on a crypted remote directory. + (t2 + (if (eq op 'copy) + (copy-file + filename tmpfile1 t keep-date preserve-uid-gid + preserve-extended-attributes) + (rename-file filename tmpfile1 t)) + (tramp-crypt-encrypt-file t2 tmpfile1 tmpfile2) + (rename-file tmpfile2 encrypt-newname ok-if-already-exists))) + (delete-directory tmpdir 'recursive)))))) + + (when (and t1 (eq op 'rename)) + (with-parsed-tramp-file-name filename v1 + (tramp-flush-file-properties v1 v1-localname))) + + (when t2 + (with-parsed-tramp-file-name newname v2 + (tramp-flush-file-properties v2 v2-localname))))) + +(defun tramp-crypt-handle-copy-file + (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) + newname (expand-file-name newname)) + ;; At least one file a Tramp file? + (if (or (tramp-tramp-file-p filename) + (tramp-tramp-file-p newname)) + (tramp-crypt-do-copy-or-rename-file + 'copy filename newname ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes) + (tramp-run-real-handler + #'copy-file + (list filename newname ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes)))) + +(defun tramp-crypt-handle-delete-directory + (directory &optional recursive trash) + "Like `delete-directory' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name directory) nil + (tramp-flush-directory-properties v localname) + (let (tramp-crypt-enabled) + (delete-directory + (tramp-crypt-encrypt-file-name directory) recursive trash)))) + +(defun tramp-crypt-handle-delete-file (filename &optional trash) + "Like `delete-file' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name filename) nil + (tramp-flush-file-properties v localname) + (let (tramp-crypt-enabled) + (delete-file (tramp-crypt-encrypt-file-name filename) trash)))) + +(defun tramp-crypt-handle-directory-files (directory &optional full match nosort) + "Like `directory-files' for Tramp files." + (unless (file-exists-p directory) + (tramp-error + (tramp-dissect-file-name directory) tramp-file-missing + "No such file or directory" directory)) + (when (file-directory-p directory) + (setq directory (file-name-as-directory (expand-file-name directory))) + (let* (tramp-crypt-enabled + (result + (directory-files (tramp-crypt-encrypt-file-name directory) 'full))) + (setq result + (mapcar (lambda (x) (tramp-crypt-decrypt-file-name x)) result)) + (when match + (setq result + (delq + nil + (mapcar + (lambda (x) + (when (string-match-p match (substring x (length directory))) + x)) + result)))) + (unless full + (setq result + (mapcar + (lambda (x) + (replace-regexp-in-string + (concat "^" (regexp-quote directory)) "" x)) + result))) + (if nosort result (sort result #'string<))))) + +(defun tramp-crypt-handle-file-attributes (filename &optional id-format) + "Like `file-attributes' for Tramp files." + (let (tramp-crypt-enabled) + (file-attributes (tramp-crypt-encrypt-file-name filename) id-format))) + +(defun tramp-crypt-handle-file-executable-p (filename) + "Like `file-executable-p' for Tramp files." + (let (tramp-crypt-enabled) + (file-executable-p (tramp-crypt-encrypt-file-name filename)))) + +(defun tramp-crypt-handle-file-name-all-completions (filename directory) + "Like `file-name-all-completions' for Tramp files." + (all-completions + filename + (let* (completion-regexp-list + tramp-crypt-enabled + (directory (file-name-as-directory directory)) + (enc-dir (tramp-crypt-encrypt-file-name directory))) + (mapcar + (lambda (x) + (substring + (tramp-crypt-decrypt-file-name (concat enc-dir x)) + (length directory))) + (file-name-all-completions "" enc-dir))))) + +(defun tramp-crypt-handle-file-readable-p (filename) + "Like `file-readable-p' for Tramp files." + (let (tramp-crypt-enabled) + (file-readable-p (tramp-crypt-encrypt-file-name filename)))) + +(defun tramp-crypt-handle-file-ownership-preserved-p (filename &optional group) + "Like `file-ownership-preserved-p' for Tramp files." + (let (tramp-crypt-enabled) + (file-ownership-preserved-p (tramp-crypt-encrypt-file-name filename) group))) + +(defun tramp-crypt-handle-file-system-info (filename) + "Like `file-system-info' for Tramp files." + (let (tramp-crypt-enabled) + ;; `file-system-info' exists since Emacs 27.1. + (tramp-compat-funcall + 'file-system-info (tramp-crypt-encrypt-file-name filename)))) + +(defun tramp-crypt-handle-file-writable-p (filename) + "Like `file-writable-p' for Tramp files." + (let (tramp-crypt-enabled) + (file-writable-p (tramp-crypt-encrypt-file-name filename)))) + +(defun tramp-crypt-handle-insert-directory + (filename switches &optional wildcard full-directory-p) + "Like `insert-directory' for Tramp files. +WILDCARD is not supported." + ;; This package has been added to Emacs 27.1. + (when (load "text-property-search" 'noerror 'nomessage) + (let (tramp-crypt-enabled) + (tramp-handle-insert-directory + (tramp-crypt-encrypt-file-name filename) + switches wildcard full-directory-p) + (let* ((filename (file-name-as-directory filename)) + (enc (tramp-crypt-encrypt-file-name filename)) + match string) + (goto-char (point-min)) + (while (setq match (text-property-search-forward 'dired-filename t t)) + (setq string + (buffer-substring + (prop-match-beginning match) (prop-match-end match)) + string (if (file-name-absolute-p string) + (tramp-crypt-decrypt-file-name string) + (substring + (tramp-crypt-decrypt-file-name (concat enc string)) + (length filename)))) + (delete-region (prop-match-beginning match) (prop-match-end match)) + (insert (propertize string 'dired-filename t))))))) + +(defun tramp-crypt-handle-make-directory (dir &optional parents) + "Like `make-directory' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name dir) nil + (when (and (null parents) (file-exists-p dir)) + (tramp-error v 'file-already-exists "Directory already exists %s" dir)) + (let (tramp-crypt-enabled) + (make-directory (tramp-crypt-encrypt-file-name dir) parents)) + ;; When PARENTS is non-nil, DIR could be a chain of non-existent + ;; directories a/b/c/... Instead of checking, we simply flush the + ;; whole cache. + (tramp-flush-directory-properties + v (if parents "/" (file-name-directory localname))))) + +(defun tramp-crypt-handle-rename-file + (filename newname &optional ok-if-already-exists) + "Like `rename-file' for Tramp files." + (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)) + (tramp-crypt-do-copy-or-rename-file + 'rename filename newname ok-if-already-exists + 'keep-date 'preserve-uid-gid) + (tramp-run-real-handler + #'rename-file (list filename newname ok-if-already-exists)))) + +(defun tramp-crypt-handle-set-file-modes (filename mode &optional flag) + "Like `set-file-modes' for Tramp files." + (with-parsed-tramp-file-name filename nil + (tramp-flush-file-properties v localname) + (let (tramp-crypt-enabled) + (tramp-compat-set-file-modes + (tramp-crypt-encrypt-file-name filename) mode flag)))) + +(defun tramp-crypt-handle-set-file-times (filename &optional time flag) + "Like `set-file-times' for Tramp files." + (with-parsed-tramp-file-name filename nil + (tramp-flush-file-properties v localname) + (let (tramp-crypt-enabled) + (tramp-compat-set-file-times + (tramp-crypt-encrypt-file-name filename) time flag)))) + +(defun tramp-crypt-handle-set-file-uid-gid (filename &optional uid gid) + "Like `tramp-set-file-uid-gid' for Tramp files." + (with-parsed-tramp-file-name filename nil + (tramp-flush-file-properties v localname) + (let (tramp-crypt-enabled) + (tramp-set-file-uid-gid + (tramp-crypt-encrypt-file-name filename) uid gid)))) + +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-crypt 'force))) + +(provide 'tramp-crypt) + +;;; TODO: + +;; * I suggest having a feature where the user can specify to always +;; use encryption for certain host names. So if you specify a host +;; name which is on that list (of names, or perhaps regexps?), tramp +;; would modify the request so as to do the encryption. (Richard Stallman) + +;;; tramp-crypt.el ends here diff --git a/lisp/net/tramp-ftp.el b/lisp/net/tramp-ftp.el index 95ae1569dc9..996a92454f1 100644 --- a/lisp/net/tramp-ftp.el +++ b/lisp/net/tramp-ftp.el @@ -31,8 +31,7 @@ (require 'tramp) ;; Pacify byte-compiler. -(eval-when-compile - (require 'custom)) +(eval-when-compile (require 'custom)) (defvar ange-ftp-ftp-name-arg) (defvar ange-ftp-ftp-name-res) (defvar ange-ftp-name-format) @@ -79,9 +78,9 @@ present for backward compatibility." ;;; This regexp recognizes absolute filenames with only one component ;;; on Windows, for the sake of hostname completion. (and (memq system-type '(ms-dos windows-nt)) - (or (assoc "^[a-zA-Z]:/[^/:]*\\'" file-name-handler-alist) + (or (assoc "^[[:alpha:]]:/[^/:]*\\'" file-name-handler-alist) (setq file-name-handler-alist - (cons '("^[a-zA-Z]:/[^/:]*\\'" . + (cons '("^[:alpha:]]:/[^/:]*\\'" . ange-ftp-completion-hook-function) file-name-handler-alist))))) diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 34a234c47f0..6467d8f88b4 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 @@ -104,8 +108,7 @@ (require 'url-util) ;; Pacify byte-compiler. -(eval-when-compile - (require 'custom)) +(eval-when-compile (require 'custom)) (declare-function zeroconf-init "zeroconf") (declare-function zeroconf-list-service-types "zeroconf") @@ -121,16 +124,19 @@ (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 ;; Until Emacs 25, `process-attributes' could crash Emacs + ;; for some processes. Better we don't check. + (<= emacs-major-version 25) + (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 +144,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 +159,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 +185,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 +475,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,38 +689,41 @@ 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")) "List of cons cells, mapping \"gvfs-<command>\" to \"gio <command>\".") ;; <http://www.pygtk.org/docs/pygobject/gio-constants.html> -(defconst tramp-gvfs-file-attributes - '("name" - "type" - "standard::display-name" - "standard::symlink-target" - "standard::is-volatile" - "unix::nlink" - "unix::uid" - "owner::user" - "unix::gid" - "owner::group" - "time::access" - "time::modified" - "time::changed" - "standard::size" - "unix::mode" - "access::can-read" - "access::can-write" - "access::can-execute" - "unix::inode" - "unix::device") - "GVFS file attributes.") - -(defconst tramp-gvfs-file-attributes-with-gvfs-ls-regexp - (concat "[[:blank:]]" (regexp-opt tramp-gvfs-file-attributes t) "=\\(.+?\\)") - "Regexp to parse GVFS file attributes with `gvfs-ls'.") +(eval-and-compile + (defconst tramp-gvfs-file-attributes + '("name" + "type" + "standard::display-name" + "standard::symlink-target" + "standard::is-volatile" + "unix::nlink" + "unix::uid" + "owner::user" + "unix::gid" + "owner::group" + "time::access" + "time::modified" + "time::changed" + "standard::size" + "unix::mode" + "access::can-read" + "access::can-write" + "access::can-execute" + "unix::inode" + "unix::device") + "GVFS file attributes.")) + +(eval-and-compile + (defconst tramp-gvfs-file-attributes-with-gvfs-ls-regexp + (concat "[[:blank:]]" (regexp-opt tramp-gvfs-file-attributes t) "=\\(.+?\\)") + "Regexp to parse GVFS file attributes with `gvfs-ls'.")) (defconst tramp-gvfs-file-attributes-with-gvfs-info-regexp (concat "^[[:blank:]]*" @@ -600,6 +822,8 @@ It has been changed in GVFS 1.14.") (start-file-process . ignore) (substitute-in-file-name . tramp-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-get-remote-gid . tramp-gvfs-handle-get-remote-gid) + (tramp-get-remote-uid . tramp-gvfs-handle-get-remote-uid) (tramp-set-file-uid-gid . tramp-gvfs-handle-set-file-uid-gid) (unhandled-file-name-directory . ignore) (vc-registered . ignore) @@ -625,10 +849,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) @@ -642,20 +865,19 @@ pass to the OPERATION." (defun tramp-gvfs-dbus-string-to-byte-array (string) "Like `dbus-string-to-byte-array' but add trailing \\0 if needed." (dbus-string-to-byte-array - (if (string-match "^(aya{sv})" tramp-gvfs-mountlocation-signature) + (if (string-match-p "^(aya{sv})" tramp-gvfs-mountlocation-signature) (concat string (string 0)) string))) (defun tramp-gvfs-dbus-byte-array-to-string (byte-array) "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 +902,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 +913,15 @@ 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))) + ;; We use `dbus-ignore-errors', because this macro is also called + ;; when loading. + (dbus-ignore-errors (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 +929,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 +938,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 @@ -728,6 +952,10 @@ is no information where to trace the message.") (tramp-error tramp-gvfs-dbus-event-vector 'file-error "%s" (cadr err)))) (add-hook 'dbus-event-error-functions #'tramp-gvfs-dbus-event-error) +(add-hook 'tramp-gvfs-unload-hook + (lambda () + (remove-hook 'dbus-event-error-functions + #'tramp-gvfs-dbus-event-error))) ;; File name primitives. @@ -758,11 +986,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 +1004,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 +1065,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)) @@ -950,10 +1182,11 @@ file names." (with-current-buffer (tramp-get-connection-buffer v) (goto-char (point-min)) (while (looking-at - (concat "^\\(.+\\)[[:blank:]]" - "\\([[:digit:]]+\\)[[:blank:]]" - "(\\(.+?\\))" - tramp-gvfs-file-attributes-with-gvfs-ls-regexp)) + (eval-when-compile + (concat "^\\(.+\\)[[:blank:]]" + "\\([[:digit:]]+\\)[[:blank:]]" + "(\\(.+?\\))" + tramp-gvfs-file-attributes-with-gvfs-ls-regexp))) (let ((item (list (cons "type" (match-string 3)) (cons "standard::size" (match-string 2)) (cons "name" (match-string 1))))) @@ -1054,8 +1287,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." (if (eq id-format 'integer) (string-to-number (or (cdr (assoc "unix::uid" attributes)) - (eval-when-compile - (format "%s" tramp-unknown-id-integer)))) + (eval-when-compile (format "%s" tramp-unknown-id-integer)))) (or (cdr (assoc "owner::user" attributes)) (cdr (assoc "unix::uid" attributes)) tramp-unknown-id-string))) @@ -1063,8 +1295,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." (if (eq id-format 'integer) (string-to-number (or (cdr (assoc "unix::gid" attributes)) - (eval-when-compile - (format "%s" tramp-unknown-id-integer)))) + (eval-when-compile (format "%s" tramp-unknown-id-integer)))) (or (cdr (assoc "owner::group" attributes)) (cdr (assoc "unix::gid" attributes)) tramp-unknown-id-string))) @@ -1244,11 +1475,11 @@ If FILE-SYSTEM is non-nil, return file system attributes." ;; File names are returned as URL paths. We must convert them. (when (string-match ddu file) (setq file (replace-match dd nil nil file))) - (while (string-match-p "%\\([0-9A-F]\\{2\\}\\)" file) + (while (string-match-p "%\\([[:xdigit:]]\\{2\\}\\)" file) (setq file (url-unhex-string file))) (when (string-match ddu (or file1 "")) (setq file1 (replace-match dd nil nil file1))) - (while (string-match-p "%\\([0-9A-F]\\{2\\}\\)" (or file1 "")) + (while (string-match-p "%\\([[:xdigit:]]\\{2\\}\\)" (or file1 "")) (setq file1 (url-unhex-string file1))) ;; Remove watch when file or directory to be watched is deleted. (when (and (member action '(moved deleted)) @@ -1281,7 +1512,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." ;; If the user is different from what we guess to be ;; the user, we don't know. Let's check, whether ;; access is restricted explicitly. - (and (/= (tramp-gvfs-get-remote-uid v 'integer) + (and (/= (tramp-get-remote-uid v 'integer) (tramp-compat-file-attribute-user-id (file-attributes filename 'integer))) (not @@ -1301,10 +1532,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 +1562,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)) @@ -1341,78 +1573,110 @@ If FILE-SYSTEM is non-nil, return file system attributes." (tramp-run-real-handler #'rename-file (list filename newname ok-if-already-exists)))) -(defun tramp-gvfs-handle-set-file-modes (filename mode) +(defun tramp-gvfs-handle-set-file-modes (filename mode &optional flag) "Like `set-file-modes' for Tramp files." (with-parsed-tramp-file-name filename nil (tramp-flush-file-properties v localname) (tramp-gvfs-send-command - v "gvfs-set-attribute" "-t" "uint32" - (tramp-gvfs-url-file-name (tramp-make-tramp-file-name v)) - "unix::mode" (number-to-string mode)))) + v "gvfs-set-attribute" (if (eq flag 'nofollow) "-nt" "-t") "uint32" + (tramp-gvfs-url-file-name filename) "unix::mode" (number-to-string mode)))) -(defun tramp-gvfs-handle-set-file-times (filename &optional time) +(defun tramp-gvfs-handle-set-file-times (filename &optional time flag) "Like `set-file-times' for Tramp files." (with-parsed-tramp-file-name filename nil (tramp-flush-file-properties v localname) - (let ((time - (if (or (null time) + (tramp-gvfs-send-command + v "gvfs-set-attribute" (if (eq flag 'nofollow) "-nt" "-t") "uint64" + (tramp-gvfs-url-file-name filename) "time::modified" + (format-time-string + "%s" (if (or (null time) (tramp-compat-time-equal-p time tramp-time-doesnt-exist) (tramp-compat-time-equal-p time tramp-time-dont-know)) (current-time) - time))) - (tramp-gvfs-send-command - v "gvfs-set-attribute" "-t" "uint64" - (tramp-gvfs-url-file-name (tramp-make-tramp-file-name v)) - "time::modified" (format-time-string "%s" time))))) + time))))) + +(defun tramp-gvfs-handle-get-remote-uid (vec id-format) + "The uid of the remote connection VEC, in ID-FORMAT. +ID-FORMAT valid values are `string' and `integer'." + (if (equal id-format 'string) + (tramp-file-name-user vec) + (when-let + ((localname (tramp-get-connection-property vec "default-location" nil))) + (tramp-compat-file-attribute-user-id + (file-attributes + (tramp-make-tramp-file-name vec localname) id-format))))) + +(defun tramp-gvfs-handle-get-remote-gid (vec id-format) + "The gid of the remote connection VEC, in ID-FORMAT. +ID-FORMAT valid values are `string' and `integer'." + (when-let + ((localname (tramp-get-connection-property vec "default-location" nil))) + (tramp-compat-file-attribute-group-id + (file-attributes + (tramp-make-tramp-file-name vec localname) id-format)))) -(defun tramp-gvfs-set-file-uid-gid (filename &optional uid gid) +(defun tramp-gvfs-handle-set-file-uid-gid (filename &optional uid gid) "Like `tramp-set-file-uid-gid' for Tramp files." (with-parsed-tramp-file-name filename nil (tramp-flush-file-properties v localname) (when (natnump uid) (tramp-gvfs-send-command v "gvfs-set-attribute" "-t" "uint32" - (tramp-gvfs-url-file-name (tramp-make-tramp-file-name v)) - "unix::uid" (number-to-string uid))) + (tramp-gvfs-url-file-name filename) "unix::uid" (number-to-string uid))) (when (natnump gid) (tramp-gvfs-send-command v "gvfs-set-attribute" "-t" "uint32" - (tramp-gvfs-url-file-name (tramp-make-tramp-file-name v)) + (tramp-gvfs-url-file-name filename) "unix::gid" (number-to-string gid))))) ;; 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 +1688,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. @@ -1490,8 +1762,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." (list t ;; handled. nil ;; no abort of D-Bus. - (with-tramp-connection-property - (tramp-get-connection-process v) message + (with-tramp-connection-property (tramp-get-process v) message ;; In theory, there can be several choices. ;; Until now, there is only the question whether ;; to accept an unknown host signature or certificate. @@ -1564,11 +1835,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 +1936,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)) @@ -1683,8 +1976,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." (tramp-gvfs-url-file-name (tramp-make-tramp-file-name vec)))) (while (tramp-gvfs-connection-mounted-p vec) (read-event nil nil 0.1)) - (tramp-flush-connection-properties vec) - (tramp-flush-connection-properties (tramp-get-connection-process vec))) + (tramp-cleanup-connection vec 'keep-debug 'keep-password)) (defun tramp-gvfs-mount-spec-entry (key value) "Construct a mount-spec entry to be used in a mount_spec. @@ -1696,11 +1988,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,42 +2048,41 @@ 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. -(defun tramp-gvfs-get-remote-uid (vec id-format) - "The uid of the remote connection VEC, in ID-FORMAT. -ID-FORMAT valid values are `string' and `integer'." - (with-tramp-connection-property vec (format "uid-%s" id-format) - (let ((user (tramp-file-name-user vec)) - (localname - (tramp-get-connection-property vec "default-location" nil))) - (cond - ((and (equal id-format 'string) user)) - (localname - (tramp-compat-file-attribute-user-id - (file-attributes - (tramp-make-tramp-file-name vec localname) id-format))) - ((equal id-format 'integer) tramp-unknown-id-integer) - ((equal id-format 'string) tramp-unknown-id-string))))) - -(defun tramp-gvfs-get-remote-gid (vec id-format) - "The gid of the remote connection VEC, in ID-FORMAT. -ID-FORMAT valid values are `string' and `integer'." - (with-tramp-connection-property vec (format "gid-%s" id-format) - (let ((localname - (tramp-get-connection-property vec "default-location" nil))) - (cond - (localname - (tramp-compat-file-attribute-group-id - (file-attributes - (tramp-make-tramp-file-name vec localname) id-format))) - ((equal id-format 'integer) tramp-unknown-id-integer) - ((equal id-format 'string) tramp-unknown-id-string))))) - -(defvar tramp-gvfs-get-remote-uid-gid-in-progress nil - "Indication, that remote uid and gid determination is in progress.") - (defun tramp-gvfs-get-remote-prefix (vec) "The prefix of the remote connection VEC. This is relevant for GNOME Online Accounts." @@ -1794,7 +2090,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 +2139,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)))) @@ -1926,16 +2222,7 @@ connection if a previous connection has died for some reason." ;; Mark it as connected. (tramp-set-connection-property - (tramp-get-connection-process vec) "connected" t)))) - - ;; In `tramp-check-cached-permissions', the connection properties - ;; "{uid,gid}-{integer,string}" are used. We set them to proper values. - (unless tramp-gvfs-get-remote-uid-gid-in-progress - (let ((tramp-gvfs-get-remote-uid-gid-in-progress t)) - (tramp-gvfs-get-remote-uid vec 'integer) - (tramp-gvfs-get-remote-gid vec 'integer) - (tramp-gvfs-get-remote-uid vec 'string) - (tramp-gvfs-get-remote-gid vec 'string)))) + (tramp-get-connection-process vec) "connected" t))))) (defun tramp-gvfs-gio-tool-p (vec) "Check, whether the gio tool is available." @@ -1968,12 +2255,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 +2268,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 +2299,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 +2323,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 +2441,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 - "afp" '((tramp-gvfs-parse-device-names "_afpovertcp._tcp"))) + "ftp" `((,fun "_ftp._tcp")))) + (when (member "http" tramp-gvfs-methods) (tramp-set-completion-function - "dav" '((tramp-gvfs-parse-device-names "_webdav._tcp"))) + "http" `((,fun "_http._tcp") + (,fun "_https._tcp")))) + (when (member "https" tramp-gvfs-methods) (tramp-set-completion-function - "davs" '((tramp-gvfs-parse-device-names "_webdav._tcp"))) + "https" `((,fun "_http._tcp") + (,fun "_https._tcp")))) + (when (member "sftp" 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")))))))) + "sftp" `((,fun "_sftp-ssh._tcp") + (,fun "_ssh._tcp") + (,fun "_workstation._tcp")))) + (when (member "smb" tramp-gvfs-methods) + (tramp-set-completion-function + "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 +2509,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..3701bfc22c9 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -135,6 +135,8 @@ (start-file-process . ignore) (substitute-in-file-name . tramp-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-get-remote-gid . ignore) + (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) (vc-registered . ignore) @@ -157,10 +159,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 +221,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 +272,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 +430,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)) @@ -458,7 +459,7 @@ file names." ;; to cache a nil result. (or (tramp-get-connection-property (tramp-get-connection-process vec) "mounted" nil) - (let* ((default-directory temporary-file-directory) + (let* ((default-directory (tramp-compat-temporary-file-directory)) (mount (shell-command-to-string "mount -t fuse.rclone"))) (tramp-message vec 6 "%s" "mount -t fuse.rclone") (tramp-message vec 6 "\n%s" mount) @@ -478,7 +479,19 @@ file names." (with-tramp-connection-property (tramp-get-connection-process vec) "rclone-pid" (catch 'pid - (dolist (pid (list-system-processes)) ;; "pidof rclone" ? + (dolist + (pid + ;; Until Emacs 25, `process-attributes' could + ;; crash Emacs for some processes. So we use + ;; "pidof", which might not work everywhere. + (if (<= emacs-major-version 25) + (let ((default-directory + (tramp-compat-temporary-file-directory))) + (mapcar + #'string-to-number + (split-string + (shell-command-to-string "pidof rclone")))) + (list-system-processes))) (and (string-match-p (regexp-quote (format "rclone mount %s:" (tramp-file-name-host vec))) @@ -564,7 +577,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..ca43475f453 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -36,6 +36,7 @@ (declare-function dired-remove-file "dired-aux") (defvar dired-compress-file-suffixes) +(defvar process-file-return-signal-string) (defvar vc-handled-backends) (defvar vc-bzr-program) (defvar vc-git-program) @@ -90,10 +91,10 @@ the default storage location, e.g. \"$HOME/.sh_history\"." (string :tag "Redirect to a file"))) ;;;###tramp-autoload -(defconst tramp-display-escape-sequence-regexp "\e[[;0-9]+m" +(defconst tramp-display-escape-sequence-regexp "\e[[:digit:];[]+m" "Terminal control escape sequences for display attributes.") -(defconst tramp-device-escape-sequence-regexp "\e[[0-9]+n" +(defconst tramp-device-escape-sequence-regexp "\e[[:digit:][]+n" "Terminal control escape sequences for device status.") ;; ksh on OpenBSD 4.5 requires that $PS1 contains a `#' character for @@ -481,6 +482,7 @@ The string is used in `tramp-methods'.") ;; Darwin: /usr/bin:/bin:/usr/sbin:/sbin ;; IRIX64: /usr/bin ;; QNAP QTS: --- +;; Hydra: /run/current-system/sw/bin:/bin:/usr/bin ;;;###tramp-autoload (defcustom tramp-remote-path '(tramp-default-remote-path "/bin" "/usr/bin" "/sbin" "/usr/sbin" @@ -491,8 +493,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 +539,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 +869,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 +904,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 +947,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 @@ -1025,6 +1040,8 @@ of command line.") (start-file-process . tramp-handle-start-file-process) (substitute-in-file-name . tramp-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-get-remote-gid . tramp-sh-handle-get-remote-gid) + (tramp-get-remote-uid . tramp-sh-handle-get-remote-uid) (tramp-set-file-uid-gid . tramp-sh-handle-set-file-uid-gid) (unhandled-file-name-directory . ignore) (vc-registered . tramp-sh-handle-vc-registered) @@ -1051,9 +1068,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 +1119,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) @@ -1142,59 +1156,9 @@ component is used as the target of the symlink." (tramp-shell-quote-argument localname))))) ;; Do it yourself. - (t (let ((steps (split-string localname "/" 'omit)) - (thisstep nil) - (numchase 0) - ;; Don't make the following value larger than - ;; necessary. People expect an error message in a - ;; timely fashion when something is wrong; - ;; otherwise they might think that Emacs is hung. - ;; Of course, correctness has to come first. - (numchase-limit 20) - symlink-target) - (while (and steps (< numchase numchase-limit)) - (setq thisstep (pop steps)) - (tramp-message - v 5 "Check %s" - (string-join - (append '("") (reverse result) (list thisstep)) "/")) - (setq symlink-target - (tramp-compat-file-attribute-type - (file-attributes - (tramp-make-tramp-file-name - v - (string-join - (append - '("") (reverse result) (list thisstep)) "/") - 'nohop)))) - (cond ((string= "." thisstep) - (tramp-message v 5 "Ignoring step `.'")) - ((string= ".." thisstep) - (tramp-message v 5 "Processing step `..'") - (pop result)) - ((stringp symlink-target) - ;; It's a symlink, follow it. - (tramp-message - v 5 "Follow symlink to %s" symlink-target) - (setq numchase (1+ numchase)) - (when (file-name-absolute-p symlink-target) - (setq result nil)) - (setq steps - (append - (split-string symlink-target "/" 'omit) - steps))) - (t - ;; It's a file. - (setq result (cons thisstep result))))) - (when (>= numchase numchase-limit) - (tramp-error - v 'file-error - "Maximum number (%d) of symlinks exceeded" numchase-limit)) - (setq result (reverse result)) - ;; Combine list to form string. - (setq result - (if result (string-join (cons "" result) "/") "/")) - (when (string-empty-p result) (setq result "/"))))) + (t (setq + result + (tramp-file-local-name (tramp-handle-file-truename filename))))) ;; Detect cycle. (when (and (file-symlink-p filename) @@ -1263,8 +1227,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. @@ -1366,20 +1330,12 @@ component is used as the target of the symlink." (tramp-send-command-and-read vec (format - (eval-when-compile - (concat - ;; On Opsware, pdksh (which is the true name of ksh there) - ;; doesn't parse correctly the sequence "((". Therefore, we - ;; add a space. Apostrophes in the stat output are masked as - ;; `tramp-stat-marker', in order to make a proper shell escape - ;; of them in file names. - "( (%s %s || %s -h %s) && (%s -c " - "'((%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)' " - "%s | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g') || echo nil)")) - (tramp-get-file-exists-command vec) - (tramp-shell-quote-argument localname) - (tramp-get-test-command vec) - (tramp-shell-quote-argument localname) + (concat + ;; Apostrophes in the stat output are masked as + ;; `tramp-stat-marker', in order to make a proper shell escape of + ;; them in file names. + "(%s -c '((%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)' %s |" + " sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g')") (tramp-get-remote-stat vec) tramp-stat-marker tramp-stat-marker (if (eq id-format 'integer) @@ -1390,7 +1346,8 @@ component is used as the target of the symlink." (eval-when-compile (concat tramp-stat-marker "%G" tramp-stat-marker))) tramp-stat-marker tramp-stat-marker (tramp-shell-quote-argument localname) - tramp-stat-quoted-marker))) + tramp-stat-quoted-marker) + 'noerror)) (defun tramp-sh-handle-set-visited-file-modtime (&optional time-list) "Like `set-visited-file-modtime' for Tramp files." @@ -1468,17 +1425,24 @@ of." ;; only if that agrees with the buffer's record. (t (tramp-compat-time-equal-p mt tramp-time-doesnt-exist))))))))) -(defun tramp-sh-handle-set-file-modes (filename mode) +(defun tramp-sh-handle-set-file-modes (filename mode &optional flag) "Like `set-file-modes' for Tramp files." (with-parsed-tramp-file-name filename nil - (tramp-flush-file-properties v localname) - ;; FIXME: extract the proper text from chmod's stderr. - (tramp-barf-unless-okay - v - (format "chmod %o %s" mode (tramp-shell-quote-argument localname)) - "Error while changing file's mode %s" filename))) + ;; We need "chmod -h" when the flag is set. + (when (or (not (eq flag 'nofollow)) + (not (file-symlink-p filename)) + (tramp-get-remote-chmod-h v)) + (tramp-flush-file-properties v localname) + ;; FIXME: extract the proper text from chmod's stderr. + (tramp-barf-unless-okay + v + (format + "chmod %s %o %s" + (if (and (eq flag 'nofollow) (tramp-get-remote-chmod-h v)) "-h" "") + mode (tramp-shell-quote-argument localname)) + "Error while changing file's mode %s" filename)))) -(defun tramp-sh-handle-set-file-times (filename &optional time) +(defun tramp-sh-handle-set-file-times (filename &optional time flag) "Like `set-file-times' for Tramp files." (with-parsed-tramp-file-name filename nil (when (tramp-get-remote-touch v) @@ -1491,13 +1455,34 @@ of." time))) (tramp-send-command-and-check v (format - "env TZ=UTC %s %s %s" + "env TZ=UTC %s %s %s %s" (tramp-get-remote-touch v) (if (tramp-get-connection-property v "touch-t" nil) (format "-t %s" (format-time-string "%Y%m%d%H%M.%S" time t)) "") + (if (eq flag 'nofollow) "-h" "") (tramp-shell-quote-argument localname))))))) +(defun tramp-sh-handle-get-remote-uid (vec id-format) + "The uid of the remote connection VEC, in ID-FORMAT. +ID-FORMAT valid values are `string' and `integer'." + (ignore-errors + (cond + ((tramp-get-remote-id vec) (tramp-get-remote-uid-with-id vec id-format)) + ((tramp-get-remote-perl vec) (tramp-get-remote-uid-with-perl vec id-format)) + ((tramp-get-remote-python vec) + (tramp-get-remote-uid-with-python vec id-format))))) + +(defun tramp-sh-handle-get-remote-gid (vec id-format) + "The gid of the remote connection VEC, in ID-FORMAT. +ID-FORMAT valid values are `string' and `integer'." + (ignore-errors + (cond + ((tramp-get-remote-id vec) (tramp-get-remote-gid-with-id vec id-format)) + ((tramp-get-remote-perl vec) (tramp-get-remote-gid-with-perl vec id-format)) + ((tramp-get-remote-python vec) + (tramp-get-remote-gid-with-python vec id-format))))) + (defun tramp-sh-handle-set-file-uid-gid (filename &optional uid gid) "Like `tramp-set-file-uid-gid' for Tramp files." ;; Modern Unices allow chown only for root. So we might need @@ -1521,7 +1506,7 @@ of." (defun tramp-remote-selinux-p (vec) "Check, whether SELINUX is enabled on the remote host." - (with-tramp-connection-property (tramp-get-connection-process vec) "selinux-p" + (with-tramp-connection-property (tramp-get-process vec) "selinux-p" (tramp-send-command-and-check vec "selinuxenabled"))) (defun tramp-sh-handle-file-selinux-context (filename) @@ -1529,9 +1514,8 @@ of." (with-parsed-tramp-file-name filename nil (with-tramp-file-property v localname "file-selinux-context" (let ((context '(nil nil nil nil)) - (regexp (eval-when-compile - (concat "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\):" - "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\)")))) + (regexp (concat "\\([[:alnum:]_]+\\):" "\\([[:alnum:]_]+\\):" + "\\([[:alnum:]_]+\\):" "\\([[:alnum:]_]+\\)"))) (when (and (tramp-remote-selinux-p v) (tramp-send-command-and-check v (format @@ -1570,7 +1554,7 @@ of." (defun tramp-remote-acl-p (vec) "Check, whether ACL is enabled on the remote host." - (with-tramp-connection-property (tramp-get-connection-process vec) "acl-p" + (with-tramp-connection-property (tramp-get-process vec) "acl-p" (tramp-send-command-and-check vec "getfacl /"))) (defun tramp-sh-handle-file-acl (filename) @@ -1700,8 +1684,10 @@ of." (defun tramp-sh-handle-file-ownership-preserved-p (filename &optional group) "Like `file-ownership-preserved-p' for Tramp files." (with-parsed-tramp-file-name filename nil - (with-tramp-file-property v localname "file-ownership-preserved-p" - (let ((attributes (file-attributes filename))) + (with-tramp-file-property + v localname + (format "file-ownership-preserved-p%s" (if group "-group" "")) + (let ((attributes (file-attributes filename 'integer))) ;; Return t if the file doesn't exist, since it's true that no ;; information would be lost by an (attempted) delete and create. (or (null attributes) @@ -1779,21 +1765,19 @@ of." (tramp-send-command-and-read vec (format - (eval-when-compile - (concat - ;; We must care about file names with spaces, or starting with - ;; "-"; this would confuse xargs. "ls -aQ" might be a - ;; solution, but it does not work on all remote systems. - ;; Therefore, we use \000 as file separator. - ;; `tramp-sh--quoting-style-options' do not work for file names - ;; with spaces piped to "xargs". - ;; Apostrophes in the stat output are masked as - ;; `tramp-stat-marker', in order to make a proper shell escape - ;; of them in file names. - "cd %s && echo \"(\"; (%s %s -a | tr '\\n\\r' '\\000\\000' | " - "xargs -0 %s -c " - "'(%s%%n%s (%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)' " - "-- 2>/dev/null | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g'); echo \")\"")) + (concat + ;; We must care about file names with spaces, or starting with + ;; "-"; this would confuse xargs. "ls -aQ" might be a solution, + ;; but it does not work on all remote systems. Therefore, we use + ;; \000 as file separator. `tramp-sh--quoting-style-options' do + ;; not work for file names with spaces piped to "xargs". + ;; Apostrophes in the stat output are masked as + ;; `tramp-stat-marker', in order to make a proper shell escape of + ;; them in file names. + "cd %s && echo \"(\"; (%s %s -a | tr '\\n\\r' '\\000\\000' | " + "xargs -0 %s -c " + "'(%s%%n%s (%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)' " + "-- 2>/dev/null | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g'); echo \")\"") (tramp-shell-quote-argument localname) (tramp-get-ls-command vec) ;; On systems which have no quoting style, file names with special @@ -1834,13 +1818,12 @@ of." (format "tramp_perl_file_name_all_completions %s" (tramp-shell-quote-argument localname))) - (format (eval-when-compile - (concat - "(cd %s 2>&1 && %s -a 2>/dev/null" - " | while IFS= read f; do" - " if %s -d \"$f\" 2>/dev/null;" - " then \\echo \"$f/\"; else \\echo \"$f\"; fi; done" - " && \\echo ok) || \\echo fail")) + (format (concat + "(cd %s 2>&1 && %s -a 2>/dev/null" + " | while IFS= read f; do" + " if %s -d \"$f\" 2>/dev/null;" + " then \\echo \"$f/\"; else \\echo \"$f\"; fi; done" + " && \\echo ok) || \\echo fail") (tramp-shell-quote-argument localname) (tramp-get-ls-command v) (tramp-get-test-command v)))) @@ -1948,7 +1931,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))) @@ -1961,7 +1944,7 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'" (unless (file-directory-p (file-name-directory newname)) (make-directory (file-name-directory newname) parents)) (tramp-do-copy-or-rename-file-out-of-band - 'copy dirname newname keep-date)) + 'copy dirname newname 'ok-if-already-exists keep-date)) ;; We must do it file-wise. (tramp-run-real-handler @@ -1978,8 +1961,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 +2013,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 @@ -2057,7 +2040,7 @@ file names." (tramp-method-out-of-band-p v1 length) (tramp-method-out-of-band-p v2 length)) (tramp-do-copy-or-rename-file-out-of-band - op filename newname keep-date)) + op filename newname ok-if-already-exists keep-date)) ;; No shortcut was possible. So we copy the file ;; first. If the operation was `rename', we go back @@ -2070,7 +2053,7 @@ file names." ;; source and target file. (t (tramp-do-copy-or-rename-file-via-buffer - op filename newname keep-date)))))) + op filename newname ok-if-already-exists keep-date)))))) ;; One file is a Tramp file, the other one is local. ((or t1 t2) @@ -2085,11 +2068,11 @@ file names." ;; corresponding copy-program can be invoked. ((tramp-method-out-of-band-p v length) (tramp-do-copy-or-rename-file-out-of-band - op filename newname keep-date)) + op filename newname ok-if-already-exists keep-date)) ;; Use the inline method via a Tramp buffer. (t (tramp-do-copy-or-rename-file-via-buffer - op filename newname keep-date)))) + op filename newname ok-if-already-exists keep-date)))) (t ;; One of them must be a Tramp file. @@ -2111,7 +2094,8 @@ file names." (with-parsed-tramp-file-name newname v2 (tramp-flush-file-properties v2 v2-localname)))))))) -(defun tramp-do-copy-or-rename-file-via-buffer (op filename newname keep-date) +(defun tramp-do-copy-or-rename-file-via-buffer + (op filename newname ok-if-already-exists keep-date) "Use an Emacs buffer to copy or rename a file. First arg OP is either `copy' or `rename' and indicates the operation. FILENAME is the source file, NEWNAME the target file. @@ -2139,10 +2123,11 @@ KEEP-DATE is non-nil if NEWNAME should have the same timestamp as FILENAME." (insert-file-contents-literally filename))) ;; KEEP-DATE handling. (when keep-date - (set-file-times + (tramp-compat-set-file-times newname (tramp-compat-file-attribute-modification-time - (file-attributes filename)))) + (file-attributes filename)) + (unless ok-if-already-exists 'nofollow))) ;; Set the mode. (set-file-modes newname (tramp-default-file-modes filename)) ;; If the operation was `rename', delete the original file. @@ -2171,8 +2156,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)) @@ -2296,10 +2281,12 @@ the uid and gid from FILENAME." ;; Set the time and mode. Mask possible errors. (ignore-errors (when keep-date - (set-file-times newname file-times) + (tramp-compat-set-file-times + newname file-times (unless ok-if-already-exists 'nofollow)) (set-file-modes newname file-modes)))))) -(defun tramp-do-copy-or-rename-file-out-of-band (op filename newname keep-date) +(defun tramp-do-copy-or-rename-file-out-of-band + (op filename newname ok-if-already-exists keep-date) "Invoke `scp' program to copy. The method used must be an out-of-band method." (let* ((t1 (tramp-tramp-file-p filename)) @@ -2322,9 +2309,9 @@ The method used must be an out-of-band method." (unwind-protect (progn (tramp-do-copy-or-rename-file-out-of-band - op filename tmpfile keep-date) + op filename tmpfile ok-if-already-exists keep-date) (tramp-do-copy-or-rename-file-out-of-band - 'rename tmpfile newname keep-date)) + 'rename tmpfile newname ok-if-already-exists keep-date)) ;; Save exit. (ignore-errors (if dir-flag @@ -2498,10 +2485,11 @@ The method used must be an out-of-band method." ;; Handle KEEP-DATE argument. (when (and keep-date (not copy-keep-date)) - (set-file-times + (tramp-compat-set-file-times newname (tramp-compat-file-attribute-modification-time - (file-attributes filename)))) + (file-attributes filename)) + (unless ok-if-already-exists 'nofollow))) ;; Set the mode. (unless (and keep-date copy-keep-date) @@ -2714,7 +2702,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 +2712,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,201 +2783,291 @@ 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." - (when args - (with-parsed-tramp-file-name (expand-file-name default-directory) nil - (let ((name (plist-get args :name)) - (buffer (plist-get args :buffer)) - (command (plist-get args :command)) - (coding (plist-get args :coding)) - (noquery (plist-get args :noquery)) - (connection-type (plist-get args :connection-type)) - (filter (plist-get args :filter)) - (sentinel (plist-get args :sentinel)) - (stderr (plist-get args :stderr))) - (unless (stringp name) - (signal 'wrong-type-argument (list #'stringp name))) - (unless (or (null buffer) (bufferp buffer) (stringp buffer)) - (signal 'wrong-type-argument (list #'stringp buffer))) - (unless (consp command) - (signal 'wrong-type-argument (list #'consp command))) - (unless (or (null coding) - (and (symbolp coding) (memq coding coding-system-list)) - (and (consp coding) - (memq (car coding) coding-system-list) - (memq (cdr coding) coding-system-list))) - (signal 'wrong-type-argument (list #'symbolp coding))) - (unless (or (null connection-type) (memq connection-type '(pipe pty))) - (signal 'wrong-type-argument (list #'symbolp connection-type))) - (unless (or (null filter) (functionp filter)) - (signal 'wrong-type-argument (list #'functionp filter))) - (unless (or (null sentinel) (functionp sentinel)) - (signal 'wrong-type-argument (list #'functionp sentinel))) - (unless (or (null stderr) (bufferp stderr) (stringp stderr)) - (signal 'wrong-type-argument (list #'stringp stderr))) - - (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))) - (program (car command)) - (args (cdr command)) - ;; When PROGRAM matches "*sh", and the first arg is - ;; "-c", it might be that the arguments exceed the - ;; command line length. Therefore, we modify the - ;; command. - (heredoc (and (stringp program) - (string-match-p "sh$" program) - (string-equal "-c" (car args)) - (= (length args) 2))) - ;; When PROGRAM is nil, we just provide a tty. - (args (if (not heredoc) args - (let ((i 250)) - (while (and (< i (length (cadr args))) - (string-match " " (cadr args) i)) - (setcdr - args - (list - (replace-match " \\\\\n" nil nil (cadr args)))) - (setq i (+ i 250)))) - (cdr args))) - ;; Use a human-friendly prompt, for example for - ;; `shell'. We discard hops, if existing, that's why - ;; we cannot use `file-remote-p'. - (prompt (format "PS1=%s %s" - (tramp-make-tramp-file-name v nil 'nohop) - tramp-initial-end-of-output)) - ;; We use as environment the difference to toplevel - ;; `process-environment'. - env uenv - (env (dolist (elt (cons prompt process-environment) env) - (or (member - elt (default-toplevel-value 'process-environment)) - (if (string-match-p "=" elt) - (setq env (append env `(,elt))) - (if (tramp-get-env-with-u-option v) - (setq env (append `("-u" ,elt) env)) - (setq uenv (cons elt uenv))))))) - (command - (when (stringp program) - (format "cd %s && %s exec %s %s env %s %s" - (tramp-shell-quote-argument localname) - (if uenv - (format - "unset %s &&" - (mapconcat - #'tramp-shell-quote-argument uenv " ")) - "") - (if heredoc (format "<<'%s'" tramp-end-of-heredoc) "") - (if tmpstderr (format "2>'%s'" tmpstderr) "") - (mapconcat #'tramp-shell-quote-argument env " ") - (if heredoc - (format "%s\n(\n%s\n) </dev/tty\n%s" - program (car args) tramp-end-of-heredoc) - (mapconcat #'tramp-shell-quote-argument - (cons program args) " "))))) - (tramp-process-connection-type - (or (null program) tramp-process-connection-type)) - (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer))) - (name1 name) - (i 0) - ;; We do not want to raise an error when `make-process' - ;; has been started several times in `eshell' and - ;; friends. - tramp-current-connection - p) - - (while (get-process name1) - ;; NAME must be unique as process name. - (setq i (1+ i) - name1 (format "%s<%d>" name i))) - (setq name name1) - ;; Set the new process properties. - (tramp-set-connection-property v "process-name" name) - (tramp-set-connection-property v "process-buffer" buffer) - - (with-current-buffer (tramp-get-connection-buffer v) - (unwind-protect - ;; We catch this event. Otherwise, `make-process' could - ;; be called on the local host. - (save-excursion - (save-restriction - ;; Activate narrowing in order to save BUFFER - ;; contents. Clear also the modification time; - ;; otherwise we might be interrupted by - ;; `verify-visited-file-modtime'. - (let ((buffer-undo-list t) - (inhibit-read-only t) - (mark (point-max))) - (clear-visited-file-modtime) - (narrow-to-region (point-max) (point-max)) - ;; We call `tramp-maybe-open-connection', in - ;; order to cleanup the prompt afterwards. - (catch 'suppress - (tramp-maybe-open-connection v) - (setq p (tramp-get-connection-process v)) - ;; Set the pid of the remote shell. This is - ;; needed when sending signals remotely. - (let ((pid (tramp-send-command-and-read v "echo $$"))) - (process-put p 'remote-pid pid) - (tramp-set-connection-property p "remote-pid" pid)) - ;; `tramp-maybe-open-connection' and - ;; `tramp-send-command-and-read' could have - ;; trashed the connection buffer. Remove this. - (widen) - (delete-region mark (point-max)) + "Like `make-process' for Tramp files. +STDERR can also be a file name. If connection property +\"direct-async-process\" is non-nil, an alternative +implementation will be used." + (if (tramp-direct-async-process-p args) + (apply #'tramp-handle-make-process args) + (when args + (with-parsed-tramp-file-name (expand-file-name default-directory) nil + (let ((name (plist-get args :name)) + (buffer (plist-get args :buffer)) + (command (plist-get args :command)) + (coding (plist-get args :coding)) + (noquery (plist-get args :noquery)) + (connection-type (plist-get args :connection-type)) + (filter (plist-get args :filter)) + (sentinel (plist-get args :sentinel)) + (stderr (plist-get args :stderr))) + (unless (stringp name) + (signal 'wrong-type-argument (list #'stringp name))) + (unless (or (null buffer) (bufferp buffer) (stringp buffer)) + (signal 'wrong-type-argument (list #'stringp buffer))) + (unless (consp command) + (signal 'wrong-type-argument (list #'consp command))) + (unless (or (null coding) + (and (symbolp coding) (memq coding coding-system-list)) + (and (consp coding) + (memq (car coding) coding-system-list) + (memq (cdr coding) coding-system-list))) + (signal 'wrong-type-argument (list #'symbolp coding))) + (unless (or (null connection-type) (memq connection-type '(pipe pty))) + (signal 'wrong-type-argument (list #'symbolp connection-type))) + (unless (or (null filter) (functionp filter)) + (signal 'wrong-type-argument (list #'functionp filter))) + (unless (or (null sentinel) (functionp sentinel)) + (signal 'wrong-type-argument (list #'functionp sentinel))) + (unless (or (null stderr) (bufferp stderr) (stringp stderr)) + (signal 'wrong-type-argument (list #'stringp stderr))) + (when (and (stringp stderr) (tramp-tramp-file-p stderr) + (not (tramp-equal-remote default-directory stderr))) + (signal 'file-error (list "Wrong stderr" stderr))) + + (let* ((buffer + (if buffer + (get-buffer-create buffer) + ;; BUFFER can be nil. We use a temporary buffer. + (generate-new-buffer tramp-temp-buffer-name))) + ;; STDERR can also be a file name. + (tmpstderr + (and stderr + (if (and (stringp stderr) (tramp-tramp-file-p stderr)) + (tramp-unquote-file-local-name stderr) + (tramp-make-tramp-temp-file v)))) + (remote-tmpstderr + (and tmpstderr (tramp-make-tramp-file-name v tmpstderr))) + (program (car command)) + (args (cdr command)) + ;; When PROGRAM matches "*sh", and the first arg is + ;; "-c", it might be that the arguments exceed the + ;; command line length. Therefore, we modify the + ;; command. + (heredoc (and (stringp program) + (string-match-p "sh$" program) + (string-equal "-c" (car args)) + (= (length args) 2))) + ;; When PROGRAM is nil, we just provide a tty. + (args (if (not heredoc) args + (let ((i 250)) + (while (and (< i (length (cadr args))) + (string-match " " (cadr args) i)) + (setcdr + args + (list + (replace-match " \\\\\n" nil nil (cadr args)))) + (setq i (+ i 250)))) + (cdr args))) + ;; Use a human-friendly prompt, for example for + ;; `shell'. We discard hops, if existing, that's why + ;; we cannot use `file-remote-p'. + (prompt (format "PS1=%s %s" + (tramp-make-tramp-file-name v nil 'nohop) + tramp-initial-end-of-output)) + ;; We use as environment the difference to toplevel + ;; `process-environment'. + env uenv + (env (dolist (elt (cons prompt process-environment) env) + (or (member + elt (default-toplevel-value 'process-environment)) + (if (string-match-p "=" elt) + (setq env (append env `(,elt))) + (if (tramp-get-env-with-u-option v) + (setq env (append `("-u" ,elt) env)) + (setq uenv (cons elt uenv))))))) + (command + (when (stringp program) + (setenv-internal + env "INSIDE_EMACS" + (concat (or (getenv "INSIDE_EMACS") emacs-version) + ",tramp:" tramp-version) + 'keep) + (format "cd %s && %s exec %s %s env %s %s" + (tramp-shell-quote-argument localname) + (if uenv + (format + "unset %s &&" + (mapconcat + #'tramp-shell-quote-argument uenv " ")) + "") + (if heredoc (format "<<'%s'" tramp-end-of-heredoc) "") + (if tmpstderr (format "2>'%s'" tmpstderr) "") + (mapconcat #'tramp-shell-quote-argument env " ") + (if heredoc + (format "%s\n(\n%s\n) </dev/tty\n%s" + program (car args) tramp-end-of-heredoc) + (mapconcat #'tramp-shell-quote-argument + (cons program args) " "))))) + (tramp-process-connection-type + (or (null program) tramp-process-connection-type)) + (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer))) + (name1 name) + (i 0) + ;; We do not want to raise an error when + ;; `make-process' has been started several times in + ;; `eshell' and friends. + tramp-current-connection + p) + + (while (get-process name1) + ;; NAME must be unique as process name. + (setq i (1+ i) + name1 (format "%s<%d>" name i))) + (setq name name1) + ;; Set the new process properties. + (tramp-set-connection-property v "process-name" name) + (tramp-set-connection-property v "process-buffer" buffer) + + (with-current-buffer (tramp-get-connection-buffer v) + (unwind-protect + ;; We catch this event. Otherwise, `make-process' + ;; could be called on the local host. + (save-excursion + (save-restriction + ;; Activate narrowing in order to save BUFFER + ;; contents. Clear also the modification time; + ;; otherwise we might be interrupted by + ;; `verify-visited-file-modtime'. + (let ((buffer-undo-list t) + (inhibit-read-only t) + (mark (point-max))) + (clear-visited-file-modtime) (narrow-to-region (point-max) (point-max)) - ;; Now do it. - (if command - ;; Send the command. - (tramp-send-command v command nil t) ; nooutput - ;; Check, whether a pty is associated. - (unless (process-get p 'remote-tty) - (tramp-error - v 'file-error - "pty association is not supported for `%s'" - name)))) - ;; Set sentinel and filter. - (when sentinel - (set-process-sentinel p sentinel)) - (when filter - (set-process-filter p filter)) - ;; Set query flag and process marker for this - ;; process. We ignore errors, because the - ;; process could have finished already. - (ignore-errors - (set-process-query-on-exit-flag p (null noquery)) - (set-marker (process-mark p) (point))) - ;; 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 call `tramp-maybe-open-connection', in + ;; order to cleanup the prompt afterwards. + (catch 'suppress + (tramp-maybe-open-connection v) + (setq p (tramp-get-connection-process v)) + ;; Set the pid of the remote shell. This is + ;; needed when sending signals remotely. + (let ((pid (tramp-send-command-and-read v "echo $$"))) + (process-put p 'remote-pid pid) + (tramp-set-connection-property p "remote-pid" pid)) + ;; `tramp-maybe-open-connection' and + ;; `tramp-send-command-and-read' could have + ;; trashed the connection buffer. Remove this. + (widen) + (delete-region mark (point-max)) + (narrow-to-region (point-max) (point-max)) + ;; Now do it. + (if command + ;; Send the command. + (tramp-send-command v command nil t) ; nooutput + ;; Check, whether a pty is associated. + (unless (process-get p 'remote-tty) + (tramp-error + v 'file-error + "pty association is not supported for `%s'" + name)))) + ;; Set sentinel and filter. + (when sentinel + (set-process-sentinel p sentinel)) + (when filter + (set-process-filter p filter)) + ;; Set query flag and process marker for this + ;; process. We ignore errors, because the + ;; process could have finished already. + (ignore-errors + (set-process-query-on-exit-flag p (null noquery)) + (set-marker (process-mark p) (point))) ;; We must flush them here already; otherwise + ;; `rename-file', `delete-file' or ;; `insert-file-contents' will fail. (tramp-flush-connection-property v "process-name") (tramp-flush-connection-property v "process-buffer") - (with-current-buffer stderr - (insert-file-contents - (tramp-make-tramp-file-name v tmpstderr) 'visit) - (auto-revert-mode))) - ;; Return process. - p))) + ;; Copy tmpstderr file. + (when (and (stringp stderr) + (not (tramp-tramp-file-p stderr))) + (add-function + :after (process-sentinel p) + (lambda (_proc _msg) + (rename-file remote-tmpstderr stderr)))) + ;; Provide error buffer. This shows only + ;; initial error messages; messages arriving + ;; later on will be inserted when the process + ;; is deleted. The temporary file will exist + ;; until the process is deleted. + (when (bufferp stderr) + (with-current-buffer stderr + (insert-file-contents-literally remote-tmpstderr)) + ;; Delete tmpstderr file. + (add-function + :after (process-sentinel p) + (lambda (_proc _msg) + (when (file-exists-p remote-tmpstderr) + (with-current-buffer stderr + (insert-file-contents-literally + remote-tmpstderr nil nil nil 'replace)) + (delete-file remote-tmpstderr))))) + ;; Return process. + p))) - ;; Save exit. - (if (string-match-p tramp-temp-buffer-name (buffer-name)) - (ignore-errors - (set-process-buffer p nil) - (kill-buffer (current-buffer))) - (set-buffer-modified-p bmp)) - (tramp-flush-connection-property v "process-name") - (tramp-flush-connection-property v "process-buffer")))))))) + ;; Save exit. + (if (string-match-p tramp-temp-buffer-name (buffer-name)) + (ignore-errors + (set-process-buffer p nil) + (kill-buffer (current-buffer))) + (set-buffer-modified-p bmp)) + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer"))))))))) + +(defun tramp-sh-get-signal-strings (vec) + "Strings to return by `process-file' in case of signals." + (with-tramp-connection-property + vec + (concat + "signal-strings-" (tramp-get-method-parameter vec 'tramp-remote-shell)) + (let ((default-directory (tramp-make-tramp-file-name vec 'localname)) + process-file-return-signal-string signals res result) + (setq signals + (append + '(0) (split-string (shell-command-to-string "kill -l") nil 'omit))) + ;; Sanity check. "kill -l" shall have returned just the signal + ;; names. Some shells don't, like the one in "docker alpine". + (let (signal-hook-function) + (condition-case nil + (dolist (sig (cdr signals)) + (unless (string-match-p "^[[:alnum:]+-]+$" sig) + (error nil))) + (error (setq signals '(0))))) + (dotimes (i 128) + (push + (cond + ;; Some predefined values, which aren't reported sometimes, + ;; or would raise problems (all Stopped signals). + ((= i 0) 0) + ((string-equal (nth i signals) "HUP") "Hangup") + ((string-equal (nth i signals) "INT") "Interrupt") + ((string-equal (nth i signals) "QUIT") "Quit") + ((string-equal (nth i signals) "STOP") "Stopped (signal)") + ((string-equal (nth i signals) "TSTP") "Stopped") + ((string-equal (nth i signals) "TTIN") "Stopped (tty input)") + ((string-equal (nth i signals) "TTOU") "Stopped (tty output)") + (t (setq res + (if (null (nth i signals)) + "" + (tramp-send-command + vec + (format + "%s %s %s" + (tramp-get-method-parameter vec 'tramp-remote-shell) + (mapconcat + #'identity + (tramp-get-method-parameter vec 'tramp-remote-shell-args) + " ") + (tramp-shell-quote-argument (format "kill -%d $$" i)))) + (with-current-buffer (tramp-get-connection-buffer vec) + (goto-char (point-min)) + (buffer-substring (point-at-bol) (point-at-eol))))) + (if (string-equal res "") + (format "Signal %d" i) + res))) + result)) + ;; Due to Bug#41287, we cannot add this to the `dotimes' clause. + (reverse result)))) (defun tramp-sh-handle-process-file (program &optional infile destination display &rest args) @@ -3012,6 +3089,11 @@ the result will be a local, non-Tramp, file name." (if (tramp-get-env-with-u-option v) (setq env (append `("-u" ,elt) env)) (setq uenv (cons elt uenv)))))) + (setenv-internal + env "INSIDE_EMACS" + (concat (or (getenv "INSIDE_EMACS") emacs-version) + ",tramp:" tramp-version) + 'keep) (when env (setq command (format @@ -3028,7 +3110,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 +3141,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) @@ -3078,13 +3159,12 @@ the result will be a local, non-Tramp, file name." ;; directory. (condition-case nil (unwind-protect - (setq ret - (if (tramp-send-command-and-check - v (format "cd %s && %s" - (tramp-shell-quote-argument localname) - command) - t t) - 0 1)) + (setq ret (tramp-send-command-and-check + v (format + "cd %s && %s" + (tramp-shell-quote-argument localname) command) + t t t)) + (unless (natnump ret) (setq ret 1)) ;; We should add the output anyway. (when outbuf (with-current-buffer outbuf @@ -3102,6 +3182,12 @@ the result will be a local, non-Tramp, file name." (kill-buffer (tramp-get-connection-buffer v)) (setq ret 1))) + ;; Handle signals. `process-file-return-signal-string' exists + ;; since Emacs 28.1. + (when (and (bound-and-true-p process-file-return-signal-string) + (natnump ret) (>= ret 128)) + (setq ret (nth (- ret 128) (tramp-sh-get-signal-strings v)))) + ;; Provide error file. (when tmpstderr (rename-file tmpstderr (cadr destination) t)) @@ -3122,7 +3208,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." @@ -3236,7 +3322,8 @@ the result will be a local, non-Tramp, file name." #'write-region (list start end localname append 'no-message lockname)) - (let* ((modes (save-excursion (tramp-default-file-modes filename))) + (let* ((modes (tramp-default-file-modes + filename (and (eq mustbenew 'excl) 'nofollow))) ;; We use this to save the value of ;; `last-coding-system-used' after writing the tmp ;; file. At the end of the function, we set @@ -3258,7 +3345,8 @@ the result will be a local, non-Tramp, file name." ;; If `append' is non-nil, we copy the file locally, and let ;; the native `write-region' implementation do the job. - (when append (copy-file filename tmpfile 'ok)) + (when (and append (file-exists-p filename)) + (copy-file filename tmpfile 'ok)) ;; We say `no-message' here because we don't want the ;; visited file modtime data to be clobbered from the temp @@ -3354,9 +3442,8 @@ the result will be a local, non-Tramp, file name." loc-enc tmpfile t)) (tramp-error v 'file-error - (eval-when-compile - (concat "Cannot write to `%s', " - "local encoding command `%s' failed")) + (concat "Cannot write to `%s', " + "local encoding command `%s' failed") filename loc-enc)))) ;; Send buffer into remote decoding command which @@ -3401,9 +3488,8 @@ the result will be a local, non-Tramp, file name." (buffer-string)))) (tramp-error v 'file-error - (eval-when-compile - (concat "Couldn't write region to `%s'," - " decode using `%s' failed")) + (concat "Couldn't write region to `%s'," + " decode using `%s' failed") filename rem-dec))))) ;; Save exit. @@ -3413,9 +3499,8 @@ the result will be a local, non-Tramp, file name." (t (tramp-error v 'file-error - (eval-when-compile - (concat "Method `%s' should specify both encoding and " - "decoding command or an scp program")) + (concat "Method `%s' should specify both encoding and " + "decoding command or an scp program") method)))) ;; Make `last-coding-system-used' have the right value. @@ -3468,8 +3553,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 @@ -3528,27 +3612,30 @@ the result will be a local, non-Tramp, file name." ;; calls shall be answered from the file cache. We unset ;; `process-file-side-effects' and `remote-file-name-inhibit-cache' ;; in order to keep the cache. - (let ((vc-handled-backends vc-handled-backends) + (let ((vc-handled-backends (copy-sequence vc-handled-backends)) remote-file-name-inhibit-cache process-file-side-effects) ;; Reduce `vc-handled-backends' in order to minimize ;; process calls. - (when (and (memq 'Bzr vc-handled-backends) - (boundp 'vc-bzr-program) + (when (and + (memq 'Bzr vc-handled-backends) + (or (not (require 'vc-bzr nil 'noerror)) (not (with-tramp-connection-property v vc-bzr-program (tramp-find-executable - v vc-bzr-program (tramp-get-remote-path v))))) + v vc-bzr-program (tramp-get-remote-path v)))))) (setq vc-handled-backends (remq 'Bzr vc-handled-backends))) - (when (and (memq 'Git vc-handled-backends) - (boundp 'vc-git-program) + (when (and + (memq 'Git vc-handled-backends) + (or (not (require 'vc-git nil 'noerror)) (not (with-tramp-connection-property v vc-git-program (tramp-find-executable - v vc-git-program (tramp-get-remote-path v))))) + v vc-git-program (tramp-get-remote-path v)))))) (setq vc-handled-backends (remq 'Git vc-handled-backends))) - (when (and (memq 'Hg vc-handled-backends) - (boundp 'vc-hg-program) + (when (and + (memq 'Hg vc-handled-backends) + (or (not (require 'vc-hg nil 'noerror)) (not (with-tramp-connection-property v vc-hg-program (tramp-find-executable - v vc-hg-program (tramp-get-remote-path v))))) + v vc-hg-program (tramp-get-remote-path v)))))) (setq vc-handled-backends (remq 'Hg vc-handled-backends))) ;; Run. (tramp-with-demoted-errors @@ -3559,10 +3646,17 @@ 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))) + +;;;###tramp-autoload +(defun tramp-sh-file-name-handler-p (vec) + "Whether VEC uses a method from `tramp-sh-file-name-handler'." + (and (assoc (tramp-file-name-method vec) tramp-methods) + (eq (tramp-find-foreign-file-name-handler + (tramp-make-tramp-file-name vec nil 'nohop)) + 'tramp-sh-file-name-handler))) ;; This must be the last entry, because `identity' always matches. ;;;###tramp-autoload @@ -3614,13 +3708,11 @@ Fall back to normal file name handler if no Tramp handler exists." events (cond ((and (memq 'change flags) (memq 'attribute-change flags)) - (eval-when-compile - (concat "create,modify,move,moved_from,moved_to,move_self," - "delete,delete_self,attrib,ignored"))) + (concat "create,modify,move,moved_from,moved_to,move_self," + "delete,delete_self,attrib,ignored")) ((memq 'change flags) - (eval-when-compile - (concat "create,modify,move,moved_from,moved_to,move_self," - "delete,delete_self,ignored"))) + (concat "create,modify,move,moved_from,moved_to,move_self," + "delete,delete_self,ignored")) ((memq 'attribute-change flags) "attrib,ignored")) sequence `(,command "-mq" "-e" ,events ,localname) ;; Make events a list of symbols. @@ -3762,12 +3854,11 @@ Fall back to normal file name handler if no Tramp handler exists." "ATTRIB CHANGED" "ATTRIBUTE_CHANGED" string)) (while (string-match - (eval-when-compile - (concat "^[\n\r]*" - "Directory Monitor Event:[\n\r]+" - "Child = \\([^\n\r]+\\)[\n\r]+" - "\\(Other = \\([^\n\r]+\\)[\n\r]+\\)?" - "Event = \\([^[:blank:]]+\\)[\n\r]+")) + (concat "^[\n\r]*" + "Directory Monitor Event:[\n\r]+" + "Child = \\([^\n\r]+\\)[\n\r]+" + "\\(Other = \\([^\n\r]+\\)[\n\r]+\\)?" + "Event = \\([^[:blank:]]+\\)[\n\r]+") string) (let* ((file (match-string 1 string)) (file1 (match-string 3 string)) @@ -3803,10 +3894,9 @@ Fall back to normal file name handler if no Tramp handler exists." (dolist (line (split-string string "[\n\r]+" 'omit)) ;; Check, whether there is a problem. (unless (string-match - (eval-when-compile - (concat "^[^[:blank:]]+" - "[[:blank:]]+\\([^[:blank:]]+\\)" - "\\([[:blank:]]+\\([^\n\r]+\\)\\)?")) + (concat "^[^[:blank:]]+" + "[[:blank:]]+\\([^[:blank:]]+\\)" + "\\([[:blank:]]+\\([^\n\r]+\\)\\)?") line) (tramp-error proc 'file-notify-error "%s" line)) @@ -3842,11 +3932,10 @@ Fall back to normal file name handler if no Tramp handler exists." (goto-char (point-min)) (forward-line) (when (looking-at - (eval-when-compile - (concat "\\(?:^/[^[:space:]]*[[:space:]]\\)?" - "[[:space:]]*\\([[:digit:]]+\\)" - "[[:space:]]+\\([[:digit:]]+\\)" - "[[:space:]]+\\([[:digit:]]+\\)"))) + (concat "\\(?:^/[^[:space:]]*[[:space:]]\\)?" + "[[:space:]]*\\([[:digit:]]+\\)" + "[[:space:]]+\\([[:digit:]]+\\)" + "[[:space:]]+\\([[:digit:]]+\\)")) (mapcar (lambda (d) (* d (tramp-get-connection-property v "df-blocksize" 0))) @@ -3915,13 +4004,16 @@ hosts, or files, disagree." (tramp-shell-quote-argument v1-localname) (tramp-shell-quote-argument v2-localname)))))) +(defconst tramp-sunos-unames (regexp-opt '("SunOS 5.10" "SunOS 5.11")) + "Regexp to determine remote SunOS.") + (defun tramp-find-executable (vec progname dirlist &optional ignore-tilde ignore-path) "Search for PROGNAME in $PATH and all directories mentioned in DIRLIST. 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. @@ -3936,7 +4028,7 @@ This function expects to be in the right *tramp* buffer." ;; therefore. (unless (or ignore-path (string-match-p - (eval-when-compile (regexp-opt '("SunOS 5.10" "SunOS 5.11"))) + tramp-sunos-unames (tramp-get-connection-property vec "uname" ""))) (tramp-send-command vec (format "which \\%s | wc -w" progname)) (goto-char (point-min)) @@ -3947,19 +4039,18 @@ 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)))) (tramp-send-command vec - (format (eval-when-compile - (concat "while read d; " - "do if test -x $d/%s && test -f $d/%s; " - "then echo tramp_executable $d/%s; " - "break; fi; done <<'%s'\n" - "%s\n%s")) + (format (concat "while read d; " + "do if test -x $d/%s && test -f $d/%s; " + "then echo tramp_executable $d/%s; " + "break; fi; done <<'%s'\n" + "%s\n%s") progname progname progname tramp-end-of-heredoc (string-join dirlist "\n") @@ -3981,23 +4072,30 @@ whether it exists and if so, it is added to the environment variable PATH." (let ((command (format - "PATH=%s; export PATH" (string-join (tramp-get-remote-path vec) ":"))) + "PATH=%s && export PATH" (string-join (tramp-get-remote-path vec) ":"))) (pipe-buf - (or (with-tramp-connection-property vec "pipe-buf" - (tramp-send-command-and-read - vec "getconf PIPE_BUF / 2>/dev/null || echo nil" 'noerror)) - 4096)) - tmpfile) + (with-tramp-connection-property vec "pipe-buf" + (tramp-send-command-and-read + vec "getconf PIPE_BUF / 2>/dev/null || echo 4096" 'noerror))) + tmpfile chunk chunksize) (tramp-message vec 5 "Setting $PATH environment variable") (if (< (length command) pipe-buf) (tramp-send-command vec command) - ;; Use a temporary file. - (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))) - (delete-file tmpfile)))) + ;; Use a temporary file. We cannot use `write-region' because + ;; setting the remote path happens in the early connection + ;; handshake, and not all external tools are determined yet. + (setq command (concat command "\n") + tmpfile (tramp-make-tramp-temp-file vec)) + (while (not (string-empty-p command)) + (setq chunksize (min (length command) (/ pipe-buf 2)) + chunk (substring command 0 chunksize) + command (substring command chunksize)) + (tramp-send-command vec (format + "printf \"%%b\" \"$*\" %s >>%s" + (tramp-shell-quote-argument chunk) + (tramp-shell-quote-argument tmpfile)))) + (tramp-send-command vec (format ". %s" tmpfile)) + (tramp-send-command vec (format "rm -f %s" tmpfile))))) ;; ------------------------------------------------------------ ;; -- Communication with external shell -- @@ -4069,99 +4167,98 @@ file exists and nonzero exit status otherwise." (defun tramp-open-shell (vec shell) "Open shell SHELL." + ;; Find arguments for this shell. (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))) - ;; 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 - ;; will display a dollar sign. The following command line sets - ;; $PS1 to a sane value, and works under Bourne-ish shells as - ;; well as csh-like shells. We also unset the variable $ENV - ;; because that is read by some sh implementations (eg, bash - ;; when called as sh) on startup; this way, we avoid the startup - ;; file clobbering $PS1. $PROMPT_COMMAND is another way to set - ;; the prompt in /bin/bash, it must be discarded as well. - ;; $HISTFILE is set according to `tramp-histfile-override'. - ;; $TERM and $INSIDE_EMACS set here to ensure they have the - ;; correct values when the shell starts, not just processes - ;; run within the shell. (Which processes include our - ;; initial probes to ensure the remote shell is usable.) - (tramp-send-command - vec (format - (eval-when-compile - (concat - "exec env TERM='%s' INSIDE_EMACS='%s,tramp:%s' " - "ENV=%s %s PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s %s")) - tramp-terminal-type - emacs-version tramp-version ; INSIDE_EMACS - (or (getenv-internal "ENV" tramp-remote-process-environment) "") - (if (stringp tramp-histfile-override) - (format "HISTFILE=%s" - (tramp-shell-quote-argument tramp-histfile-override)) - (if tramp-histfile-override - "HISTFILE='' HISTFILESIZE=0 HISTSIZE=0" - "")) - (tramp-shell-quote-argument tramp-end-of-output) - shell (or extra-args "")) - t) - ;; Check proper HISTFILE setting. We give up when not working. - (when (and (stringp tramp-histfile-override) - (file-name-directory tramp-histfile-override)) - (tramp-barf-unless-okay - vec - (format - "(cd %s)" - (tramp-shell-quote-argument - (file-name-directory tramp-histfile-override))) - "`tramp-histfile-override' uses invalid file `%s'" - tramp-histfile-override))) + ;; 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 will display + ;; a dollar sign. The following command line sets $PS1 to a sane + ;; value, and works under Bourne-ish shells as well as csh-like + ;; shells. We also unset the variable $ENV because that is read + ;; by some sh implementations (eg, bash when called as sh) on + ;; startup; this way, we avoid the startup file clobbering $PS1. + ;; $PROMPT_COMMAND is another way to set the prompt in /bin/bash, + ;; it must be discarded as well. $HISTFILE is set according to + ;; `tramp-histfile-override'. $TERM and $INSIDE_EMACS set here to + ;; ensure they have the correct values when the shell starts, not + ;; just processes run within the shell. (Which processes include + ;; our initial probes to ensure the remote shell is usable.) + (tramp-send-command + vec (format + (concat + "exec env TERM='%s' INSIDE_EMACS='%s,tramp:%s' " + "ENV=%s %s PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s %s") + tramp-terminal-type + (or (getenv "INSIDE_EMACS") emacs-version) tramp-version + (or (getenv-internal "ENV" tramp-remote-process-environment) "") + (if (stringp tramp-histfile-override) + (format "HISTFILE=%s" + (tramp-shell-quote-argument tramp-histfile-override)) + (if tramp-histfile-override + "HISTFILE='' HISTFILESIZE=0 HISTSIZE=0" + "")) + (tramp-shell-quote-argument tramp-end-of-output) + shell (or (tramp-get-sh-extra-args shell) "")) + t) + ;; Check proper HISTFILE setting. We give up when not working. + (when (and (stringp tramp-histfile-override) + (file-name-directory tramp-histfile-override)) + (tramp-barf-unless-okay + vec + (format + "(cd %s)" + (tramp-shell-quote-argument + (file-name-directory tramp-histfile-override))) + "`tramp-histfile-override' uses invalid file `%s'" + tramp-histfile-override)) (tramp-set-connection-property (tramp-get-connection-process vec) "remote-shell" shell))) (defun tramp-find-shell (vec) "Open a shell on the remote host which groks tilde expansion." - (with-current-buffer (tramp-get-buffer vec) - (let ((default-shell (tramp-get-method-parameter vec 'tramp-remote-shell)) - shell) - (setq shell - (with-tramp-connection-property vec "remote-shell" - ;; CCC: "root" does not exist always, see my QNAP TS-459. - ;; Which check could we apply instead? - (tramp-send-command vec "echo ~root" t) - (if (or (string-match-p "^~root$" (buffer-string)) - ;; The default shell (ksh93) of OpenSolaris and - ;; Solaris is buggy. We've got reports for - ;; "SunOS 5.10" and "SunOS 5.11" so far. - (string-match-p - (eval-when-compile - (regexp-opt '("SunOS 5.10" "SunOS 5.11"))) - (tramp-get-connection-property vec "uname" ""))) - - (or (tramp-find-executable - vec "bash" (tramp-get-remote-path vec) t t) - (tramp-find-executable - vec "ksh" (tramp-get-remote-path vec) t t) - ;; Maybe it works at least for some other commands. - (prog1 - default-shell - (tramp-message - vec 2 - (eval-when-compile + ;; If we are in `make-process', we don't need another shell. + (unless (tramp-get-connection-property vec "process-name" nil) + (with-current-buffer (tramp-get-buffer vec) + (let ((default-shell (tramp-get-method-parameter vec 'tramp-remote-shell)) + shell) + (setq shell + (with-tramp-connection-property vec "remote-shell" + ;; CCC: "root" does not exist always, see my QNAP + ;; TS-459. Which check could we apply instead? + (tramp-send-command vec "echo ~root" t) + (if (or (string-match-p "^~root$" (buffer-string)) + ;; The default shell (ksh93) of OpenSolaris + ;; and Solaris is buggy. We've got reports + ;; for "SunOS 5.10" and "SunOS 5.11" so far. + (string-match-p + tramp-sunos-unames + (tramp-get-connection-property vec "uname" ""))) + + (or (tramp-find-executable + vec "bash" (tramp-get-remote-path vec) t t) + (tramp-find-executable + vec "ksh" (tramp-get-remote-path vec) t t) + ;; Maybe it works at least for some other commands. + (prog1 + default-shell + (tramp-message + vec 2 (concat "Couldn't find a remote shell which groks tilde " - "expansion, using `%s'")) - default-shell))) + "expansion, using `%s'") + default-shell))) - default-shell))) + default-shell))) - ;; Open a new shell if needed. - (unless (string-equal shell default-shell) - (tramp-message - vec 5 "Starting remote shell `%s' for tilde expansion" shell) - (tramp-open-shell vec shell))))) + ;; Open a new shell if needed. + (unless (string-equal shell default-shell) + (tramp-message + vec 5 "Starting remote shell `%s' for tilde expansion" shell) + (tramp-open-shell vec shell)))))) ;; Utility functions. @@ -4187,9 +4284,16 @@ process to set up. VEC specifies the connection." (let ((tramp-end-of-output tramp-initial-end-of-output) (case-fold-search t)) (tramp-open-shell vec (tramp-get-method-parameter vec 'tramp-remote-shell)) + (tramp-message vec 5 "Setting up remote shell environment") + + ;; Disable line editing. + (tramp-send-command vec "set +o vi +o emacs" t) + + ;; Dump option settings in the traces. + (when (>= tramp-verbose 9) + (tramp-send-command vec "set -o" t)) ;; Disable echo expansion. - (tramp-message vec 5 "Setting up remote shell environment") (tramp-send-command vec "stty -inlcr -onlcr -echo kill '^U' erase '^H'" t) ;; Check whether the echo has really been disabled. Some @@ -4216,11 +4320,15 @@ process to set up. VEC specifies the connection." ;; connection properties. We start again with ;; `tramp-maybe-open-connection', it will be caught there. (tramp-message vec 5 "Checking system information") - (let ((old-uname (tramp-get-connection-property vec "uname" nil)) - (uname - (tramp-set-connection-property - vec "uname" - (tramp-send-command-and-read vec "echo \\\"`uname -sr`\\\"")))) + (let* ((old-uname (tramp-get-connection-property vec "uname" nil)) + (uname + ;; If we are in `make-process', we don't need to recompute. + (if (and old-uname + (tramp-get-connection-property vec "process-name" nil)) + old-uname + (tramp-set-connection-property + vec "uname" + (tramp-send-command-and-read vec "echo \\\"`uname -sr`\\\""))))) (when (and (stringp old-uname) (not (string-equal old-uname uname))) (tramp-message vec 3 @@ -4259,8 +4367,6 @@ process to set up. VEC specifies the connection." (tramp-message vec 5 "Setting coding system to `%s' and `%s'" cs-decode cs-encode))) - (tramp-send-command vec "set +o vi +o emacs" t) - ;; Check whether the remote host suffers from buggy ;; `send-process-string'. This is known for FreeBSD (see comment ;; in `send_process', file process.c). I've tested sending 624 @@ -4383,7 +4489,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 +4500,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 +4528,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 +4548,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 +4571,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 +4589,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,17 +4633,22 @@ 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 - (expand-file-name - tramp-temp-name-prefix - (tramp-get-remote-tmpdir vec))) + (setq tmpfile (tramp-make-tramp-temp-name vec) value (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 +4666,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 @@ -4646,6 +4781,12 @@ Goes through the list `tramp-inline-compress-commands'." (tramp-message vec 2 "Couldn't find an inline transfer compress command"))))) +;;;###tramp-autoload +(defun tramp-multi-hop-p (vec) + "Whether the method of VEC is capable of multi-hops." + (and (tramp-sh-file-name-handler-p vec) + (not (tramp-get-method-parameter vec 'tramp-copy-program)))) + (defun tramp-compute-multi-hops (vec) "Expands VEC according to `tramp-default-proxies-alist'." (let ((saved-tdpa tramp-default-proxies-alist) @@ -4709,8 +4850,7 @@ Goes through the list `tramp-inline-compress-commands'." (when (cdr target-alist) (setq choices target-alist) (while (setq item (pop choices)) - (when (or (not (tramp-get-method-parameter item 'tramp-login-program)) - (tramp-get-method-parameter item 'tramp-copy-program)) + (unless (tramp-multi-hop-p item) (setq tramp-default-proxies-alist saved-tdpa) (tramp-user-error vec "Method `%s' is not supported for multi-hops." @@ -4796,8 +4936,8 @@ 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)) - (tramp-cleanup-connection vec 'keep-debug))) + vec 3 "Timeout session %s" (tramp-make-tramp-file-name vec 'noloc)) + (tramp-cleanup-connection vec 'keep-debug nil 'keep-processes))) (defun tramp-maybe-open-connection (vec) "Maybe open a connection VEC. @@ -4818,11 +4958,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 +4970,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) @@ -4951,11 +5086,8 @@ connection if a previous connection has died for some reason." ;; we cannot use `tramp-get-connection-process'. (tmpfile (with-tramp-connection-property - (get-process (tramp-buffer-name vec)) "temp-file" - (make-temp-name - (expand-file-name - tramp-temp-name-prefix - (tramp-compat-temporary-file-directory))))) + (tramp-get-process vec) "temp-file" + (tramp-compat-make-temp-name))) spec r-shell) ;; Add arguments for asynchronous processes. @@ -5116,7 +5248,7 @@ function waits for output unless NOOUTPUT is set." found))) (defun tramp-send-command-and-check - (vec command &optional subshell dont-suppress-err) + (vec command &optional subshell dont-suppress-err exit-status) "Run COMMAND and check its exit status. Send `echo $?' along with the COMMAND for checking the exit status. If COMMAND is nil, just send `echo $?'. Return t if the exit @@ -5124,7 +5256,9 @@ status is 0, and nil otherwise. If the optional argument SUBSHELL is non-nil, the command is executed in a subshell, ie surrounded by parentheses. If -DONT-SUPPRESS-ERR is non-nil, stderr won't be sent to /dev/null." +DONT-SUPPRESS-ERR is non-nil, stderr won't be sent to /dev/null. +Optional argument EXIT-STATUS, if non-nil, triggers the return of +the exit status." (tramp-send-command vec (concat (if subshell "( " "") @@ -5133,12 +5267,14 @@ DONT-SUPPRESS-ERR is non-nil, stderr won't be sent to /dev/null." "echo tramp_exit_status $?" (if subshell " )" ""))) (with-current-buffer (tramp-get-connection-buffer vec) - (unless (tramp-search-regexp "tramp_exit_status [0-9]+") + (unless (tramp-search-regexp "tramp_exit_status [[:digit:]]+") (tramp-error vec 'file-error "Couldn't find exit status of `%s'" command)) (skip-chars-forward "^ ") (prog1 - (zerop (read (current-buffer))) + (if exit-status + (read (current-buffer)) + (zerop (read (current-buffer)))) (let ((inhibit-read-only t)) (delete-region (match-beginning 0) (point-max)))))) @@ -5171,7 +5307,10 @@ raises an error." command marker (buffer-string)))))) ;; Read the expression. (condition-case nil - (prog1 (read (current-buffer)) + (prog1 + (let ((signal-hook-function + (unless noerror signal-hook-function))) + (read (current-buffer))) ;; Error handling. (when (re-search-forward "\\S-" (point-at-eol) t) (error nil))) @@ -5324,7 +5463,7 @@ Nonexistent directories are removed from spec." ;; cache the result for the session only. Otherwise, the ;; result is cached persistently. (if (memq 'tramp-own-remote-path tramp-remote-path) - (tramp-get-connection-process vec) + (tramp-get-process vec) vec) "remote-path" (let* ((remote-path (copy-tree tramp-remote-path)) @@ -5532,8 +5671,7 @@ Nonexistent directories are removed from spec." ;; stat on Solaris is buggy. We've got reports for "SunOS 5.10" ;; and "SunOS 5.11" so far. (unless (string-match-p - (eval-when-compile (regexp-opt '("SunOS 5.10" "SunOS 5.11"))) - (tramp-get-connection-property vec "uname" "")) + tramp-sunos-unames (tramp-get-connection-property vec "uname" "")) (tramp-message vec 5 "Finding a suitable `stat' command") (let ((result (tramp-find-executable vec "stat" (tramp-get-remote-path vec))) @@ -5579,10 +5717,7 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil." (tramp-message vec 5 "Finding a suitable `touch' command") (let ((result (tramp-find-executable vec "touch" (tramp-get-remote-path vec))) - (tmpfile - (make-temp-name - (expand-file-name - tramp-temp-name-prefix (tramp-get-remote-tmpdir vec))))) + (tmpfile (tramp-make-tramp-temp-name vec))) ;; Busyboxes do support the "-t" option only when they have been ;; built with the DESKTOP config option. Let's check it. (when result @@ -5594,7 +5729,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))) @@ -5697,27 +5832,6 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil." "import os; print (os.getuid())" "import os, pwd; print ('\\\"' + pwd.getpwuid(os.getuid())[0] + '\\\"')")))) -(defun tramp-get-remote-uid (vec id-format) - "The uid of the remote connection VEC, in ID-FORMAT. -ID-FORMAT valid values are `string' and `integer'." - (with-tramp-connection-property vec (format "uid-%s" id-format) - (let ((res - (ignore-errors - (cond - ((tramp-get-remote-id vec) - (tramp-get-remote-uid-with-id vec id-format)) - ((tramp-get-remote-perl vec) - (tramp-get-remote-uid-with-perl vec id-format)) - ((tramp-get-remote-python vec) - (tramp-get-remote-uid-with-python vec id-format)))))) - ;; Ensure there is a valid result. - (cond - ((and (equal id-format 'integer) (not (integerp res))) - tramp-unknown-id-integer) - ((and (equal id-format 'string) (not (stringp res))) - tramp-unknown-id-string) - (t res))))) - (defun tramp-get-remote-gid-with-id (vec id-format) "Implement `tramp-get-remote-gid' for Tramp files using `id'." (tramp-send-command-and-read @@ -5748,26 +5862,59 @@ ID-FORMAT valid values are `string' and `integer'." "import os; print (os.getgid())" "import os, grp; print ('\\\"' + grp.getgrgid(os.getgid())[0] + '\\\"')")))) -(defun tramp-get-remote-gid (vec id-format) - "The gid of the remote connection VEC, in ID-FORMAT. -ID-FORMAT valid values are `string' and `integer'." - (with-tramp-connection-property vec (format "gid-%s" id-format) - (let ((res - (ignore-errors - (cond - ((tramp-get-remote-id vec) - (tramp-get-remote-gid-with-id vec id-format)) - ((tramp-get-remote-perl vec) - (tramp-get-remote-gid-with-perl vec id-format)) - ((tramp-get-remote-python vec) - (tramp-get-remote-gid-with-python vec id-format)))))) - ;; Ensure there is a valid result. - (cond - ((and (equal id-format 'integer) (not (integerp res))) - tramp-unknown-id-integer) - ((and (equal id-format 'string) (not (stringp res))) - 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-remote-chmod-h (vec) + "Check whether remote `chmod' supports nofollow argument." + (with-tramp-connection-property vec "chmod-h" + (tramp-message vec 5 "Finding a suitable `chmod' command with nofollow") + (let ((tmpfile (tramp-make-tramp-temp-name vec))) + (prog1 + (tramp-send-command-and-check + vec + (format + "ln -s foo %s && chmod -h %s 0777" + (tramp-file-local-name tmpfile) (tramp-file-local-name tmpfile))) + (delete-file tmpfile))))) (defun tramp-get-env-with-u-option (vec) "Check, whether the remote `env' command supports the -u option." @@ -5786,10 +5933,9 @@ the length of the file to be compressed. If no corresponding command is found, nil is returned." (when (and (integerp tramp-inline-compress-start-size) (> size tramp-inline-compress-start-size)) - (with-tramp-connection-property (tramp-get-connection-process vec) prop + (with-tramp-connection-property (tramp-get-process vec) prop (tramp-find-inline-compress vec) - (tramp-get-connection-property - (tramp-get-connection-process vec) prop nil)))) + (tramp-get-connection-property (tramp-get-process vec) prop nil)))) (defun tramp-get-inline-coding (vec prop size) "Return the coding command related to PROP. @@ -5807,11 +5953,9 @@ function cell is returned to be applied on a buffer." ;; no inline coding is found. (ignore-errors (let ((coding - (with-tramp-connection-property - (tramp-get-connection-process vec) prop + (with-tramp-connection-property (tramp-get-process vec) prop (tramp-find-inline-encoding vec) - (tramp-get-connection-property - (tramp-get-connection-process vec) prop nil))) + (tramp-get-connection-property (tramp-get-process vec) prop nil))) (prop1 (if (string-match-p "encoding" prop) "inline-compress" "inline-decompress")) compress) @@ -5889,9 +6033,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..1b6af2a2e33 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -75,12 +75,23 @@ ;;;###tramp-autoload (defcustom tramp-smb-conf "/dev/null" - "Path of the smb.conf file. -If it is nil, no smb.conf will be added to the `tramp-smb-program' + "Path of the \"smb.conf\" file. +If it is nil, no \"smb.conf\" will be added to the `tramp-smb-program' call, letting the SMB client use the default one." :group 'tramp :type '(choice (const nil) (file :must-match t))) +;;;###tramp-autoload +(defcustom tramp-smb-options nil + "List of additional options. +They are added to the `tramp-smb-program' call via \"--option '...'\". + +For example, if the deprecated SMB1 protocol shall be used, add to +this variable (\"client min protocol=NT1\") ." + :group 'tramp + :type '(repeat string) + :version "28.1") + (defvar tramp-smb-version nil "Version string of the SMB client.") @@ -135,6 +146,7 @@ call, letting the SMB client use the default one." "NT_STATUS_HOST_UNREACHABLE" "NT_STATUS_IMAGE_ALREADY_LOADED" "NT_STATUS_INVALID_LEVEL" + "NT_STATUS_INVALID_PARAMETER" "NT_STATUS_INVALID_PARAMETER_MIX" "NT_STATUS_IO_TIMEOUT" "NT_STATUS_LOGON_FAILURE" @@ -281,6 +293,8 @@ See `tramp-actions-before-shell' for more info.") (start-file-process . tramp-smb-handle-start-file-process) (substitute-in-file-name . tramp-smb-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-get-remote-gid . ignore) + (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) (vc-registered . ignore) @@ -329,10 +343,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,16 +433,12 @@ 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. ((and t1 t2) - (let ((tmpdir - (make-temp-name - (expand-file-name - tramp-temp-name-prefix - (tramp-compat-temporary-file-directory))))) + (let ((tmpdir (tramp-compat-make-temp-name))) (unwind-protect (progn (make-directory tmpdir) @@ -457,11 +466,9 @@ pass to the OPERATION." (localname (file-name-as-directory (replace-regexp-in-string "\\\\" "/" (tramp-smb-get-localname v)))) - (tmpdir (make-temp-name - (expand-file-name - tramp-temp-name-prefix - (tramp-compat-temporary-file-directory)))) - (args (list (concat "//" host "/" share) "-E"))) + (tmpdir (tramp-compat-make-temp-name)) + (args (list (concat "//" host "/" share) "-E")) + (options tramp-smb-options)) (if (not (zerop (length user))) (setq args (append args (list "-U" user))) @@ -471,6 +478,10 @@ pass to the OPERATION." (when port (setq args (append args (list "-p" port)))) (when tramp-smb-conf (setq args (append args (list "-s" tramp-smb-conf)))) + (while options + (setq args + (append args `("--option" ,(format "%s" (car options)))) + options (cdr options))) (setq args (if t1 ;; Source is remote. @@ -539,10 +550,11 @@ pass to the OPERATION." ;; Handle KEEP-DATE argument. (when keep-date - (set-file-times + (tramp-compat-set-file-times newname (tramp-compat-file-attribute-modification-time - (file-attributes dirname)))) + (file-attributes dirname)) + (unless ok-if-already-exists 'nofollow))) ;; Set the mode. (unless keep-date @@ -581,47 +593,47 @@ 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 - (set-file-times + (tramp-compat-set-file-times newname (tramp-compat-file-attribute-modification-time - (file-attributes filename)))))) + (file-attributes filename)) + (unless ok-if-already-exists 'nofollow))))) (defun tramp-smb-handle-delete-directory (directory &optional recursive _trash) "Like `delete-directory' for Tramp files." @@ -692,11 +704,11 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (delete nil (mapcar (lambda (x) (when (string-match-p match x) x)) result)))) - ;; Append directory. + ;; Prepend directory. (when full (setq result (mapcar - (lambda (x) (format "%s/%s" directory x)) + (lambda (x) (format "%s/%s" (directory-file-name directory) x)) result))) ;; Sort them if necessary. (unless nosort (setq result (sort result #'string-lessp))) @@ -760,7 +772,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (let* ((share (tramp-smb-get-share v)) (localname (replace-regexp-in-string "\\\\" "/" (tramp-smb-get-localname v))) - (args (list (concat "//" host "/" share) "-E"))) + (args (list (concat "//" host "/" share) "-E")) + (options tramp-smb-options)) (if (not (zerop (length user))) (setq args (append args (list "-U" user))) @@ -770,6 +783,10 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when port (setq args (append args (list "-p" port)))) (when tramp-smb-conf (setq args (append args (list "-s" tramp-smb-conf)))) + (while options + (setq args + (append args `("--option" ,(format "%s" (car options)))) + options (cdr options))) (setq args (append args (list (tramp-unquote-shell-quote-argument localname) @@ -858,23 +875,31 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (while (not (eobp)) (cond ((looking-at - "Size:\\s-+\\([0-9]+\\)\\s-+Blocks:\\s-+[0-9]+\\s-+\\(\\w+\\)") + (concat + "Size:\\s-+\\([[:digit:]]+\\)\\s-+" + "Blocks:\\s-+[[:digit:]]+\\s-+\\(\\w+\\)")) (setq size (string-to-number (match-string 1)) id (if (string-equal "directory" (match-string 2)) t (if (string-equal "symbolic" (match-string 2)) "")))) ((looking-at - "Inode:\\s-+\\([0-9]+\\)\\s-+Links:\\s-+\\([0-9]+\\)") + "Inode:\\s-+\\([[:digit:]]+\\)\\s-+Links:\\s-+\\([[:digit:]]+\\)") (setq inode (string-to-number (match-string 1)) link (string-to-number (match-string 2)))) ((looking-at - "Access:\\s-+([0-9]+/\\(\\S-+\\))\\s-+Uid:\\s-+\\([0-9]+\\)\\s-+Gid:\\s-+\\([0-9]+\\)") + (concat + "Access:\\s-+([[:digit:]]+/\\(\\S-+\\))\\s-+" + "Uid:\\s-+\\([[:digit:]]+\\)\\s-+" + "Gid:\\s-+\\([[:digit:]]+\\)")) (setq mode (match-string 1) uid (if (equal id-format 'string) (match-string 2) (string-to-number (match-string 2))) gid (if (equal id-format 'string) (match-string 3) (string-to-number (match-string 3))))) ((looking-at - "Access:\\s-+\\([0-9]+\\)-\\([0-9]+\\)-\\([0-9]+\\)\\s-+\\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\)") + (concat + "Access:\\s-+" + "\\([[:digit:]]+\\)-\\([[:digit:]]+\\)-\\([[:digit:]]+\\)\\s-+" + "\\([[:digit:]]+\\):\\([[:digit:]]+\\):\\([[:digit:]]+\\)")) (setq atime (encode-time (string-to-number (match-string 6)) ;; sec @@ -884,7 +909,10 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (string-to-number (match-string 2)) ;; month (string-to-number (match-string 1))))) ;; year ((looking-at - "Modify:\\s-+\\([0-9]+\\)-\\([0-9]+\\)-\\([0-9]+\\)\\s-+\\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\)") + (concat + "Modify:\\s-+" + "\\([[:digit:]]+\\)-\\([[:digit:]]+\\)-\\([[:digit:]]+\\)\\s-+" + "\\([[:digit:]]+\\):\\([[:digit:]]+\\):\\([[:digit:]]+\\)")) (setq mtime (encode-time (string-to-number (match-string 6)) ;; sec @@ -894,7 +922,10 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (string-to-number (match-string 2)) ;; month (string-to-number (match-string 1))))) ;; year ((looking-at - "Change:\\s-+\\([0-9]+\\)-\\([0-9]+\\)-\\([0-9]+\\)\\s-+\\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\)") + (concat + "Change:\\s-+" + "\\([[:digit:]]+\\)-\\([[:digit:]]+\\)-\\([[:digit:]]+\\)\\s-+" + "\\([[:digit:]]+\\):\\([[:digit:]]+\\):\\([[:digit:]]+\\)")) (setq ctime (encode-time (string-to-number (match-string 6)) ;; sec @@ -970,10 +1001,9 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (goto-char (point-min)) (forward-line) (when (looking-at - (eval-when-compile - (concat "[[:space:]]*\\([[:digit:]]+\\)" - " blocks of size \\([[:digit:]]+\\)" - "\\. \\([[:digit:]]+\\) blocks available"))) + (concat "[[:space:]]*\\([[:digit:]]+\\)" + " blocks of size \\([[:digit:]]+\\)" + "\\. \\([[:digit:]]+\\) blocks available")) (setq blocksize (string-to-number (match-string 2)) total (* blocksize (string-to-number (match-string 1))) avail (* blocksize (string-to-number (match-string 3))))) @@ -1003,7 +1033,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 +1218,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 +1272,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 +1385,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 @@ -1414,7 +1442,8 @@ component is used as the target of the symlink." "\\\\" "/" (tramp-smb-get-localname v))) (args (list (concat "//" host "/" share) "-E" "-S" (replace-regexp-in-string - "\n" "," acl-string)))) + "\n" "," acl-string))) + (options tramp-smb-options)) (if (not (zerop (length user))) (setq args (append args (list "-U" user))) @@ -1424,6 +1453,10 @@ component is used as the target of the symlink." (when port (setq args (append args (list "-p" port)))) (when tramp-smb-conf (setq args (append args (list "-s" tramp-smb-conf)))) + (while options + (setq args + (append args `("--option" ,(format "%s" (car options)))) + options (cdr options))) (setq args (append args (list (tramp-unquote-shell-quote-argument localname) @@ -1454,7 +1487,7 @@ component is used as the target of the symlink." ;; This is meant for traces, and returning from the ;; function. No error is propagated outside, due to ;; the `ignore-errors' closure. - (unless (tramp-search-regexp "tramp_exit_status [0-9]+") + (unless (tramp-search-regexp "tramp_exit_status [[:digit:]]+") (tramp-error v 'file-error "Couldn't find exit status of `%s'" tramp-smb-acl-program)) @@ -1468,15 +1501,17 @@ component is used as the target of the symlink." (tramp-flush-connection-property v "process-name") (tramp-flush-connection-property v "process-buffer"))))))) -(defun tramp-smb-handle-set-file-modes (filename mode) +(defun tramp-smb-handle-set-file-modes (filename mode &optional flag) "Like `set-file-modes' for Tramp files." (with-parsed-tramp-file-name filename nil - (when (tramp-smb-get-cifs-capabilities v) - (tramp-flush-file-properties v localname) - (unless (tramp-smb-send-command - v (format "chmod \"%s\" %o" (tramp-smb-get-localname v) mode)) - (tramp-error - v 'file-error "Error while changing file's mode %s" filename))))) + ;; smbclient chmod does not support nofollow. + (unless (and (eq flag 'nofollow) (file-symlink-p filename)) + (when (tramp-smb-get-cifs-capabilities v) + (tramp-flush-file-properties v localname) + (unless (tramp-smb-send-command + v (format "chmod \"%s\" %o" (tramp-smb-get-localname v) mode)) + (tramp-error + v 'file-error "Error while changing file's mode %s" filename)))))) ;; We use BUFFER also as connection buffer during setup. Because of ;; this, its original contents must be saved, and restored once @@ -1557,9 +1592,6 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." (format "File %s exists; overwrite anyway? " filename))))) (tramp-error v 'file-already-exists filename)) - ;; We must also flush the cache of the directory, because - ;; `file-attributes' reads the values from there. - (tramp-flush-file-properties v localname) (let ((curbuf (current-buffer)) (tmpfile (tramp-compat-make-temp-file filename))) (when (and append (file-exists-p filename)) @@ -1579,6 +1611,10 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." (tramp-error v 'file-error "Cannot write `%s'" filename)) (delete-file tmpfile))) + ;; We must also flush the cache of the directory, because + ;; `file-attributes' reads the values from there. + (tramp-flush-file-properties v localname) + (unless (equal curbuf (current-buffer)) (tramp-error v 'file-error @@ -1696,21 +1732,21 @@ Result is a list of (LOCALNAME MODE SIZE MONTH DAY TIME YEAR)." ;; Entries provided by smbclient DIR aren't fully regular. ;; They should have the format ;; -;; \s-\{2,2} - leading spaces +;; \s-\{2,2\} - leading spaces ;; \S-\(.*\S-\)\s-* - file name, 30 chars, left bound ;; \s-+[ADHRSV]* - permissions, 7 chars, right bound ;; \s- - space delimiter -;; \s-+[0-9]+ - size, 8 chars, right bound +;; \s-+[[:digit:]]+ - size, 8 chars, right bound ;; \s-\{2,2\} - space delimiter ;; \w\{3,3\} - weekday ;; \s- - space delimiter ;; \w\{3,3\} - month ;; \s- - space delimiter -;; [ 12][0-9] - day +;; [ 12][[:digit:]] - day ;; \s- - space delimiter -;; [0-9]\{2,2\}:[0-9]\{2,2\}:[0-9]\{2,2\} - time +;; [[:digit:]]\{2,2\}:[[:digit:]]\{2,2\}:[[:digit:]]\{2,2\} - time ;; \s- - space delimiter -;; [0-9]\{4,4\} - year +;; [[:digit:]]\{4,4\} - year ;; ;; samba/src/client.c (http://samba.org/doxygen/samba/client_8c-source.html) ;; has function display_finfo: @@ -1758,13 +1794,14 @@ are listed. Result is the list (LOCALNAME MODE SIZE MTIME)." (cl-block nil ;; year. - (if (string-match "\\([0-9]+\\)$" line) + (if (string-match "\\([[:digit:]]+\\)$" line) (setq year (string-to-number (match-string 1 line)) line (substring line 0 -5)) (cl-return)) ;; time. - (if (string-match "\\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\)$" line) + (if (string-match + "\\([[:digit:]]+\\):\\([[:digit:]]+\\):\\([[:digit:]]+\\)$" line) (setq hour (string-to-number (match-string 1 line)) min (string-to-number (match-string 2 line)) sec (string-to-number (match-string 3 line)) @@ -1772,7 +1809,7 @@ are listed. Result is the list (LOCALNAME MODE SIZE MTIME)." (cl-return)) ;; day. - (if (string-match "\\([0-9]+\\)$" line) + (if (string-match "\\([[:digit:]]+\\)$" line) (setq day (string-to-number (match-string 1 line)) line (substring line 0 -3)) (cl-return)) @@ -1789,7 +1826,7 @@ are listed. Result is the list (LOCALNAME MODE SIZE MTIME)." (cl-return)) ;; size. - (if (string-match "\\([0-9]+\\)$" line) + (if (string-match "\\([[:digit:]]+\\)$" line) (let ((length (- (max 10 (1+ (length (match-string 1 line))))))) (setq size (string-to-number (match-string 1 line))) (when (string-match @@ -1844,7 +1881,7 @@ are listed. Result is the list (LOCALNAME MODE SIZE MTIME)." (if (and (process-live-p (tramp-get-connection-process vec)) (tramp-get-connection-property vec "posix" t)) (with-tramp-connection-property - (tramp-get-connection-process vec) "cifs-capabilities" + (tramp-get-process vec) "cifs-capabilities" (save-match-data (when (tramp-smb-send-command vec "posix") (with-current-buffer (tramp-get-connection-buffer vec) @@ -1861,8 +1898,7 @@ are listed. Result is the list (LOCALNAME MODE SIZE MTIME)." ;; When we are not logged in yet, we return nil. (if (and (tramp-smb-get-share vec) (process-live-p (tramp-get-connection-process vec))) - (with-tramp-connection-property - (tramp-get-connection-process vec) "stat-capability" + (with-tramp-connection-property (tramp-get-process vec) "stat-capability" (tramp-smb-send-command vec "stat \"/\"")))) @@ -1924,11 +1960,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) @@ -1949,6 +1983,7 @@ If ARGUMENT is non-nil, use it as argument for (host (tramp-file-name-host vec)) (domain (tramp-file-name-domain vec)) (port (tramp-file-name-port vec)) + (options tramp-smb-options) args) (cond @@ -1967,6 +2002,10 @@ If ARGUMENT is non-nil, use it as argument for (when port (setq args (append args (list "-p" port)))) (when tramp-smb-conf (setq args (append args (list "-s" tramp-smb-conf)))) + (while options + (setq args + (append args `("--option" ,(format "%s" (car options)))) + options (cdr options))) (when argument (setq args (append args (list argument)))) @@ -1994,7 +2033,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 +2171,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..98727dc4a87 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -132,6 +132,8 @@ See `tramp-actions-before-shell' for more info.") (start-file-process . ignore) (substitute-in-file-name . tramp-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-get-remote-gid . tramp-sudoedit-handle-get-remote-gid) + (tramp-get-remote-uid . tramp-sudoedit-handle-get-remote-uid) (tramp-set-file-uid-gid . tramp-sudoedit-handle-set-file-uid-gid) (unhandled-file-name-directory . ignore) (vc-registered . ignore) @@ -153,10 +155,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 +249,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 +266,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)))) @@ -284,7 +283,8 @@ absolute file names." ;; Set the time and mode. Mask possible errors. (when keep-date (ignore-errors - (set-file-times newname file-times) + (tramp-compat-set-file-times + newname file-times (unless ok-if-already-exists 'nofollow)) (set-file-modes newname file-modes))) ;; Handle `preserve-extended-attributes'. We ignore possible @@ -305,8 +305,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)) @@ -375,7 +375,7 @@ the result will be a local, non-Tramp, file name." (defun tramp-sudoedit-remote-acl-p (vec) "Check, whether ACL is enabled on the remote host." - (with-tramp-connection-property (tramp-get-connection-process vec) "acl-p" + (with-tramp-connection-property (tramp-get-process vec) "acl-p" (zerop (tramp-call-process vec "getfacl" nil nil nil "/")))) (defun tramp-sudoedit-handle-file-acl (filename) @@ -466,19 +466,21 @@ the result will be a local, non-Tramp, file name." (tramp-sudoedit-send-command v "test" "-r" (tramp-compat-file-name-unquote localname))))) -(defun tramp-sudoedit-handle-set-file-modes (filename mode) +(defun tramp-sudoedit-handle-set-file-modes (filename mode &optional flag) "Like `set-file-modes' for Tramp files." (with-parsed-tramp-file-name filename nil - (tramp-flush-file-properties v localname) - (unless (tramp-sudoedit-send-command - v "chmod" (format "%o" mode) - (tramp-compat-file-name-unquote localname)) - (tramp-error - v 'file-error "Error while changing file's mode %s" filename)))) + ;; It is unlikely that "chmod -h" works. + (unless (and (eq flag 'nofollow) (file-symlink-p filename)) + (tramp-flush-file-properties v localname) + (unless (tramp-sudoedit-send-command + v "chmod" (format "%o" mode) + (tramp-compat-file-name-unquote localname)) + (tramp-error + v 'file-error "Error while changing file's mode %s" filename))))) (defun tramp-sudoedit-remote-selinux-p (vec) "Check, whether SELINUX is enabled on the remote host." - (with-tramp-connection-property (tramp-get-connection-process vec) "selinux-p" + (with-tramp-connection-property (tramp-get-process vec) "selinux-p" (zerop (tramp-call-process vec "selinuxenabled")))) (defun tramp-sudoedit-handle-file-selinux-context (filename) @@ -486,9 +488,8 @@ the result will be a local, non-Tramp, file name." (with-parsed-tramp-file-name filename nil (with-tramp-file-property v localname "file-selinux-context" (let ((context '(nil nil nil nil)) - (regexp (eval-when-compile - (concat "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\):" - "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\)")))) + (regexp (concat "\\([[:alnum:]_]+\\):" "\\([[:alnum:]_]+\\):" + "\\([[:alnum:]_]+\\):" "\\([[:alnum:]_]+\\)"))) (when (and (tramp-sudoedit-remote-selinux-p v) (tramp-sudoedit-send-command v "ls" "-d" "-Z" @@ -513,10 +514,9 @@ the result will be a local, non-Tramp, file name." (goto-char (point-min)) (forward-line) (when (looking-at - (eval-when-compile - (concat "[[:space:]]*\\([[:digit:]]+\\)" - "[[:space:]]+\\([[:digit:]]+\\)" - "[[:space:]]+\\([[:digit:]]+\\)"))) + (concat "[[:space:]]*\\([[:digit:]]+\\)" + "[[:space:]]+\\([[:digit:]]+\\)" + "[[:space:]]+\\([[:digit:]]+\\)")) (list (string-to-number (match-string 1)) ;; The second value is the used size. We need the ;; free size. @@ -524,7 +524,7 @@ the result will be a local, non-Tramp, file name." (string-to-number (match-string 2))) (string-to-number (match-string 3))))))))) -(defun tramp-sudoedit-handle-set-file-times (filename &optional time) +(defun tramp-sudoedit-handle-set-file-times (filename &optional time flag) "Like `set-file-times' for Tramp files." (with-parsed-tramp-file-name filename nil (tramp-flush-file-properties v localname) @@ -537,14 +537,14 @@ the result will be a local, non-Tramp, file name." (tramp-sudoedit-send-command v "env" "TZ=UTC" "touch" "-t" (format-time-string "%Y%m%d%H%M.%S" time t) + (if (eq flag 'nofollow) "-h" "") (tramp-compat-file-name-unquote localname))))) (defun tramp-sudoedit-handle-file-truename (filename) "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 +615,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 +644,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)) @@ -691,21 +689,19 @@ component is used as the target of the symlink." (tramp-flush-file-property v localname "file-selinux-context")) t))))) -(defun tramp-sudoedit-get-remote-uid (vec id-format) +(defun tramp-sudoedit-handle-get-remote-uid (vec id-format) "The uid of the remote connection VEC, in ID-FORMAT. ID-FORMAT valid values are `string' and `integer'." - (with-tramp-connection-property vec (format "uid-%s" id-format) - (if (equal id-format 'integer) - (tramp-sudoedit-send-command-and-read vec "id" "-u") - (tramp-sudoedit-send-command-string vec "id" "-un")))) + (if (equal id-format 'integer) + (tramp-sudoedit-send-command-and-read vec "id" "-u") + (tramp-sudoedit-send-command-string vec "id" "-un"))) -(defun tramp-sudoedit-get-remote-gid (vec id-format) +(defun tramp-sudoedit-handle-get-remote-gid (vec id-format) "The gid of the remote connection VEC, in ID-FORMAT. ID-FORMAT valid values are `string' and `integer'." - (with-tramp-connection-property vec (format "gid-%s" id-format) - (if (equal id-format 'integer) - (tramp-sudoedit-send-command-and-read vec "id" "-g") - (tramp-sudoedit-send-command-string vec "id" "-gn")))) + (if (equal id-format 'integer) + (tramp-sudoedit-send-command-and-read vec "id" "-g") + (tramp-sudoedit-send-command-string vec "id" "-gn"))) (defun tramp-sudoedit-handle-set-file-uid-gid (filename &optional uid gid) "Like `tramp-set-file-uid-gid' for Tramp files." @@ -713,22 +709,22 @@ ID-FORMAT valid values are `string' and `integer'." (tramp-sudoedit-send-command v "chown" (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))))) + (or uid (tramp-get-remote-uid v 'integer)) + (or gid (tramp-get-remote-gid v 'integer))) + (tramp-unquote-file-local-name filename)))) (defun tramp-sudoedit-handle-write-region (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." (with-parsed-tramp-file-name filename nil - (let ((uid (or (tramp-compat-file-attribute-user-id - (file-attributes filename 'integer)) - (tramp-sudoedit-get-remote-uid v 'integer))) - (gid (or (tramp-compat-file-attribute-group-id - (file-attributes filename 'integer)) - (tramp-sudoedit-get-remote-gid v 'integer))) - (modes (tramp-default-file-modes filename))) + (let* ((uid (or (tramp-compat-file-attribute-user-id + (file-attributes filename 'integer)) + (tramp-get-remote-uid v 'integer))) + (gid (or (tramp-compat-file-attribute-group-id + (file-attributes filename 'integer)) + (tramp-get-remote-gid v 'integer))) + (flag (and (eq mustbenew 'excl) 'nofollow)) + (modes (tramp-default-file-modes filename flag))) (prog1 (tramp-handle-write-region start end filename append visit lockname mustbenew) @@ -742,7 +738,7 @@ ID-FORMAT valid values are `string' and `integer'." (file-attributes filename 'integer)) gid)) (tramp-set-file-uid-gid filename uid gid)) - (set-file-modes filename modes))))) + (tramp-compat-set-file-modes filename modes flag))))) ;; Internal functions. @@ -787,14 +783,7 @@ connection if a previous connection has died for some reason." (tramp-set-connection-local-variables vec) ;; Mark it as connected. - (tramp-set-connection-property p "connected" t)) - - ;; In `tramp-check-cached-permissions', the connection properties - ;; "{uid,gid}-{integer,string}" are used. We set them to proper values. - (tramp-sudoedit-get-remote-uid vec 'integer) - (tramp-sudoedit-get-remote-gid vec 'integer) - (tramp-sudoedit-get-remote-uid vec 'string) - (tramp-sudoedit-get-remote-gid vec 'string))) + (tramp-set-connection-property p "connected" t)))) (defun tramp-sudoedit-send-command (vec &rest args) "Send commands ARGS to connection VEC. 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 4f3249d966a..ab52bec39eb 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 @@ -37,7 +37,7 @@ ;; For more detailed instructions, please see the info file. ;; ;; Notes: -;; ----- +;; ------ ;; ;; Also see the todo list at the bottom of this file. ;; @@ -46,6 +46,7 @@ ;; ;; There's a mailing list for this, as well. Its name is: ;; tramp-devel@gnu.org + ;; You can use the Web to subscribe, under the following URL: ;; https://lists.gnu.org/mailman/listinfo/tramp-devel ;; @@ -63,6 +64,7 @@ ;; Pacify byte-compiler. (require 'cl-lib) +(declare-function file-notify-rm-watch "filenotify") (declare-function netrc-parse "netrc") (defvar auto-save-file-name-transforms) @@ -558,7 +560,7 @@ Sometimes the prompt is reported to look like \"login as:\"." ;; Allow also [] style prompts. They can appear only during ;; connection initialization; Tramp redefines the prompt afterwards. (concat "\\(?:^\\|\r\\)" - "[^]#$%>\n]*#?[]#$%>] *\\(\e\\[[0-9;]*[a-zA-Z] *\\)*") + "[^]#$%>\n]*#?[]#$%>] *\\(\e\\[[[:digit:];]*[[:alpha:]] *\\)*") "Regexp to match prompts from remote shell. Normally, Tramp expects you to configure `shell-prompt-pattern' correctly, but sometimes it happens that you are connecting to a @@ -599,7 +601,7 @@ The `sudo' program appears to insert a `^@' character into the prompt." "\\|" "^.*\\(" ;; Here comes a list of regexes, separated by \\| - "Received signal [0-9]+" + "Received signal [[:digit:]]+" "\\).*") "Regexp matching a `login failed' message. The regexp should match at end of buffer." @@ -744,7 +746,7 @@ to be set, depending on VALUE." tramp-postfix-host-format (tramp-build-postfix-host-format) tramp-postfix-host-regexp (tramp-build-postfix-host-regexp) tramp-remote-file-name-spec-regexp - (tramp-build-remote-file-name-spec-regexp) + (tramp-build-remote-file-name-spec-regexp) tramp-file-name-structure (tramp-build-file-name-structure) tramp-file-name-regexp (tramp-build-file-name-regexp) tramp-completion-file-name-regexp @@ -795,9 +797,9 @@ Used in `tramp-make-tramp-file-name'.") Should always start with \"^\". Derived from `tramp-prefix-format'.") (defconst tramp-method-regexp-alist - '((default . "[a-zA-Z0-9-]+") + '((default . "[[:alnum:]-]+") (simplified . "") - (separate . "[a-zA-Z0-9-]*")) + (separate . "[[:alnum:]-]*")) "Alist mapping Tramp syntax to regexps matching methods identifiers.") (defun tramp-build-method-regexp () @@ -841,7 +843,7 @@ Derived from `tramp-postfix-method-format'.") "Regexp matching delimiter between user and domain names. Derived from `tramp-prefix-domain-format'.") -(defconst tramp-domain-regexp "[a-zA-Z0-9_.-]+" +(defconst tramp-domain-regexp "[[:alnum:]_.-]+" "Regexp matching domain names.") (defconst tramp-user-with-domain-regexp @@ -858,7 +860,7 @@ Used in `tramp-make-tramp-file-name'.") "Regexp matching delimiter between user and host names. Derived from `tramp-postfix-user-format'.") -(defconst tramp-host-regexp "[a-zA-Z0-9_.%-]+" +(defconst tramp-host-regexp "[[:alnum:]_.%-]+" "Regexp matching host names.") (defconst tramp-prefix-ipv6-format-alist @@ -886,7 +888,7 @@ Derived from `tramp-prefix-ipv6-format'.") ;; The following regexp is a bit sloppy. But it shall serve our ;; purposes. It covers also IPv4 mapped IPv6 addresses, like in ;; "::ffff:192.168.0.1". -(defconst tramp-ipv6-regexp "\\(?:[a-zA-Z0-9]*:\\)+[a-zA-Z0-9.]+" +(defconst tramp-ipv6-regexp "\\(?:[[:alnum:]]*:\\)+[[:alnum:].]+" "Regexp matching IPv6 addresses.") (defconst tramp-postfix-ipv6-format-alist @@ -918,7 +920,7 @@ Derived from `tramp-postfix-ipv6-format'.") "Regexp matching delimiter between host names and port numbers. Derived from `tramp-prefix-port-format'.") -(defconst tramp-port-regexp "[0-9]+" +(defconst tramp-port-regexp "[[:digit:]]+" "Regexp matching port numbers.") (defconst tramp-host-with-port-regexp @@ -1258,7 +1260,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 +1308,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 +1350,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 +1371,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 +1392,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 +1413,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,16 +1476,13 @@ 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 v "Method `%s' is not known." method)) ;; Only some methods from tramp-sh.el do support multi-hops. - (when (and - hop - (or (not (tramp-get-method-parameter v 'tramp-login-program)) - (tramp-get-method-parameter v 'tramp-copy-program))) + (unless (or (null hop) nodefault non-essential (tramp-multi-hop-p v)) (tramp-user-error v "Method `%s' is not supported for multi-hops." method))))))) @@ -1491,8 +1496,7 @@ See `tramp-dissect-file-name' for details." tramp-postfix-host-format name)) nodefault))) ;; Only some methods from tramp-sh.el do support multi-hops. - (when (or (not (tramp-get-method-parameter v 'tramp-login-program)) - (tramp-get-method-parameter v 'tramp-copy-program)) + (unless (or nodefault non-essential (tramp-multi-hop-p v)) (tramp-user-error v "Method `%s' is not supported for multi-hops." (tramp-file-name-method v))) @@ -1592,7 +1596,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. @@ -1625,6 +1629,15 @@ from the default one." (or (tramp-get-connection-property vec "process-name" nil) (tramp-buffer-name vec))) +(defun tramp-get-process (vec-or-proc) + "Get the default connection process to be used for VEC-OR-PROC. +Return `tramp-cache-undefined' in case it doesn't exist." + (or (and (tramp-file-name-p vec-or-proc) + (get-buffer-process (tramp-buffer-name vec-or-proc))) + (and (processp vec-or-proc) + (tramp-get-process (process-get vec-or-proc 'vector))) + tramp-cache-undefined)) + (defun tramp-get-connection-process (vec) "Get the connection process to be used for VEC. In case a second asynchronous communication has been started, it is different @@ -1648,7 +1661,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 @@ -1667,11 +1680,10 @@ version, the function does nothing." (format "*debug tramp/%s %s*" method host-port)))) (defconst tramp-debug-outline-regexp - (eval-when-compile - (concat - "[0-9]+:[0-9]+:[0-9]+\\.[0-9]+ " ;; Timestamp. - "\\(?:\\(#<thread .+>\\) \\)?" ;; Thread. - "[a-z0-9-]+ (\\([0-9]+\\)) #")) ;; Function name, verbosity. + (concat + "[[:digit:]]+:[[:digit:]]+:[[:digit:]]+\\.[[:digit:]]+ " ;; Timestamp. + "\\(?:\\(#<thread .+>\\) \\)?" ;; Thread. + "[[:alnum:]-]+ (\\([[:digit:]]+\\)) #") ;; Function name, verbosity. "Used for highlighting Tramp debug buffers in `outline-mode'.") (defconst tramp-debug-font-lock-keywords @@ -1744,29 +1756,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 +1774,11 @@ 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) + +(defvar tramp-inhibit-progress-reporter nil + "Show Tramp progress reporter in the minibuffer. +This variable is used to disable concurrent progress reporter messages.") (defsubst tramp-message (vec-or-proc level fmt-string &rest arguments) "Emit a message depending on verbosity level. @@ -1802,8 +1795,9 @@ control string and the remaining ARGUMENTS to actually emit the message (if applicable)." (ignore-errors (when (<= level tramp-verbose) - ;; Display only when there is a minimum level. - (when (and tramp-message-show-message (<= level 3)) + ;; Display only when there is a minimum level, and the progress + ;; reporter doesn't suppress further messages. + (when (and (<= level 3) (null tramp-inhibit-progress-reporter)) (apply #'message (concat (cond @@ -1835,6 +1829,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 +1841,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 +1868,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 +1887,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 +1905,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 +1929,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 +1955,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 +1973,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 +1989,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,25 +1999,30 @@ 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)))))) + ;; Start only when there is no other progress reporter + ;; running, and when there is a minimum level. + (when-let ((pr (and (null tramp-inhibit-progress-reporter) + (<= ,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")) + (prog1 + ;; Suppress concurrent progress reporter messages. + (let ((tramp-inhibit-progress-reporter + (or tramp-inhibit-progress-reporter tm))) + ,@body) + (setq cookie "done")) ;; Stop progress reporter. (if tm (cancel-timer tm)) (tramp-message ,vec ,level "%s...%s" ,message cookie))))) @@ -2020,6 +2033,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 +2045,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 +2059,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\\>")) @@ -2060,12 +2071,15 @@ letter into the file name. This function removes it." (save-match-data (let ((quoted (tramp-compat-file-name-quoted-p name 'top)) (result (tramp-compat-file-name-unquote name 'top))) - (setq result (if (string-match "\\`[a-zA-Z]:/" result) + (setq result (if (string-match "\\`[[:alpha:]]:/" result) (replace-match "/" nil t result) result)) (if quoted (tramp-compat-file-name-quote result 'top) result)))) ;;; 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 +2112,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))) @@ -2139,11 +2153,13 @@ For definition of that list see `tramp-set-completion-function'." (defvar tramp-devices 0 "Keeps virtual device numbers.") -(defun tramp-default-file-modes (filename) +(defun tramp-default-file-modes (filename &optional flag) "Return file modes of FILENAME as integer. -If the file modes of FILENAME cannot be determined, return the -value of `default-file-modes', without execute permissions." - (or (file-modes filename) +If optional FLAG is ‘nofollow’, do not follow FILENAME if it is a +symbolic link. If the file modes of FILENAME cannot be +determined, return the value of `default-file-modes', without +execute permissions." + (or (tramp-compat-file-modes filename flag) (logand (default-file-modes) #o0666))) (defun tramp-replace-environment-variables (filename) @@ -2174,6 +2190,7 @@ arguments to pass to the OPERATION." tramp-vc-file-name-handler tramp-completion-file-name-handler tramp-archive-file-name-handler + tramp-crypt-file-name-handler cygwin-mount-name-hook-function cygwin-mount-map-drive-hook-function . @@ -2239,7 +2256,7 @@ Must be handled by the callers." file-newer-than-file-p rename-file)) (cond ((tramp-tramp-file-p (nth 0 args)) (nth 0 args)) - ((tramp-tramp-file-p (nth 1 args)) (nth 1 args)) + ((file-name-absolute-p (nth 1 args)) (nth 1 args)) (t default-directory))) ;; FILE DIRECTORY resp FILE1 FILE2. ((eq operation 'expand-file-name) @@ -2267,13 +2284,13 @@ 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))) + ;; VEC. + ((member operation '(tramp-get-remote-gid tramp-get-remote-uid)) + (tramp-make-tramp-file-name (nth 0 args))) ;; Unknown file primitive. (t (error "Unknown file I/O primitive: %s" operation)))) @@ -2390,7 +2407,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 +2436,21 @@ 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 + ;; We cannot use `tramp-compat-temporary-file-directory' here due + ;; to autoload. + (let ((default-directory temporary-file-directory)) + (load "tramp" 'noerror 'nomessage))) (apply operation args))) ;; `tramp-autoload-file-name-handler' must be registered before @@ -2442,7 +2462,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) @@ -2478,34 +2498,36 @@ remote file names." (tramp-unload-file-name-handlers) ;; Add the handlers. We do not add anything to the `operations' - ;; property of `tramp-file-name-handler' and - ;; `tramp-archive-file-name-handler', this shall be done by the + ;; property of `tramp-file-name-handler', + ;; `tramp-archive-file-name-handler' and + ;; `tramp-crypt-file-name-handler', this shall be done by the ;; 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) + + (tramp-register-crypt-file-name-handler) (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 +2539,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 +2580,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 +2594,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 +2873,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 +2885,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 "\\)" @@ -2926,7 +2935,7 @@ User is always nil." "Return a list of (user host) tuples allowed to access. User is always nil." (tramp-parse-shostkeys-sknownhosts - dirname (concat "^key_[0-9]+_\\(" tramp-host-regexp "\\)\\.pub$"))) + dirname (concat "^key_[[:digit:]]+_\\(" tramp-host-regexp "\\)\\.pub$"))) (defun tramp-parse-sknownhosts (dirname) "Return a list of (user host) tuples allowed to access. @@ -2961,7 +2970,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 +2992,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 +3029,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)))) @@ -3199,12 +3208,13 @@ User is always nil." (copy-file filename tmpfile 'ok-if-already-exists 'keep-time) tmpfile))) -(defun tramp-handle-file-modes (filename) +(defun tramp-handle-file-modes (filename &optional flag) "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 filename)) + (mode-string (tramp-compat-file-attribute-modes attrs))) + (if (and (not (eq flag 'nofollow)) (eq ?l (aref mode-string 0))) + (file-modes (file-truename filename)) + (tramp-mode-string-to-int mode-string)))) ;; Localname manipulation functions that grok Tramp localnames... (defun tramp-handle-file-name-as-directory (file) @@ -3242,12 +3252,13 @@ User is always nil." (let ((candidate (tramp-compat-file-name-unquote (directory-file-name filename))) + case-fold-search tmpfile) ;; Check, whether we find an existing file with ;; lower case letters. This avoids us to create a ;; temporary file. (while (and (string-match-p - "[a-z]" (tramp-compat-file-local-name candidate)) + "[[:lower:]]" (tramp-file-local-name candidate)) (not (file-exists-p candidate))) (setq candidate (directory-file-name @@ -3256,9 +3267,8 @@ User is always nil." ;; for comparison. `make-nearby-temp-file' is added ;; 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)) + (unless (string-match-p + "[[:lower:]]" (tramp-file-local-name candidate)) (setq tmpfile (let ((default-directory (file-name-directory filename))) @@ -3271,7 +3281,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 +3333,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 +3383,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) @@ -3389,6 +3395,8 @@ User is always nil." ;; something is wrong; otherwise they might think that Emacs ;; is hung. Of course, correctness has to come first. (numchase-limit 20) + ;; Unquoting could enable encryption. + tramp-crypt-enabled symlink-target) (with-parsed-tramp-file-name result v1 ;; We cache only the localname. @@ -3413,7 +3421,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 +3456,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 +3466,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)) @@ -3507,10 +3515,10 @@ User is always nil." ;; When we shall insert only a part of the file, we ;; copy this part. This works only for the shell file - ;; name handlers. + ;; name handlers. It doesn't work for crypted files. (when (and (or beg end) - (tramp-get-method-parameter - v 'tramp-login-program)) + (tramp-sh-file-name-handler-p v) + (null tramp-crypt-enabled)) (setq remote-copy (tramp-make-tramp-temp-file v)) ;; This is defined in tramp-sh.el. Let's assume ;; this is loaded already. @@ -3582,8 +3590,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 +3625,8 @@ 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 ((signal-hook-function (unless noerror signal-hook-function)) + (inhibit-message (or inhibit-message nomessage))) (with-tramp-progress-reporter v 0 (format "Loading %s" file) (let ((local-copy (file-local-copy file))) (unwind-protect @@ -3625,6 +3634,167 @@ User is always nil." (delete-file local-copy))))) t))) +(defun tramp-direct-async-process-p (&rest args) + "Whether direct async `make-process' can be called." + (let ((v (tramp-dissect-file-name default-directory))) + (and (tramp-get-connection-property v"direct-async-process" nil) + (not (tramp-multi-hop-p v)) + (not (plist-get args :stderr))))) + +;; We use BUFFER also as connection buffer during setup. Because of +;; this, its original contents must be saved, and restored once +;; connection has been setup. +(defun tramp-handle-make-process (&rest args) + "An alternative `make-process' implementation for Tramp files. +It does not support `:stderr'." + (when args + (with-parsed-tramp-file-name (expand-file-name default-directory) nil + (let ((name (plist-get args :name)) + (buffer (plist-get args :buffer)) + (command (plist-get args :command)) + ;; FIXME: `:coding' shall be used. + (coding (plist-get args :coding)) + (noquery (plist-get args :noquery)) + ;; FIXME: `:connection-type' shall be used. + (connection-type (plist-get args :connection-type)) + (filter (plist-get args :filter)) + (sentinel (plist-get args :sentinel)) + (stderr (plist-get args :stderr))) + (unless (stringp name) + (signal 'wrong-type-argument (list #'stringp name))) + (unless (or (null buffer) (bufferp buffer) (stringp buffer)) + (signal 'wrong-type-argument (list #'stringp buffer))) + (unless (consp command) + (signal 'wrong-type-argument (list #'consp command))) + (unless (or (null coding) + (and (symbolp coding) (memq coding coding-system-list)) + (and (consp coding) + (memq (car coding) coding-system-list) + (memq (cdr coding) coding-system-list))) + (signal 'wrong-type-argument (list #'symbolp coding))) + (unless (or (null connection-type) (memq connection-type '(pipe pty))) + (signal 'wrong-type-argument (list #'symbolp connection-type))) + (unless (or (null filter) (functionp filter)) + (signal 'wrong-type-argument (list #'functionp filter))) + (unless (or (null sentinel) (functionp sentinel)) + (signal 'wrong-type-argument (list #'functionp sentinel))) + (when stderr + (signal + 'user-error + (list + "Stderr not supported for direct remote asynchronous processes" + stderr))) + + (let* ((buffer + (if buffer + (get-buffer-create buffer) + ;; BUFFER can be nil. We use a temporary buffer. + (generate-new-buffer tramp-temp-buffer-name))) + (command (append `("cd" ,localname "&&") + (mapcar #'tramp-shell-quote-argument command))) + (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer))) + (name1 name) + (i 0) + ;; We do not want to raise an error when `make-process' + ;; has been started several times in `eshell' and + ;; friends. + tramp-current-connection + p) + + (while (get-process name1) + ;; NAME must be unique as process name. + (setq i (1+ i) + name1 (format "%s<%d>" name i))) + (setq name name1) + ;; Set the new process properties. + (tramp-set-connection-property v "process-name" name) + (tramp-set-connection-property v "process-buffer" buffer) + + ;; Check for `tramp-sh-file-name-handler', because something + ;; is different between tramp-adb.el and tramp-sh.el. + (with-current-buffer (tramp-get-connection-buffer v) + (unwind-protect + (let* ((sh-file-name-handler-p (tramp-sh-file-name-handler-p v)) + (login-program + (tramp-get-method-parameter v 'tramp-login-program)) + (login-args + (tramp-get-method-parameter v 'tramp-login-args)) + (async-args + (tramp-get-method-parameter v 'tramp-async-args)) + ;; We don't create the temporary file. In + ;; fact, it is just a prefix for the + ;; ControlPath option of ssh; the real + ;; temporary file has another name, and it is + ;; created and protected by ssh. It is also + ;; removed by ssh when the connection is + ;; closed. The temporary file name is cached + ;; in the main connection process, therefore + ;; we cannot use `tramp-get-connection-process'. + (tmpfile + (when sh-file-name-handler-p + (with-tramp-connection-property + (tramp-get-process v) "temp-file" + (tramp-compat-make-temp-name)))) + (options + (when sh-file-name-handler-p + (tramp-compat-funcall + 'tramp-ssh-controlmaster-options v))) + spec) + + ;; Replace `login-args' place holders. + (setq + spec (format-spec-make ?t tmpfile) + options (format-spec (or options "") spec) + spec (format-spec-make + ?h (or host "") ?u (or user "") ?p (or port "") + ?c options ?l "") + ;; Add arguments for asynchronous processes. + login-args (append async-args login-args) + ;; Expand format spec. + login-args + (tramp-compat-flatten-tree + (mapcar + (lambda (x) + (setq x (mapcar (lambda (y) (format-spec y spec)) x)) + (unless (member "" x) x)) + login-args)) + ;; Split ControlMaster options. + login-args + (tramp-compat-flatten-tree + (mapcar (lambda (x) (split-string x " ")) login-args)) + p (apply + #'start-process + name buffer login-program (append login-args command))) + + (tramp-message v 6 "%s" (string-join (process-command p) " ")) + ;; Set sentinel and filter. + (when sentinel + (set-process-sentinel p sentinel)) + (when filter + (set-process-filter p filter)) + ;; Set query flag and process marker for this + ;; process. We ignore errors, because the + ;; process could have finished already. + (ignore-errors + (set-process-query-on-exit-flag p (null noquery)) + (set-marker (process-mark p) (point))) + ;; We must flush them here already; otherwise + ;; `rename-file', `delete-file' or + ;; `insert-file-contents' will fail. + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer") + ;; Return process. + p) + + ;; Save exit. + (if (string-match-p tramp-temp-buffer-name (buffer-name)) + (ignore-errors + (set-process-buffer p nil) + (kill-buffer (current-buffer))) + (set-buffer-modified-p bmp)) + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer")))))))) + (defun tramp-handle-make-symbolic-link (target linkname &optional ok-if-already-exists) "Like `make-symbolic-link' for Tramp files. @@ -3645,28 +3815,43 @@ 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)) (t (get-buffer-create + ;; These variables have been introduced with Emacs 28.1. (if asynchronous - "*Async Shell Command*" - "*Shell Command Output*"))))) + (or (bound-and-true-p shell-command-buffer-name-async) + "*Async Shell Command*") + (or (bound-and-true-p shell-command-buffer-name) + "*Shell Command Output*")))))) (error-buffer (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 +3883,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 +3914,69 @@ 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." - ;; `make-process' knows the `:file-handler' argument since Emacs 27.1 only. + "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. Therefore, we invoke it via `tramp-file-name-handler'. (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)) @@ -3862,7 +4077,14 @@ of." (tramp-error v 'file-already-exists filename)) (let ((tmpfile (tramp-compat-make-temp-file filename)) - (modes (save-excursion (tramp-default-file-modes filename)))) + (modes (tramp-default-file-modes + filename (and (eq mustbenew 'excl) 'nofollow))) + (uid (or (tramp-compat-file-attribute-user-id + (file-attributes filename 'integer)) + (tramp-get-remote-uid v 'integer))) + (gid (or (tramp-compat-file-attribute-group-id + (file-attributes filename 'integer)) + (tramp-get-remote-gid v 'integer)))) (when (and append (file-exists-p filename)) (copy-file filename tmpfile 'ok)) ;; The permissions of the temporary file should be set. If @@ -3881,15 +4103,18 @@ of." (error (delete-file tmpfile) (tramp-error - v 'file-error "Couldn't write region to `%s'" filename)))) + v 'file-error "Couldn't write region to `%s'" filename))) - (tramp-flush-file-properties v localname) + (tramp-flush-file-properties v localname) - ;; Set file modification time. - (when (or (eq visit t) (stringp visit)) - (set-visited-file-modtime - (tramp-compat-file-attribute-modification-time - (file-attributes filename)))) + ;; Set file modification time. + (when (or (eq visit t) (stringp visit)) + (set-visited-file-modtime + (tramp-compat-file-attribute-modification-time + (file-attributes filename)))) + + ;; Set the ownership. + (tramp-set-file-uid-gid filename uid gid)) ;; The end. (when (and (null noninteractive) @@ -3943,7 +4168,7 @@ of." "Call `file-notify-rm-watch'." (unless (process-live-p proc) (tramp-message proc 5 "Sentinel called: `%S' `%s'" proc event) - (tramp-compat-funcall 'file-notify-rm-watch proc))) + (file-notify-rm-watch proc))) ;;; Functions for establishing connection: @@ -4044,6 +4269,8 @@ The terminal type can be configured with `tramp-terminal-type'." (defun tramp-action-process-alive (proc _vec) "Check, whether a process has finished." (unless (process-live-p proc) + ;; There might be pending output. + (while (tramp-accept-process-output proc 0)) (throw 'tramp-action 'process-died))) (defun tramp-action-out-of-band (proc vec) @@ -4083,9 +4310,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 +4362,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))) @@ -4158,10 +4384,9 @@ performed successfully. Any other value means an error." (tramp-get-connection-buffer vec))) ((eq exit 'process-died) (substitute-command-keys - (eval-when-compile - (concat - "Tramp failed to connect. If this happens repeatedly, try\n" - " `\\[tramp-cleanup-this-connection]'")))) + (concat + "Tramp failed to connect. If this happens repeatedly, try\n" + " `\\[tramp-cleanup-this-connection]'"))) ((eq exit 'timeout) (format-message "Timeout reached, see buffer `%s' for details" @@ -4176,18 +4401,21 @@ performed successfully. Any other value means an error." (defun tramp-accept-process-output (proc &optional timeout) "Like `accept-process-output' for Tramp processes. This is needed in order to hide `last-coding-system-used', which is set -for process communication also." +for process communication also. +If the user quits via `C-g', it is propagated up to `tramp-file-name-handler'." (with-current-buffer (process-buffer proc) (let ((inhibit-read-only t) last-coding-system-used result) - ;; JUST-THIS-ONE is set due to Bug#12145. - (tramp-message - proc 10 "%s %s %s %s\n%s" - proc timeout (process-status proc) - (with-local-quit - (setq result (accept-process-output proc timeout nil t))) - (buffer-string)) + ;; JUST-THIS-ONE is set due to Bug#12145. `with-local-quit' + ;; returns t in order to report success. + (if (with-local-quit + (setq result (accept-process-output proc timeout nil t)) t) + (tramp-message + proc 10 "%s %s %s %s\n%s" + proc timeout (process-status proc) result (buffer-string)) + ;; Propagate quit. + (keyboard-quit)) result))) (defun tramp-search-regexp (regexp) @@ -4362,7 +4590,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 +4683,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 +4715,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. @@ -4562,12 +4789,8 @@ be granted." (concat "file-attributes-" suffix) nil) (file-attributes (tramp-make-tramp-file-name vec) (intern suffix)))) - (remote-uid - (tramp-get-connection-property - vec (concat "uid-" suffix) nil)) - (remote-gid - (tramp-get-connection-property - vec (concat "gid-" suffix) nil)) + (remote-uid (tramp-get-remote-uid vec (intern suffix))) + (remote-gid (tramp-get-remote-gid vec (intern suffix))) (unknown-id (if (string-equal suffix "string") tramp-unknown-id-string tramp-unknown-id-integer))) @@ -4601,6 +4824,32 @@ be granted." (tramp-compat-file-attribute-group-id file-attr)))))))))))) +(defun tramp-get-remote-uid (vec id-format) + "The uid of the remote connection VEC, in ID-FORMAT. +ID-FORMAT valid values are `string' and `integer'." + (with-tramp-connection-property vec (format "uid-%s" id-format) + (or (when-let + ((handler + (find-file-name-handler + (tramp-make-tramp-file-name vec) 'tramp-get-remote-uid))) + (funcall handler #'tramp-get-remote-uid vec id-format)) + ;; Ensure there is a valid result. + (and (equal id-format 'integer) tramp-unknown-id-integer) + (and (equal id-format 'string) tramp-unknown-id-string)))) + +(defun tramp-get-remote-gid (vec id-format) + "The gid of the remote connection VEC, in ID-FORMAT. +ID-FORMAT valid values are `string' and `integer'." + (with-tramp-connection-property vec (format "gid-%s" id-format) + (or (when-let + ((handler + (find-file-name-handler + (tramp-make-tramp-file-name vec) 'tramp-get-remote-uid))) + (funcall handler #'tramp-get-remote-gid vec id-format)) + ;; Ensure there is a valid result. + (and (equal id-format 'integer) tramp-unknown-id-integer) + (and (equal id-format 'string) tramp-unknown-id-string)))) + (defun tramp-local-host-p (vec) "Return t if this points to the local host, nil otherwise. This handles also chrooted environments, which are not regarded as local." @@ -4614,16 +4863,16 @@ This handles also chrooted environments, which are not regarded as local." ;; The method shall be applied to one of the shell file name ;; handlers. `tramp-local-host-p' is also called for "smb" and ;; alike, where it must fail. - (tramp-get-method-parameter vec 'tramp-login-program) + (tramp-sh-file-name-handler-p vec) + ;; Direct actions aren't possible for crypted directories. + (null tramp-crypt-enabled) ;; The local temp directory must be writable for the other user. (file-writable-p (tramp-make-tramp-file-name vec (tramp-compat-temporary-file-directory) 'nohop)) ;; On some systems, chown runs only for root. (or (zerop (user-uid)) - ;; This is defined in tramp-sh.el. Let's assume this is - ;; loaded already. - (zerop (tramp-compat-funcall 'tramp-get-remote-uid vec 'integer)))))) + (zerop (tramp-get-remote-uid vec 'integer)))))) (defun tramp-get-remote-tmpdir (vec) "Return directory for temporary files on the remote host identified by VEC." @@ -4632,22 +4881,25 @@ 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))) +(defun tramp-make-tramp-temp-name (vec) + "Generate a temporary file name on the remote host identified by VEC." + (make-temp-name + (expand-file-name tramp-temp-name-prefix (tramp-get-remote-tmpdir vec)))) + (defun tramp-make-tramp-temp-file (vec) "Create a temporary file on the remote host identified by VEC. Return the local name of the temporary file." - (let ((prefix (expand-file-name - tramp-temp-name-prefix (tramp-get-remote-tmpdir vec))) - result) + (let (result) (while (not result) ;; `make-temp-file' would be the natural choice for ;; implementation. But it calls `write-region' internally, ;; which also needs a temporary file - we would end in an ;; infinite loop. - (setq result (make-temp-name prefix)) + (setq result (tramp-make-tramp-temp-name vec)) (if (file-exists-p result) (setq result nil) ;; This creates the file by side effect. @@ -4655,7 +4907,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 +4934,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 +5072,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 (list-system-processes)) + (when-let ((attributes (process-attributes pid)) + (comm (cdr (assoc 'comm attributes)))) + (and (string-equal (cdr (assoc 'user attributes)) (user-login-name)) + ;; 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 +5246,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 +5306,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..8d21133b3b1 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 @@ -51,6 +48,7 @@ ;; Suppress message from `emacs-repository-get-branch'. We must ;; also handle out-of-tree builds. (let ((inhibit-message t) + (debug-on-error nil) (dir (or (locate-dominating-file (locate-library "tramp") ".git") source-directory))) ;; `emacs-repository-get-branch' has been introduced with Emacs 27.1. @@ -64,6 +62,7 @@ ;; Suppress message from `emacs-repository-get-version'. We must ;; also handle out-of-tree builds. (let ((inhibit-message t) + (debug-on-error nil) (dir (or (locate-dominating-file (locate-library "tramp") ".git") source-directory))) (and (stringp dir) (file-directory-p dir) @@ -71,9 +70,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 +101,3 @@ (provide 'trampver) ;;; trampver.el ends here - -;; Local Variables: -;; mode: Emacs-Lisp -;; coding: utf-8 -;; End: diff --git a/lisp/net/webjump.el b/lisp/net/webjump.el index 6edd03c39cc..8bb156199c5 100644 --- a/lisp/net/webjump.el +++ b/lisp/net/webjump.el @@ -1,4 +1,4 @@ -;;; webjump.el --- programmable Web hotlist +;;; webjump.el --- programmable Web hotlist -*- lexical-binding: t; -*- ;; Copyright (C) 1996-1997, 2001-2020 Free Software Foundation, Inc. @@ -323,8 +323,7 @@ Please submit bug reports and other feedback to the author, Neil W. Van Dyke (defun webjump-read-url-choice (what urls &optional default) ;; Note: Convert this to use `webjump-read-choice' someday. - (let* ((completions (mapcar (function (lambda (n) (cons n n))) - urls)) + (let* ((completions (mapcar (lambda (n) (cons n n)) urls)) (input (completing-read (concat what ;;(if default " (RET for default)" "") ": ") 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/ledit.el b/lisp/obsolete/ledit.el deleted file mode 100644 index c99a06de570..00000000000 --- a/lisp/obsolete/ledit.el +++ /dev/null @@ -1,157 +0,0 @@ -;;; ledit.el --- Emacs side of ledit interface - -;; Copyright (C) 1985, 2001-2020 Free Software Foundation, Inc. - -;; Maintainer: emacs-devel@gnu.org -;; Keywords: languages -;; Obsolete-since: 24.3 - -;; 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 is a major mode for editing Liszt. - -;;; Code: - -;;; To do: -;;; o lisp -> emacs side of things (grind-definition and find-definition) - -(defvar ledit-mode-map nil) - -(defconst ledit-zap-file - (expand-file-name (concat (user-login-name) ".l1") temporary-file-directory) - "File name for data sent to Lisp by Ledit.") -(defconst ledit-read-file - (expand-file-name (concat (user-login-name) ".l2") temporary-file-directory) - "File name for data sent to Ledit by Lisp.") -(defconst ledit-compile-file - (expand-file-name (concat (user-login-name) ".l4") temporary-file-directory) - "File name for data sent to Lisp compiler by Ledit.") -(defconst ledit-buffer "*LEDIT*" - "Name of buffer in which Ledit accumulates data to send to Lisp.") - -;;;###autoload -(defconst ledit-save-files t "\ -*Non-nil means Ledit should save files before transferring to Lisp.") -;;;###autoload -(defconst ledit-go-to-lisp-string "%?lisp" "\ -*Shell commands to execute to resume Lisp job.") -;;;###autoload -(defconst ledit-go-to-liszt-string "%?liszt" "\ -*Shell commands to execute to resume Lisp compiler job.") - -(defun ledit-save-defun () - "Save the current defun in the ledit buffer." - (interactive) - (save-excursion - (end-of-defun) - (let ((end (point))) - (beginning-of-defun) - (append-to-buffer ledit-buffer (point) end)) - (message "Current defun saved for Lisp"))) - -(defun ledit-save-region (beg end) - "Save the current region in the ledit buffer" - (interactive "r") - (append-to-buffer ledit-buffer beg end) - (message "Region saved for Lisp")) - -(defun ledit-zap-defun-to-lisp () - "Carry the current defun to Lisp." - (interactive) - (ledit-save-defun) - (ledit-go-to-lisp)) - -(defun ledit-zap-defun-to-liszt () - "Carry the current defun to liszt." - (interactive) - (ledit-save-defun) - (ledit-go-to-liszt)) - -(defun ledit-zap-region-to-lisp (beg end) - "Carry the current region to Lisp." - (interactive "r") - (ledit-save-region beg end) - (ledit-go-to-lisp)) - -(defun ledit-go-to-lisp () - "Suspend Emacs and restart a waiting Lisp job." - (interactive) - (if ledit-save-files - (save-some-buffers)) - (if (get-buffer ledit-buffer) - (with-current-buffer ledit-buffer - (goto-char (point-min)) - (write-region (point-min) (point-max) ledit-zap-file) - (erase-buffer))) - (suspend-emacs ledit-go-to-lisp-string) - (load ledit-read-file t t)) - -(defun ledit-go-to-liszt () - "Suspend Emacs and restart a waiting Liszt job." - (interactive) - (if ledit-save-files - (save-some-buffers)) - (if (get-buffer ledit-buffer) - (with-current-buffer ledit-buffer - (goto-char (point-min)) - (insert "(declare (macros t))\n") - (write-region (point-min) (point-max) ledit-compile-file) - (erase-buffer))) - (suspend-emacs ledit-go-to-liszt-string) - (load ledit-read-file t t)) - -(defun ledit-setup () - "Set up key bindings for the Lisp/Emacs interface." - (unless ledit-mode-map - (setq ledit-mode-map (make-sparse-keymap)) - (set-keymap-parent ledit-mode-map lisp-mode-shared-map)) - (define-key ledit-mode-map "\e\^d" 'ledit-save-defun) - (define-key ledit-mode-map "\e\^r" 'ledit-save-region) - (define-key ledit-mode-map "\^xz" 'ledit-go-to-lisp) - (define-key ledit-mode-map "\e\^c" 'ledit-go-to-liszt)) - -(ledit-setup) - -;;;###autoload -(defun ledit-mode () - "\\<ledit-mode-map>Major mode for editing text and stuffing it to a Lisp job. -Like Lisp mode, plus these special commands: - \\[ledit-save-defun] -- record defun at or after point - for later transmission to Lisp job. - \\[ledit-save-region] -- record region for later transmission to Lisp job. - \\[ledit-go-to-lisp] -- transfer to Lisp job and transmit saved text. - \\[ledit-go-to-liszt] -- transfer to Liszt (Lisp compiler) job - and transmit saved text. - -\\{ledit-mode-map} -To make Lisp mode automatically change to Ledit mode, -do (setq lisp-mode-hook 'ledit-from-lisp-mode)" - (interactive) - (delay-mode-hooks (lisp-mode)) - (ledit-from-lisp-mode)) - -;;;###autoload -(defun ledit-from-lisp-mode () - (use-local-map ledit-mode-map) - (setq mode-name "Ledit") - (setq major-mode 'ledit-mode) - (run-mode-hooks 'ledit-mode-hook)) - -(provide 'ledit) - -;;; ledit.el ends here diff --git a/lisp/obsolete/levents.el b/lisp/obsolete/levents.el deleted file mode 100644 index 2ae1ca48d16..00000000000 --- a/lisp/obsolete/levents.el +++ /dev/null @@ -1,292 +0,0 @@ -;;; levents.el --- emulate the Lucid event data type and associated functions - -;; Copyright (C) 1993, 2001-2020 Free Software Foundation, Inc. - -;; Maintainer: emacs-devel@gnu.org -;; Keywords: emulations -;; Obsolete-since: 23.2 - -;; 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: - -;; Things we cannot emulate in Lisp: -;; It is not possible to emulate current-mouse-event as a variable, -;; though it is not hard to obtain the data from (this-command-keys). - -;; We do not have a variable unread-command-event; -;; instead, we have the more general unread-command-events. - -;; Our read-key-sequence and read-char are not precisely -;; compatible with those in Lucid Emacs, but they should work ok. - -;;; Code: - -(defun next-command-event (event) - (error "You must rewrite to use `read-command-event' instead of `next-command-event'")) - -(defun next-event (event) - (error "You must rewrite to use `read-event' instead of `next-event'")) - -(defun dispatch-event (event) - (error "`dispatch-event' not supported")) - -;; Make events of type eval, menu and timeout -;; execute properly. - -(define-key global-map [menu] 'execute-eval-event) -(define-key global-map [timeout] 'execute-eval-event) -(define-key global-map [eval] 'execute-eval-event) - -(defun execute-eval-event (event) - (interactive "e") - (funcall (nth 1 event) (nth 2 event))) - -(put 'eval 'event-symbol-elements '(eval)) -(put 'menu 'event-symbol-elements '(eval)) -(put 'timeout 'event-symbol-elements '(eval)) - -(defun allocate-event () - "Return an empty event structure. -In this emulation, it returns nil." - nil) - -(defun button-press-event-p (obj) - "True if the argument is a mouse-button-press event object." - (and (consp obj) (symbolp (car obj)) - (memq 'down (get (car obj) 'event-symbol-elements)))) - -(defun button-release-event-p (obj) - "True if the argument is a mouse-button-release event object." - (and (consp obj) (symbolp (car obj)) - (or (memq 'click (get (car obj) 'event-symbol-elements)) - (memq 'drag (get (car obj) 'event-symbol-elements))))) - -(defun button-event-p (obj) - "True if the argument is a mouse-button press or release event object." - (and (consp obj) (symbolp (car obj)) - (or (memq 'click (get (car obj) 'event-symbol-elements)) - (memq 'down (get (car obj) 'event-symbol-elements)) - (memq 'drag (get (car obj) 'event-symbol-elements))))) - -(defun mouse-event-p (obj) - "True if the argument is a mouse-button press or release event object." - (and (consp obj) (symbolp (car obj)) - (or (eq (car obj) 'mouse-movement) - (memq 'click (get (car obj) 'event-symbol-elements)) - (memq 'down (get (car obj) 'event-symbol-elements)) - (memq 'drag (get (car obj) 'event-symbol-elements))))) - -(defun character-to-event (ch &optional event) - "Converts a numeric ASCII value to an event structure, replete with -bucky bits. The character is the first argument, and the event to fill -in is the second. This function contains knowledge about what the codes -mean -- for example, the number 9 is converted to the character Tab, -not the distinct character Control-I. - -Beware that character-to-event and event-to-character are not strictly -inverse functions, since events contain much more information than the -ASCII character set can encode." - ch) - -(defun copy-event (event1 &optional event2) - "Make a copy of the given event object. -In this emulation, `copy-event' just returns its argument." - event1) - -(defun deallocate-event (event) - "Allow the given event structure to be reused. -In actual Lucid Emacs, you MUST NOT use this event object after -calling this function with it. You will lose. It is not necessary to -call this function, as event objects are garbage- collected like all -other objects; however, it may be more efficient to explicitly -deallocate events when you are sure that this is safe. - -This emulation does not actually deallocate or reuse events -except via garbage collection and `cons'." - nil) - -(defun enqueue-eval-event: (function object) - "Add an eval event to the back of the queue. -It will be the next event read after all pending events." - (setq unread-command-events - (nconc unread-command-events - (list (list 'eval function object))))) - -(defun eval-event-p (obj) - "True if the argument is an eval or menu event object." - (eq (car-safe obj) 'eval)) - -(defun event-button (event) - "Return the button-number of the given mouse-button-press event." - (let ((sym (car (get (car event) 'event-symbol-elements)))) - (cdr (assq sym '((mouse-1 . 1) (mouse-2 . 2) (mouse-3 . 3) - (mouse-4 . 4) (mouse-5 . 5)))))) - -(defun event-function (event) - "Return the callback function of the given timeout, menu, or eval event." - (nth 1 event)) - -(defun event-key (event) - "Return the KeySym of the given key-press event. -The value is an ASCII printing character (not upper case) or a symbol." - (if (symbolp event) - (car (get event 'event-symbol-elements)) - (let ((base (logand event (1- (ash 1 18))))) - (downcase (if (< base 32) (logior base 64) base))))) - -(defun event-object (event) - "Return the function argument of the given timeout, menu, or eval event." - (nth 2 event)) - -(defun event-point (event) - "Return the character position of the given mouse-related event. -If the event did not occur over a window, or did -not occur over text, then this returns nil. Otherwise, it returns an index -into the buffer visible in the event's window." - (posn-point (event-end event))) - -;; Return position of start of line LINE in WINDOW. -;; If LINE is nil, return the last position -;; visible in WINDOW. -(defun event-closest-point-1 (window &optional line) - (let* ((total (- (window-height window) - (if (window-minibuffer-p window) - 0 1))) - (distance (or line total))) - (save-excursion - (goto-char (window-start window)) - (if (= (vertical-motion distance) distance) - (if (not line) - (forward-char -1))) - (point)))) - -(defun event-closest-point (event &optional start-window) - "Return the nearest position to where EVENT ended its motion. -This is computed for the window where EVENT's motion started, -or for window WINDOW if that is specified." - (or start-window (setq start-window (posn-window (event-start event)))) - (if (eq start-window (posn-window (event-end event))) - (if (eq (event-point event) 'vertical-line) - (event-closest-point-1 start-window - (cdr (posn-col-row (event-end event)))) - (if (eq (event-point event) 'mode-line) - (event-closest-point-1 start-window) - (event-point event))) - ;; EVENT ended in some other window. - (let* ((end-w (posn-window (event-end event))) - (end-w-top) - (w-top (nth 1 (window-edges start-window)))) - (setq end-w-top - (if (windowp end-w) - (nth 1 (window-edges end-w)) - (/ (cdr (posn-x-y (event-end event))) - (frame-char-height end-w)))) - (if (>= end-w-top w-top) - (event-closest-point-1 start-window) - (window-start start-window))))) - -(defun event-process (event) - "Return the process of the given process-output event." - (nth 1 event)) - -(defun event-timestamp (event) - "Return the timestamp of the given event object. -In Lucid Emacs, this works for any kind of event. -In this emulation, it returns nil for non-mouse-related events." - (and (listp event) - (posn-timestamp (event-end event)))) - -(defun event-to-character (event &optional lenient) - "Return the closest ASCII approximation to the given event object. -If the event isn't a keypress, this returns nil. -If the second argument is non-nil, then this is lenient in its -translation; it will ignore modifier keys other than control and meta, -and will ignore the shift modifier on those characters which have no -shifted ASCII equivalent (Control-Shift-A for example, will be mapped to -the same ASCII code as Control-A.) If the second arg is nil, then nil -will be returned for events which have no direct ASCII equivalent." - (if (symbolp event) - (and lenient - (cdr (assq event '((backspace . 8) (delete . 127) (tab . 9) - (return . 10) (enter . 10))))) - ;; Our interpretation is, ASCII means anything a number can represent. - (if (integerp event) - event nil))) - -(defun event-window (event) - "Return the window of the given mouse-related event object." - (posn-window (event-end event))) - -(defun event-x (event) - "Return the X position in characters of the given mouse-related event." - (/ (car (posn-col-row (event-end event))) - (frame-char-width (window-frame (event-window event))))) - -(defun event-x-pixel (event) - "Return the X position in pixels of the given mouse-related event." - (car (posn-col-row (event-end event)))) - -(defun event-y (event) - "Return the Y position in characters of the given mouse-related event." - (/ (cdr (posn-col-row (event-end event))) - (frame-char-height (window-frame (event-window event))))) - -(defun event-y-pixel (event) - "Return the Y position in pixels of the given mouse-related event." - (cdr (posn-col-row (event-end event)))) - -(defun key-press-event-p (obj) - "True if the argument is a keyboard event object." - (or (integerp obj) - (and (symbolp obj) - (get obj 'event-symbol-elements)))) - -(defun menu-event-p (obj) - "True if the argument is a menu event object." - (eq (car-safe obj) 'menu)) - -(defun motion-event-p (obj) - "True if the argument is a mouse-motion event object." - (eq (car-safe obj) 'mouse-movement)) - -(defun read-command-event () - "Return the next keyboard or mouse event; execute other events. -This is similar to the function `next-command-event' of Lucid Emacs, -but different in that it returns the event rather than filling in -an existing event object." - (let (event) - (while (progn - (setq event (read-event)) - (not (or (key-press-event-p event) - (button-press-event-p event) - (button-release-event-p event) - (menu-event-p event)))) - (let ((type (car-safe event))) - (cond ((eq type 'eval) - (funcall (nth 1 event) (nth 2 event))) - ((eq type 'switch-frame) - (select-frame (nth 1 event)))))) - event)) - -(defun process-event-p (obj) - "True if the argument is a process-output event object. -GNU Emacs 19 does not currently generate process-output events." - (eq (car-safe obj) 'process)) - -(provide 'levents) - -;;; levents.el ends here diff --git a/lisp/obsolete/lmenu.el b/lisp/obsolete/lmenu.el deleted file mode 100644 index 678481924b2..00000000000 --- a/lisp/obsolete/lmenu.el +++ /dev/null @@ -1,445 +0,0 @@ -;;; lmenu.el --- emulate Lucid's menubar support - -;; Copyright (C) 1992-1994, 1997, 2001-2020 Free Software Foundation, -;; Inc. - -;; Keywords: emulations obsolete -;; Obsolete-since: 23.3 - -;; 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 has been obsolete since Emacs 23.3. - -;;; Code: - - -;; First, emulate the Lucid menubar support in GNU Emacs 19. - -;; Arrange to use current-menubar to set up part of the menu bar. - -(defvar current-menubar) -(defvar lucid-menubar-map) -(defvar lucid-failing-menubar) - -(defvar recompute-lucid-menubar 'recompute-lucid-menubar) -(defun recompute-lucid-menubar () - (define-key lucid-menubar-map [menu-bar] - (condition-case nil - (make-lucid-menu-keymap "menu-bar" current-menubar) - (error (message "Invalid data in current-menubar moved to lucid-failing-menubar") - (sit-for 1) - (setq lucid-failing-menubar current-menubar - current-menubar nil)))) - (setq lucid-menu-bar-dirty-flag nil)) - -(defvar lucid-menubar-map (make-sparse-keymap)) -(or (assq 'current-menubar minor-mode-map-alist) - (setq minor-mode-map-alist - (cons (cons 'current-menubar lucid-menubar-map) - minor-mode-map-alist))) - -;; XEmacs compatibility -(defun set-menubar-dirty-flag () - (force-mode-line-update) - (setq lucid-menu-bar-dirty-flag t)) - -(defvar add-menu-item-count 0) - -;; This is a variable whose value is always nil. -(defvar make-lucid-menu-keymap-disable nil) - -;; Return a menu keymap corresponding to a Lucid-style menu list -;; MENU-ITEMS, and with name MENU-NAME. -(defun make-lucid-menu-keymap (menu-name menu-items) - (let ((menu (make-sparse-keymap menu-name))) - ;; Process items in reverse order, - ;; since the define-key loop reverses them again. - (setq menu-items (reverse menu-items)) - (while menu-items - (let ((item (car menu-items)) - command name callback) - (cond ((stringp item) - (setq command nil) - (setq name (if (string-match "^-+$" item) "" item))) - ((consp item) - (setq command (make-lucid-menu-keymap (car item) (cdr item))) - (setq name (car item))) - ((vectorp item) - (setq command (make-symbol (format "menu-function-%d" - add-menu-item-count)) - add-menu-item-count (1+ add-menu-item-count) - name (aref item 0) - callback (aref item 1)) - (if (symbolp callback) - (fset command callback) - (fset command (list 'lambda () '(interactive) callback))) - (put command 'menu-alias t) - (let ((i 2)) - (while (< i (length item)) - (cond - ((eq (aref item i) ':active) - (put command 'menu-enable - (or (aref item (1+ i)) - 'make-lucid-menu-keymap-disable)) - (setq i (+ 2 i))) - ((eq (aref item i) ':suffix) - ;; unimplemented - (setq i (+ 2 i))) - ((eq (aref item i) ':keys) - ;; unimplemented - (setq i (+ 2 i))) - ((eq (aref item i) ':style) - ;; unimplemented - (setq i (+ 2 i))) - ((eq (aref item i) ':selected) - ;; unimplemented - (setq i (+ 2 i))) - ((and (symbolp (aref item i)) - (= ?: (string-to-char (symbol-name (aref item i))))) - (error "Unrecognized menu item keyword: %S" - (aref item i))) - ((= i 2) - ;; old-style format: active-p &optional suffix - (put command 'menu-enable - (or (aref item i) 'make-lucid-menu-keymap-disable)) - ;; suffix is unimplemented - (setq i (length item))) - (t - (error "Unexpected menu item value: %S" - (aref item i)))))))) - (if (null command) - ;; Handle inactive strings specially--allow any number - ;; of identical ones. - (setcdr menu (cons (list nil name) (cdr menu))) - (if name - (define-key menu (vector (intern name)) (cons name command))))) - (setq menu-items (cdr menu-items))) - menu)) - -(declare-function x-popup-dialog "menu.c" (position contents &optional header)) - -;; XEmacs compatibility function -(defun popup-dialog-box (data) - "Pop up a dialog box. -A dialog box description is a list. - - - The first element of the list is a string to display in the dialog box. - - The rest of the elements are descriptions of the dialog box's buttons. - Each one is a vector of three elements: - - The first element is the text of the button. - - The second element is the `callback'. - - The third element is t or nil, whether this button is selectable. - -If the `callback' of a button is a symbol, then it must name a command. -It will be invoked with `call-interactively'. If it is a list, then it is -evaluated with `eval'. - -One (and only one) of the buttons may be nil. This marker means that all -following buttons should be flushright instead of flushleft. - -The syntax, more precisely: - - form := <something to pass to `eval'> - command := <a symbol or string, to pass to `call-interactively'> - callback := command | form - active-p := <t, nil, or a form to evaluate to decide whether this - button should be selectable> - name := <string> - partition := `nil' - button := `[' name callback active-p `]' - dialog := `(' name [ button ]+ [ partition [ button ]+ ] `)'" - (let ((name (car data)) - (tail (cdr data)) - converted - choice meaning) - (while tail - (if (null (car tail)) - (setq converted (cons nil converted)) - (let ((item (aref (car tail) 0)) - (callback (aref (car tail) 1)) - (enable (aref (car tail) 2))) - (setq converted - (cons (if enable (cons item callback) item) - converted)))) - (setq tail (cdr tail))) - (setq choice (x-popup-dialog t (cons name (nreverse converted)))) - (if choice - (if (symbolp choice) - (call-interactively choice) - (eval choice))))) - -;; This is empty because the usual elements of the menu bar -;; are provided by menu-bar.el instead. -;; It would not make sense to duplicate them here. -(defconst default-menubar nil) - -;; XEmacs compatibility -(defun set-menubar (menubar) - "Set the default menubar to be menubar." - (setq-default current-menubar (copy-sequence menubar)) - (set-menubar-dirty-flag)) - -;; XEmacs compatibility -(defun set-buffer-menubar (menubar) - "Set the buffer-local menubar to be menubar." - (make-local-variable 'current-menubar) - (setq current-menubar (copy-sequence menubar)) - (set-menubar-dirty-flag)) - - -;;; menu manipulation functions - -;; XEmacs compatibility -(defun find-menu-item (menubar item-path-list &optional parent) - "Searches MENUBAR for item given by ITEM-PATH-LIST. -Returns (ITEM . PARENT), where PARENT is the immediate parent of - the item found. -Signals an error if the item is not found." - (or parent (setq item-path-list (mapcar 'downcase item-path-list))) - (if (not (consp menubar)) - nil - (let ((rest menubar) - result) - (while rest - (if (and (car rest) - (equal (car item-path-list) - (downcase (if (vectorp (car rest)) - (aref (car rest) 0) - (if (stringp (car rest)) - (car rest) - (car (car rest))))))) - (setq result (car rest) rest nil) - (setq rest (cdr rest)))) - (if (cdr item-path-list) - (if (consp result) - (find-menu-item (cdr result) (cdr item-path-list) result) - (if result - (signal 'error (list "not a submenu" result)) - (signal 'error (list "no such submenu" (car item-path-list))))) - (cons result parent))))) - - -;; XEmacs compatibility -(defun disable-menu-item (path) - "Make the named menu item be unselectable. -PATH is a list of strings which identify the position of the menu item in -the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" -under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the -menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"." - (let* ((menubar current-menubar) - (pair (find-menu-item menubar path)) - (item (car pair)) - (menu (cdr pair))) - (or item - (signal 'error (list (if menu "No such menu item" "No such menu") - path))) - (if (consp item) (error "can't disable menus, only menu items")) - (aset item 2 nil) - (set-menubar-dirty-flag) - item)) - - -;; XEmacs compatibility -(defun enable-menu-item (path) - "Make the named menu item be selectable. -PATH is a list of strings which identify the position of the menu item in -the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" -under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the -menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"." - (let* ((menubar current-menubar) - (pair (find-menu-item menubar path)) - (item (car pair)) - (menu (cdr pair))) - (or item - (signal 'error (list (if menu "No such menu item" "No such menu") - path))) - (if (consp item) (error "%S is a menu, not a menu item" path)) - (aset item 2 t) - (set-menubar-dirty-flag) - item)) - - -(defun add-menu-item-1 (item-p menu-path item-name item-data enabled-p before) - (if before (setq before (downcase before))) - (let* ((menubar current-menubar) - (menu (condition-case () - (car (find-menu-item menubar menu-path)) - (error nil))) - (item (if (listp menu) - (car (find-menu-item (cdr menu) (list item-name))) - (signal 'error (list "not a submenu" menu-path))))) - (or menu - (let ((rest menu-path) - (so-far menubar)) - (while rest -;;; (setq menu (car (find-menu-item (cdr so-far) (list (car rest))))) - (setq menu - (if (eq so-far menubar) - (car (find-menu-item so-far (list (car rest)))) - (car (find-menu-item (cdr so-far) (list (car rest)))))) - (or menu - (let ((rest2 so-far)) - (or rest2 - (error "Trying to modify a menu that doesn't exist")) - (while (and (cdr rest2) (car (cdr rest2))) - (setq rest2 (cdr rest2))) - (setcdr rest2 - (nconc (list (setq menu (list (car rest)))) - (cdr rest2))))) - (setq so-far menu) - (setq rest (cdr rest))))) - (or menu (setq menu menubar)) - (if item - nil ; it's already there - (if item-p - (setq item (vector item-name item-data enabled-p)) - (setq item (cons item-name item-data))) - ;; if BEFORE is specified, try to add it there. - (if before - (setq before (car (find-menu-item menu (list before))))) - (let ((rest menu) - (added-before nil)) - (while rest - (if (eq before (car (cdr rest))) - (progn - (setcdr rest (cons item (cdr rest))) - (setq rest nil added-before t)) - (setq rest (cdr rest)))) - (if (not added-before) - ;; adding before the first item on the menubar itself is harder - (if (and (eq menu menubar) (eq before (car menu))) - (setq menu (cons item menu) - current-menubar menu) - ;; otherwise, add the item to the end. - (nconc menu (list item)))))) - (if item-p - (progn - (aset item 1 item-data) - (aset item 2 (not (null enabled-p)))) - (setcar item item-name) - (setcdr item item-data)) - (set-menubar-dirty-flag) - item)) - -;; XEmacs compatibility -(defun add-menu-item (menu-path item-name function enabled-p &optional before) - "Add a menu item to some menu, creating the menu first if necessary. -If the named item exists already, it is changed. -MENU-PATH identifies the menu under which the new menu item should be inserted. - It is a list of strings; for example, (\"File\") names the top-level \"File\" - menu. (\"File\" \"Foo\") names a hypothetical submenu of \"File\". -ITEM-NAME is the string naming the menu item to be added. -FUNCTION is the command to invoke when this menu item is selected. - If it is a symbol, then it is invoked with `call-interactively', in the same - way that functions bound to keys are invoked. If it is a list, then the - list is simply evaluated. -ENABLED-P controls whether the item is selectable or not. -BEFORE, if provided, is the name of a menu item before which this item should - be added, if this item is not on the menu already. If the item is already - present, it will not be moved." - (or menu-path (error "must specify a menu path")) - (or item-name (error "must specify an item name")) - (add-menu-item-1 t menu-path item-name function enabled-p before)) - - -;; XEmacs compatibility -(defun delete-menu-item (path) - "Remove the named menu item from the menu hierarchy. -PATH is a list of strings which identify the position of the menu item in -the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" -under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the -menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"." - (let* ((menubar current-menubar) - (pair (find-menu-item menubar path)) - (item (car pair)) - (menu (or (cdr pair) menubar))) - (if (not item) - nil - ;; the menubar is the only special case, because other menus begin - ;; with their name. - (if (eq menu current-menubar) - (setq current-menubar (delq item menu)) - (delq item menu)) - (set-menubar-dirty-flag) - item))) - - -;; XEmacs compatibility -(defun relabel-menu-item (path new-name) - "Change the string of the specified menu item. -PATH is a list of strings which identify the position of the menu item in -the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" -under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the -menu item called \"Item\" under the \"Foo\" submenu of \"Menu\". -NEW-NAME is the string that the menu item will be printed as from now on." - (or (stringp new-name) - (setq new-name (signal 'wrong-type-argument (list 'stringp new-name)))) - (let* ((menubar current-menubar) - (pair (find-menu-item menubar path)) - (item (car pair)) - (menu (cdr pair))) - (or item - (signal 'error (list (if menu "No such menu item" "No such menu") - path))) - (if (and (consp item) - (stringp (car item))) - (setcar item new-name) - (aset item 0 new-name)) - (set-menubar-dirty-flag) - item)) - -;; XEmacs compatibility -(defun add-menu (menu-path menu-name menu-items &optional before) - "Add a menu to the menubar or one of its submenus. -If the named menu exists already, it is changed. -MENU-PATH identifies the menu under which the new menu should be inserted. - It is a list of strings; for example, (\"File\") names the top-level \"File\" - menu. (\"File\" \"Foo\") names a hypothetical submenu of \"File\". - If MENU-PATH is nil, then the menu will be added to the menubar itself. -MENU-NAME is the string naming the menu to be added. -MENU-ITEMS is a list of menu item descriptions. - Each menu item should be a vector of three elements: - - a string, the name of the menu item; - - a symbol naming a command, or a form to evaluate; - - and a form whose value determines whether this item is selectable. -BEFORE, if provided, is the name of a menu before which this menu should - be added, if this menu is not on its parent already. If the menu is already - present, it will not be moved." - (or menu-name (error "must specify a menu name")) - (or menu-items (error "must specify some menu items")) - (add-menu-item-1 nil menu-path menu-name menu-items t before)) - - - -(defvar put-buffer-names-in-file-menu t) - - -;; Don't unconditionally enable menu bars; leave that up to the user. -;;(let ((frames (frame-list))) -;; (while frames -;; (modify-frame-parameters (car frames) '((menu-bar-lines . 1))) -;; (setq frames (cdr frames)))) -;;(or (assq 'menu-bar-lines default-frame-alist) -;; (setq default-frame-alist -;; (cons '(menu-bar-lines . 1) default-frame-alist))) - -(set-menubar default-menubar) - -(provide 'lmenu) - -;;; lmenu.el ends here diff --git a/lisp/obsolete/longlines.el b/lisp/obsolete/longlines.el index 2fba49f402d..cbe453aa6bf 100644 --- a/lisp/obsolete/longlines.el +++ b/lisp/obsolete/longlines.el @@ -37,6 +37,7 @@ ;; Special thanks to Rod Smith for many useful bug reports. ;;; Code: +;;; Options (defgroup longlines nil "Automatic wrapping of long lines when loading files." @@ -76,7 +77,7 @@ This is used when `longlines-show-hard-newlines' is on." :group 'longlines :type 'string) -;; Internal variables +;;; Internal variables (defvar longlines-wrap-beg nil) (defvar longlines-wrap-end nil) @@ -90,7 +91,7 @@ This is used when `longlines-show-hard-newlines' is on." (make-variable-buffer-local 'longlines-showing) (make-variable-buffer-local 'longlines-decoded) -;; Mode +;;; Mode (defvar message-indent-citation-function) @@ -210,7 +211,7 @@ This function exists to be called by `change-major-mode-hook' when the major mode changes." (longlines-mode 0)) -;; Showing the effect of hard newlines in the buffer +;;; Showing the effect of hard newlines in the buffer (defun longlines-show-hard-newlines (&optional arg) "Make hard newlines visible by adding a face. @@ -252,7 +253,7 @@ With optional argument ARG, make the hard newlines invisible again." (setq pos (text-property-not-all (1+ pos) (point-max) 'hard nil))) (restore-buffer-modified-p mod))) -;; Wrapping the paragraphs. +;;; Wrapping the paragraphs (defun longlines-wrap-region (beg end) "Wrap each successive line, starting with the line before BEG. @@ -402,7 +403,7 @@ Hard newlines are left intact." (setq pos (string-match "\n" str (1+ pos)))) str)) -;; Auto wrap +;;; Auto wrap (defun longlines-auto-wrap (&optional arg) "Toggle automatic line wrapping. @@ -457,7 +458,7 @@ This is called by `window-configuration-change-hook'." (setq fill-column (- (window-width) dw)) (longlines-wrap-region (point-min) (point-max))))) -;; Isearch +;;; Isearch (defun longlines-search-function () (cond @@ -477,7 +478,7 @@ This is called by `window-configuration-change-hook'." (let ((search-spaces-regexp " *[ \n]")) (re-search-forward string bound noerror count))) -;; Loading and saving +;;; Loading and saving (defun longlines-before-revert-hook () (add-hook 'after-revert-hook 'longlines-after-revert-hook nil t) @@ -492,7 +493,7 @@ This is called by `window-configuration-change-hook'." (list 'longlines "Automatically wrap long lines." nil nil 'longlines-encode-region t nil)) -;; Unloading +;;; Unloading (defun longlines-unload-function () "Unload the longlines library." diff --git a/lisp/obsolete/lucid.el b/lisp/obsolete/lucid.el deleted file mode 100644 index 817cc9cfaaa..00000000000 --- a/lisp/obsolete/lucid.el +++ /dev/null @@ -1,211 +0,0 @@ -;;; lucid.el --- emulate some Lucid Emacs functions - -;; Copyright (C) 1993, 1995, 2001-2020 Free Software Foundation, Inc. - -;; Maintainer: emacs-devel@gnu.org -;; Keywords: emulations -;; Obsolete-since: 23.2 - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;;; Code: - -;; XEmacs autoloads CL so we might as well make use of it. -(require 'cl) - -(defalias 'current-time-seconds 'current-time) - -(defun real-path-name (name &optional default) - (file-truename (expand-file-name name default))) - -;; It's not clear what to return if the mouse is not in FRAME. -(defun read-mouse-position (frame) - (let ((pos (mouse-position))) - (if (eq (car pos) frame) - (cdr pos)))) - -(defun switch-to-other-buffer (arg) - "Switch to the previous buffer. -With a numeric arg N, switch to the Nth most recent buffer. -With an arg of 0, buries the current buffer at the -bottom of the buffer stack." - (interactive "p") - (if (eq arg 0) - (bury-buffer (current-buffer))) - (switch-to-buffer - (if (<= arg 1) (other-buffer (current-buffer)) - (nth arg - (apply 'nconc - (mapcar - (lambda (buf) - (if (= ?\ (string-to-char (buffer-name buf))) - nil - (list buf))) - (buffer-list))))))) - -(defun device-class (&optional device) - "Return the class (color behavior) of DEVICE. -This will be one of `color', `grayscale', or `mono'. -This function exists for compatibility with XEmacs." - (cond - ((display-color-p device) 'color) - ((display-grayscale-p device) 'grayscale) - (t 'mono))) - -(defalias 'find-face 'facep) -(defalias 'get-face 'facep) -;; internal-try-face-font was removed from faces.el in rev 1.139, 1999/07/21. -;;;(defalias 'try-face-font 'internal-try-face-font) - -(defalias 'exec-to-string 'shell-command-to-string) - - -;; Buffer context - -(defun buffer-syntactic-context (&optional buffer) - "Syntactic context at point in BUFFER. -Either of `string', `comment' or nil. -This is an XEmacs compatibility function." - (with-current-buffer (or buffer (current-buffer)) - (let ((state (syntax-ppss (point)))) - (cond - ((nth 3 state) 'string) - ((nth 4 state) 'comment))))) - - -(defun buffer-syntactic-context-depth (&optional buffer) - "Syntactic parenthesis depth at point in BUFFER. -This is an XEmacs compatibility function." - (with-current-buffer (or buffer (current-buffer)) - (nth 0 (syntax-ppss (point))))) - - -;; Extents -(defun make-extent (beg end &optional buffer) - (make-overlay beg end buffer)) - -(defun extent-properties (extent) (overlay-properties extent)) -(unless (fboundp 'extent-property) (defalias 'extent-property 'overlay-get)) - -(defun extent-at (pos &optional object property before) - (with-current-buffer (or object (current-buffer)) - (let ((overlays (overlays-at pos 'sorted))) - (when property - (let (filtered) - (while overlays - (if (overlay-get (car overlays) property) - (setq filtered (cons (car overlays) filtered))) - (setq overlays (cdr overlays))) - (setq overlays filtered))) - (if before - (nth 1 (memq before overlays)) - (car overlays))))) - -(defun set-extent-property (extent prop value) - ;; Make sure that separate adjacent extents - ;; with the same mouse-face value - ;; do not run together as one extent. - (and (eq prop 'mouse-face) - (symbolp value) - (setq value (list value))) - (if (eq prop 'duplicable) - (cond ((and value (not (overlay-get extent prop))) - ;; If becoming duplicable, copy all overlayprops to text props. - (add-text-properties (overlay-start extent) - (overlay-end extent) - (overlay-properties extent) - (overlay-buffer extent))) - ;; If becoming no longer duplicable, remove these text props. - ((and (not value) (overlay-get extent prop)) - (remove-text-properties (overlay-start extent) - (overlay-end extent) - (overlay-properties extent) - (overlay-buffer extent)))) - ;; If extent is already duplicable, put this property - ;; on the text as well as on the overlay. - (if (overlay-get extent 'duplicable) - (put-text-property (overlay-start extent) - (overlay-end extent) - prop value (overlay-buffer extent)))) - (overlay-put extent prop value)) - -(defun set-extent-face (extent face) - (set-extent-property extent 'face face)) - -(defun set-extent-end-glyph (extent glyph) - (set-extent-property extent 'after-string glyph)) - -(defun delete-extent (extent) - (set-extent-property extent 'duplicable nil) - (delete-overlay extent)) - -;; Support the Lucid names with `screen' instead of `frame'. - -(defalias 'current-screen-configuration 'current-frame-configuration) -(defalias 'delete-screen 'delete-frame) -(defalias 'find-file-new-screen 'find-file-other-frame) -(defalias 'find-file-read-only-new-screen 'find-file-read-only-other-frame) -(defalias 'find-tag-new-screen 'find-tag-other-frame) -;;(defalias 'focus-screen 'focus-frame) -(defalias 'iconify-screen 'iconify-frame) -(defalias 'mail-new-screen 'mail-other-frame) -(defalias 'make-screen-invisible 'make-frame-invisible) -(defalias 'make-screen-visible 'make-frame-visible) -;; (defalias 'minibuffer-screen-list 'minibuffer-frame-list) -(defalias 'modify-screen-parameters 'modify-frame-parameters) -(defalias 'next-screen 'next-frame) -;; (defalias 'next-multiscreen-window 'next-multiframe-window) -;; (defalias 'previous-multiscreen-window 'previous-multiframe-window) -;; (defalias 'redirect-screen-focus 'redirect-frame-focus) -(defalias 'redraw-screen 'redraw-frame) -;; (defalias 'screen-char-height 'frame-char-height) -;; (defalias 'screen-char-width 'frame-char-width) -;; (defalias 'screen-configuration-to-register 'frame-configuration-to-register) -;; (defalias 'screen-focus 'frame-focus) -(defalias 'screen-list 'frame-list) -;; (defalias 'screen-live-p 'frame-live-p) -(defalias 'screen-parameters 'frame-parameters) -(defalias 'screen-pixel-height 'frame-pixel-height) -(defalias 'screen-pixel-width 'frame-pixel-width) -(defalias 'screen-root-window 'frame-root-window) -(defalias 'screen-selected-window 'frame-selected-window) -(defalias 'lower-screen 'lower-frame) -(defalias 'raise-screen 'raise-frame) -(defalias 'screen-visible-p 'frame-visible-p) -(defalias 'screenp 'framep) -(defalias 'select-screen 'select-frame) -(defalias 'selected-screen 'selected-frame) -;; (defalias 'set-screen-configuration 'set-frame-configuration) -;; (defalias 'set-screen-height 'set-frame-height) -(defalias 'set-screen-position 'set-frame-position) -(defalias 'set-screen-size 'set-frame-size) -;; (defalias 'set-screen-width 'set-frame-width) -(defalias 'switch-to-buffer-new-screen 'switch-to-buffer-other-frame) -;; (defalias 'unfocus-screen 'unfocus-frame) -(defalias 'visible-screen-list 'visible-frame-list) -(defalias 'window-screen 'window-frame) -(defalias 'x-create-screen 'x-create-frame) -(defalias 'x-new-screen 'make-frame) - -(provide 'lucid) - -;; Local Variables: -;; byte-compile-warnings: (not cl-functions) -;; End: - -;;; lucid.el ends here diff --git a/lisp/mail/metamail.el b/lisp/obsolete/metamail.el index 0e407ea060e..d6ab4a3d0cf 100644 --- a/lisp/mail/metamail.el +++ b/lisp/obsolete/metamail.el @@ -4,6 +4,7 @@ ;; Author: Masanobu UMEDA <umerin@mse.kyutech.ac.jp> ;; Keywords: mail, news, mime, multimedia +;; Obsolete-since: 28.1 ;; This file is part of GNU Emacs. diff --git a/lisp/obsolete/old-whitespace.el b/lisp/obsolete/old-whitespace.el deleted file mode 100644 index 95010c00200..00000000000 --- a/lisp/obsolete/old-whitespace.el +++ /dev/null @@ -1,801 +0,0 @@ -;;; whitespace.el --- warn about and clean bogus whitespaces in the file - -;; Copyright (C) 1999-2020 Free Software Foundation, Inc. - -;; Author: Rajesh Vaidheeswarran <rv@gnu.org> -;; Keywords: convenience -;; Obsolete-since: 23.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: - -;; URL: http://www.dsmit.com/lisp/ -;; -;; The whitespace library is intended to find and help fix five different types -;; of whitespace problems that commonly exist in source code. -;; -;; 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 at beginning of line, 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. -;; -;; Whitespace errors are reported in a buffer, and on the mode line. -;; -;; Mode line will show a W:<x>!<y> to denote a particular type of whitespace, -;; where `x' and `y' can be one (or more) of: -;; -;; e - End-of-Line whitespace. -;; i - Indentation whitespace. -;; l - Leading whitespace. -;; s - Space followed by Tab. -;; t - Trailing whitespace. -;; -;; If any of the whitespace checks is turned off, the mode line will display a -;; !<y>. -;; -;; (since (3) is the most controversial one, here is the rationale: Most -;; terminal drivers and printer drivers have TAB configured or even -;; hardcoded to be 8 spaces. (Some of them allow configuration, but almost -;; always they default to 8.) -;; -;; Changing `tab-width' to other than 8 and editing will cause your code to -;; look different from within Emacs, and say, if you cat it or more it, or -;; even print it. -;; -;; Almost all the popular programming modes let you define an offset (like -;; c-basic-offset or perl-indent-level) to configure the offset, so you -;; should never have to set your `tab-width' to be other than 8 in all -;; these modes. In fact, with an indent level of say, 4, 2 TABS will cause -;; Emacs to replace your 8 spaces with one \t (try it). If vi users in -;; your office complain, tell them to use vim, which distinguishes between -;; tabstop and shiftwidth (vi equivalent of our offsets), and also ask them -;; to set smarttab.) -;; -;; All the above have caused (and will cause) unwanted codeline integration and -;; merge problems. -;; -;; whitespace.el will complain if it detects whitespaces on opening a file, and -;; warn you on closing a file also (in case you had inserted any -;; whitespaces during the process of your editing). -;; -;; Exported functions: -;; -;; `whitespace-buffer' - To check the current buffer for whitespace problems. -;; `whitespace-cleanup' - To cleanup all whitespaces in the current buffer. -;; `whitespace-region' - To check between point and mark for whitespace -;; problems. -;; `whitespace-cleanup-region' - To cleanup all whitespaces between point -;; and mark in the current buffer. - -;;; Code: - -(defvar whitespace-version "3.5" "Version of the whitespace library.") - -(defvar whitespace-all-buffer-files nil - "An associated list of buffers and files checked for whitespace cleanliness. - -This is to enable periodic checking of whitespace cleanliness in the files -visited by the buffers.") - -(defvar whitespace-rescan-timer nil - "Timer object used to rescan the files in buffers that have been modified.") - -;; Tell Emacs about this new kind of minor mode -(defvar whitespace-mode nil - "Non-nil when Whitespace mode (a minor mode) is enabled.") -(make-variable-buffer-local 'whitespace-mode) - -(defvar whitespace-mode-line nil - "String to display in the mode line for Whitespace mode.") -(make-variable-buffer-local 'whitespace-mode-line) - -(defvar whitespace-check-buffer-leading nil - "Test leading whitespace for file in current buffer if t.") -(make-variable-buffer-local 'whitespace-check-buffer-leading) -;;;###autoload(put 'whitespace-check-buffer-leading 'safe-local-variable 'booleanp) - -(defvar whitespace-check-buffer-trailing nil - "Test trailing whitespace for file in current buffer if t.") -(make-variable-buffer-local 'whitespace-check-buffer-trailing) -;;;###autoload(put 'whitespace-check-buffer-trailing 'safe-local-variable 'booleanp) - -(defvar whitespace-check-buffer-indent nil - "Test indentation whitespace for file in current buffer if t.") -(make-variable-buffer-local 'whitespace-check-buffer-indent) -;;;###autoload(put 'whitespace-check-buffer-indent 'safe-local-variable 'booleanp) - -(defvar whitespace-check-buffer-spacetab nil - "Test Space-followed-by-TABS whitespace for file in current buffer if t.") -(make-variable-buffer-local 'whitespace-check-buffer-spacetab) -;;;###autoload(put 'whitespace-check-buffer-spacetab 'safe-local-variable 'booleanp) - -(defvar whitespace-check-buffer-ateol nil - "Test end-of-line whitespace for file in current buffer if t.") -(make-variable-buffer-local 'whitespace-check-buffer-ateol) -;;;###autoload(put 'whitespace-check-buffer-ateol 'safe-local-variable 'booleanp) - -(defvar whitespace-highlighted-space nil - "The variable to store the extent to highlight.") -(make-variable-buffer-local 'whitespace-highlighted-space) - -(defalias 'whitespace-make-overlay - (if (featurep 'xemacs) 'make-extent 'make-overlay)) -(defalias 'whitespace-overlay-put - (if (featurep 'xemacs) 'set-extent-property 'overlay-put)) -(defalias 'whitespace-delete-overlay - (if (featurep 'xemacs) 'delete-extent 'delete-overlay)) -(defalias 'whitespace-overlay-start - (if (featurep 'xemacs) 'extent-start 'overlay-start)) -(defalias 'whitespace-overlay-end - (if (featurep 'xemacs) 'extent-end 'overlay-end)) -(defalias 'whitespace-mode-line-update - (if (featurep 'xemacs) 'redraw-modeline 'force-mode-line-update)) - -(defgroup whitespace nil - "Check for and fix five different types of whitespaces in source code." - :version "21.1" - :link '(emacs-commentary-link "whitespace.el") - ;; Since XEmacs doesn't have a 'convenience group, use the next best group - ;; which is 'editing? - :group (if (featurep 'xemacs) 'editing 'convenience)) - -(defcustom whitespace-check-leading-whitespace t - "Flag to check leading whitespace. This is the global for the system. -It can be overridden by setting a buffer local variable -`whitespace-check-buffer-leading'." - :type 'boolean - :group 'whitespace) - -(defcustom whitespace-check-trailing-whitespace t - "Flag to check trailing whitespace. This is the global for the system. -It can be overridden by setting a buffer local variable -`whitespace-check-buffer-trailing'." - :type 'boolean - :group 'whitespace) - -(defcustom whitespace-check-spacetab-whitespace t - "Flag to check space followed by a TAB. This is the global for the system. -It can be overridden by setting a buffer local variable -`whitespace-check-buffer-spacetab'." - :type 'boolean - :group 'whitespace) - -(defcustom whitespace-spacetab-regexp "[ ]+\t" - "Regexp to match one or more spaces followed by a TAB." - :type 'regexp - :group 'whitespace) - -(defcustom whitespace-check-indent-whitespace indent-tabs-mode - "Flag to check indentation whitespace. This is the global for the system. -It can be overridden by setting a buffer local variable -`whitespace-check-buffer-indent'." - :type 'boolean - :group 'whitespace) - -(defcustom whitespace-indent-regexp "^\t*\\( \\)+" - "Regexp to match multiples of eight spaces near line beginnings. -The default value ignores leading TABs." - :type 'regexp - :group 'whitespace) - -(defcustom whitespace-check-ateol-whitespace t - "Flag to check end-of-line whitespace. This is the global for the system. -It can be overridden by setting a buffer local variable -`whitespace-check-buffer-ateol'." - :type 'boolean - :group 'whitespace) - -(defcustom whitespace-ateol-regexp "[ \t]+$" - "Regexp to match one or more TABs or spaces at line ends." - :type 'regexp - :group 'whitespace) - -(defcustom whitespace-errbuf "*Whitespace Errors*" - "The name of the buffer where whitespace related messages will be logged." - :type 'string - :group 'whitespace) - -(defcustom whitespace-clean-msg "clean." - "If non-nil, this message will be displayed after a whitespace check -determines a file to be clean." - :type 'string - :group 'whitespace) - -(defcustom whitespace-abort-on-error nil - "While writing a file, abort if the file is unclean. -If `whitespace-auto-cleanup' is set, that takes precedence over -this variable." - :type 'boolean - :group 'whitespace) - -(defcustom whitespace-auto-cleanup nil - "Cleanup a buffer automatically on finding it whitespace unclean." - :type 'boolean - :group 'whitespace) - -(defcustom whitespace-silent nil - "All whitespace errors will be shown only in the mode line when t. - -Note that setting this may cause all whitespaces introduced in a file to go -unnoticed when the buffer is killed, unless the user visits the `*Whitespace -Errors*' buffer before opening (or closing) another file." - :type 'boolean - :group 'whitespace) - -(defcustom whitespace-modes '(ada-mode asm-mode autoconf-mode awk-mode - c-mode c++-mode cc-mode - change-log-mode cperl-mode - electric-nroff-mode emacs-lisp-mode - f90-mode fortran-mode html-mode - html3-mode java-mode jde-mode - ksh-mode latex-mode LaTeX-mode - lisp-mode m4-mode makefile-mode - modula-2-mode nroff-mode objc-mode - pascal-mode perl-mode prolog-mode - python-mode scheme-mode sgml-mode - sh-mode shell-script-mode simula-mode - tcl-mode tex-mode texinfo-mode - vrml-mode xml-mode) - - "Major modes in which we turn on whitespace checking. - -These are mostly programming and documentation modes. But you may add other -modes that you want whitespaces checked in by adding something like the -following to your `.emacs': - -\(setq whitespace-modes (cons \\='my-mode (cons \\='my-other-mode - whitespace-modes))\) - -Or, alternately, you can use the Emacs `customize' command to set this." - :type '(repeat symbol) - :group 'whitespace) - -(defcustom whitespace-rescan-timer-time 600 - "Period in seconds to rescan modified buffers for whitespace creep. - -This is the period after which the timer will fire causing -`whitespace-rescan-files-in-buffers' to check for whitespace creep in -modified buffers. - -To disable timer scans, set this to zero." - :type 'integer - :group 'whitespace) - -(defcustom whitespace-display-in-modeline t - "Display whitespace errors on the modeline." - :type 'boolean - :group 'whitespace) - -(defcustom whitespace-display-spaces-in-color t - "Display the bogus whitespaces by coloring them with the face -`whitespace-highlight'." - :type 'boolean - :group 'whitespace) - -(defface whitespace-highlight '((((class color) (background light)) - (:background "green1")) - (((class color) (background dark)) - (:background "sea green")) - (((class grayscale mono) - (background light)) - (:background "black")) - (((class grayscale mono) - (background dark)) - (:background "white"))) - "Face used for highlighting the bogus whitespaces that exist in the buffer." - :group 'whitespace) - -(if (not (assoc 'whitespace-mode minor-mode-alist)) - (setq minor-mode-alist (cons '(whitespace-mode whitespace-mode-line) - minor-mode-alist))) - -(set-default 'whitespace-check-buffer-leading - whitespace-check-leading-whitespace) -(set-default 'whitespace-check-buffer-trailing - whitespace-check-trailing-whitespace) -(set-default 'whitespace-check-buffer-indent - whitespace-check-indent-whitespace) -(set-default 'whitespace-check-buffer-spacetab - whitespace-check-spacetab-whitespace) -(set-default 'whitespace-check-buffer-ateol - whitespace-check-ateol-whitespace) - -(defun whitespace-check-whitespace-mode (&optional arg) - "Test and set the whitespace-mode in qualifying buffers." - (if (null whitespace-mode) - (setq whitespace-mode - (if (or arg (member major-mode whitespace-modes)) - t - nil)))) - -;;;###autoload -(defun whitespace-toggle-leading-check () - "Toggle the check for leading space in the local buffer." - (interactive) - (let ((current-val whitespace-check-buffer-leading)) - (setq whitespace-check-buffer-leading (not current-val)) - (message "Will%s check for leading space in buffer." - (if whitespace-check-buffer-leading "" " not")) - (if whitespace-check-buffer-leading (whitespace-buffer-leading)))) - -;;;###autoload -(defun whitespace-toggle-trailing-check () - "Toggle the check for trailing space in the local buffer." - (interactive) - (let ((current-val whitespace-check-buffer-trailing)) - (setq whitespace-check-buffer-trailing (not current-val)) - (message "Will%s check for trailing space in buffer." - (if whitespace-check-buffer-trailing "" " not")) - (if whitespace-check-buffer-trailing (whitespace-buffer-trailing)))) - -;;;###autoload -(defun whitespace-toggle-indent-check () - "Toggle the check for indentation space in the local buffer." - (interactive) - (let ((current-val whitespace-check-buffer-indent)) - (setq whitespace-check-buffer-indent (not current-val)) - (message "Will%s check for indentation space in buffer." - (if whitespace-check-buffer-indent "" " not")) - (if whitespace-check-buffer-indent - (whitespace-buffer-search whitespace-indent-regexp)))) - -;;;###autoload -(defun whitespace-toggle-spacetab-check () - "Toggle the check for space-followed-by-TABs in the local buffer." - (interactive) - (let ((current-val whitespace-check-buffer-spacetab)) - (setq whitespace-check-buffer-spacetab (not current-val)) - (message "Will%s check for space-followed-by-TABs in buffer." - (if whitespace-check-buffer-spacetab "" " not")) - (if whitespace-check-buffer-spacetab - (whitespace-buffer-search whitespace-spacetab-regexp)))) - - -;;;###autoload -(defun whitespace-toggle-ateol-check () - "Toggle the check for end-of-line space in the local buffer." - (interactive) - (let ((current-val whitespace-check-buffer-ateol)) - (setq whitespace-check-buffer-ateol (not current-val)) - (message "Will%s check for end-of-line space in buffer." - (if whitespace-check-buffer-ateol "" " not")) - (if whitespace-check-buffer-ateol - (whitespace-buffer-search whitespace-ateol-regexp)))) - - -;;;###autoload -(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\). -5. Spaces or TABS at the end of a line. - -Check for whitespace only if this buffer really contains a non-empty file -and: -1. the major mode is one of the whitespace-modes, or -2. `whitespace-buffer' was explicitly called with a prefix argument." - (interactive) - (let ((whitespace-error nil)) - (whitespace-check-whitespace-mode current-prefix-arg) - (if (and buffer-file-name (> (buffer-size) 0) whitespace-mode) - (progn - (whitespace-check-buffer-list (buffer-name) buffer-file-name) - (whitespace-tickle-timer) - (overlay-recenter (point-max)) - (remove-overlays nil nil 'face 'whitespace-highlight) - (if whitespace-auto-cleanup - (if buffer-read-only - (if (not quiet) - (message "Can't cleanup: %s is read-only" (buffer-name))) - (whitespace-cleanup-internal)) - (let ((whitespace-leading (if whitespace-check-buffer-leading - (whitespace-buffer-leading) - nil)) - (whitespace-trailing (if whitespace-check-buffer-trailing - (whitespace-buffer-trailing) - nil)) - (whitespace-indent (if whitespace-check-buffer-indent - (whitespace-buffer-search - whitespace-indent-regexp) - nil)) - (whitespace-spacetab (if whitespace-check-buffer-spacetab - (whitespace-buffer-search - whitespace-spacetab-regexp) - nil)) - (whitespace-ateol (if whitespace-check-buffer-ateol - (whitespace-buffer-search - whitespace-ateol-regexp) - nil)) - (whitespace-errmsg nil) - (whitespace-filename buffer-file-name) - (whitespace-this-modeline "")) - - ;; Now let's complain if we found any of the above. - (setq whitespace-error (or whitespace-leading whitespace-indent - whitespace-spacetab whitespace-ateol - whitespace-trailing)) - - (if whitespace-error - (progn - (setq whitespace-errmsg - (concat whitespace-filename " contains:\n" - (if whitespace-leading - "Leading whitespace\n") - (if whitespace-indent - (concat "Indentation whitespace" - whitespace-indent "\n")) - (if whitespace-spacetab - (concat "Space followed by Tab" - whitespace-spacetab "\n")) - (if whitespace-ateol - (concat "End-of-line whitespace" - whitespace-ateol "\n")) - (if whitespace-trailing - "Trailing whitespace\n") - "\ntype `M-x whitespace-cleanup' to " - "cleanup the file.")) - (setq whitespace-this-modeline - (concat (if whitespace-ateol "e") - (if whitespace-indent "i") - (if whitespace-leading "l") - (if whitespace-spacetab "s") - (if whitespace-trailing "t"))))) - (whitespace-update-modeline whitespace-this-modeline) - (if (get-buffer whitespace-errbuf) - (kill-buffer whitespace-errbuf)) - (with-current-buffer (get-buffer-create whitespace-errbuf) - (if whitespace-errmsg - (progn - (insert whitespace-errmsg) - (if (not (or quiet whitespace-silent)) - (display-buffer (current-buffer) t)) - (if (not quiet) - (message "Whitespaces: [%s%s] in %s" - whitespace-this-modeline - (let ((whitespace-unchecked - (whitespace-unchecked-whitespaces))) - (if whitespace-unchecked - (concat "!" whitespace-unchecked) - "")) - whitespace-filename))) - (if (and (not quiet) (not (equal whitespace-clean-msg ""))) - (message "%s %s" whitespace-filename - whitespace-clean-msg)))))))) - whitespace-error)) - -;;;###autoload -(defun whitespace-region (s e) - "Check the region for whitespace errors." - (interactive "r") - (save-excursion - (save-restriction - (narrow-to-region s e) - (whitespace-buffer)))) - -;;;###autoload -(defun whitespace-cleanup () - "Cleanup the five different kinds of whitespace problems. -It normally applies to the whole buffer, but in Transient Mark mode -when the mark is active it applies to the region. -See `whitespace-buffer' docstring for a summary of the problems." - (interactive) - (if (and transient-mark-mode mark-active) - (whitespace-cleanup-region (region-beginning) (region-end)) - (whitespace-cleanup-internal))) - -(defun whitespace-cleanup-internal (&optional region-only) - ;; If this buffer really contains a file, then run, else quit. - (whitespace-check-whitespace-mode current-prefix-arg) - (if (and buffer-file-name whitespace-mode) - (let ((whitespace-any nil) - (whitespace-tabwidth 8) - (whitespace-tabwidth-saved tab-width)) - - ;; since all printable TABS should be 8, irrespective of how - ;; they are displayed. - (setq tab-width whitespace-tabwidth) - - (if (and whitespace-check-buffer-leading - (whitespace-buffer-leading)) - (progn - (whitespace-buffer-leading-cleanup) - (setq whitespace-any t))) - - (if (and whitespace-check-buffer-trailing - (whitespace-buffer-trailing)) - (progn - (whitespace-buffer-trailing-cleanup) - (setq whitespace-any t))) - - (if (and whitespace-check-buffer-indent - (whitespace-buffer-search whitespace-indent-regexp)) - (progn - (whitespace-indent-cleanup) - (setq whitespace-any t))) - - (if (and whitespace-check-buffer-spacetab - (whitespace-buffer-search whitespace-spacetab-regexp)) - (progn - (whitespace-buffer-cleanup whitespace-spacetab-regexp "\t") - (setq whitespace-any t))) - - (if (and whitespace-check-buffer-ateol - (whitespace-buffer-search whitespace-ateol-regexp)) - (progn - (whitespace-buffer-cleanup whitespace-ateol-regexp "") - (setq whitespace-any t))) - - ;; Call this recursively till everything is taken care of - (if whitespace-any - (whitespace-cleanup-internal region-only) - ;; if we are done, talk to the user - (progn - (unless whitespace-silent - (if region-only - (message "The region is now clean") - (message "%s is now clean" buffer-file-name))) - (whitespace-update-modeline))) - (setq tab-width whitespace-tabwidth-saved)))) - -;;;###autoload -(defun whitespace-cleanup-region (s e) - "Whitespace cleanup on the region." - (interactive "r") - (save-excursion - (save-restriction - (narrow-to-region s e) - (whitespace-cleanup-internal t)) - (whitespace-buffer t))) - -(defun whitespace-buffer-leading () - "Return t if the current buffer has leading newline characters. -If highlighting is enabled, highlight these characters." - (save-excursion - (goto-char (point-min)) - (skip-chars-forward "\n") - (unless (bobp) - (whitespace-highlight-the-space (point-min) (point)) - t))) - -(defun whitespace-buffer-leading-cleanup () - "Remove any leading newline characters from current buffer." - (save-excursion - (goto-char (point-min)) - (skip-chars-forward "\n") - (delete-region (point-min) (point)))) - -(defun whitespace-buffer-trailing () - "Return t if the current buffer has extra trailing newline characters. -If highlighting is enabled, highlight these characters." - (save-excursion - (goto-char (point-max)) - (skip-chars-backward "\n") - (forward-line) - (unless (eobp) - (whitespace-highlight-the-space (point) (point-max)) - t))) - -(defun whitespace-buffer-trailing-cleanup () - "Remove extra trailing newline characters from current buffer." - (save-excursion - (goto-char (point-max)) - (skip-chars-backward "\n") - (unless (eobp) - (forward-line) - (delete-region (point) (point-max))))) - -(defun whitespace-buffer-search (regexp) - "Search for any given whitespace REGEXP." - (with-local-quit - (let (whitespace-retval) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (whitespace-highlight-the-space (match-beginning 0) (match-end 0)) - (push (match-beginning 0) whitespace-retval))) - (when whitespace-retval - (format " %s" (nreverse whitespace-retval)))))) - -(defun whitespace-buffer-cleanup (regexp newregexp) - "Search for any given whitespace REGEXP and replace it with the NEWREGEXP." - (save-excursion - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (replace-match newregexp)))) - -(defun whitespace-indent-cleanup () - "Search for 8/more spaces at the start of a line and replace it with tabs." - (save-excursion - (goto-char (point-min)) - (while (re-search-forward whitespace-indent-regexp nil t) - (let ((column (current-column)) - (indent-tabs-mode t)) - (delete-region (match-beginning 0) (point)) - (indent-to column))))) - -(defun whitespace-unchecked-whitespaces () - "Return the list of whitespaces whose testing has been suppressed." - (let ((unchecked-spaces - (concat (if (not whitespace-check-buffer-ateol) "e") - (if (not whitespace-check-buffer-indent) "i") - (if (not whitespace-check-buffer-leading) "l") - (if (not whitespace-check-buffer-spacetab) "s") - (if (not whitespace-check-buffer-trailing) "t")))) - (if (not (equal unchecked-spaces "")) - unchecked-spaces - nil))) - -(defun whitespace-update-modeline (&optional whitespace-err) - "Update mode line with whitespace errors. -Also with whitespaces whose testing has been turned off." - (if whitespace-display-in-modeline - (progn - (setq whitespace-mode-line nil) - ;; Whitespace errors - (if (and whitespace-err (not (equal whitespace-err ""))) - (setq whitespace-mode-line whitespace-err)) - ;; Whitespace suppressed errors - (let ((whitespace-unchecked (whitespace-unchecked-whitespaces))) - (if whitespace-unchecked - (setq whitespace-mode-line - (concat whitespace-mode-line "!" whitespace-unchecked)))) - ;; Add the whitespace modeline prefix - (setq whitespace-mode-line (if whitespace-mode-line - (concat " W:" whitespace-mode-line) - nil)) - (whitespace-mode-line-update)))) - -(defun whitespace-highlight-the-space (b e) - "Highlight the current line, unhighlighting a previously jumped to line." - (if whitespace-display-spaces-in-color - (let ((ol (whitespace-make-overlay b e))) - (whitespace-overlay-put ol 'face 'whitespace-highlight)))) - -(defun whitespace-unhighlight-the-space() - "Unhighlight the currently highlight line." - (if (and whitespace-display-spaces-in-color whitespace-highlighted-space) - (progn - (mapc 'whitespace-delete-overlay whitespace-highlighted-space) - (setq whitespace-highlighted-space nil)))) - -(defun whitespace-check-buffer-list (buf-name buf-file) - "Add a buffer and its file to the whitespace monitor list. - -The buffer named BUF-NAME and its associated file BUF-FILE are now monitored -periodically for whitespace." - (if (and whitespace-mode (not (member (list buf-file buf-name) - whitespace-all-buffer-files))) - (add-to-list 'whitespace-all-buffer-files (list buf-file buf-name)))) - -(defun whitespace-tickle-timer () - "Tickle timer to periodically to scan qualifying files for whitespace creep. - -If timer is not set, then set it to scan the files in -`whitespace-all-buffer-files' periodically (defined by -`whitespace-rescan-timer-time') for whitespace creep." - (if (and whitespace-rescan-timer-time - (/= whitespace-rescan-timer-time 0) - (not whitespace-rescan-timer)) - (setq whitespace-rescan-timer - (add-timeout whitespace-rescan-timer-time - 'whitespace-rescan-files-in-buffers nil - whitespace-rescan-timer-time)))) - -(defun whitespace-rescan-files-in-buffers (&optional arg) - "Check monitored files for whitespace creep since last scan." - (let ((whitespace-all-my-files whitespace-all-buffer-files) - buffile bufname thiselt buf) - (if (not whitespace-all-my-files) - (progn - (disable-timeout whitespace-rescan-timer) - (setq whitespace-rescan-timer nil)) - (while whitespace-all-my-files - (setq thiselt (car whitespace-all-my-files)) - (setq whitespace-all-my-files (cdr whitespace-all-my-files)) - (setq buffile (car thiselt)) - (setq bufname (cadr thiselt)) - (setq buf (get-buffer bufname)) - (if (buffer-live-p buf) - (with-current-buffer bufname - ;;(message "buffer %s live" bufname) - (if whitespace-mode - (progn - ;;(message "checking for whitespace in %s" bufname) - (if whitespace-auto-cleanup - (progn - ;;(message "cleaning up whitespace in %s" bufname) - (whitespace-cleanup-internal)) - (progn - ;;(message "whitespace-buffer %s." (buffer-name)) - (whitespace-buffer t)))) - ;;(message "Removing %s from refresh list" bufname) - (whitespace-refresh-rescan-list buffile bufname))) - ;;(message "Removing %s from refresh list" bufname) - (whitespace-refresh-rescan-list buffile bufname)))))) - -(defun whitespace-refresh-rescan-list (buffile bufname) - "Refresh the list of files to be rescanned for whitespace creep." - (if whitespace-all-buffer-files - (setq whitespace-all-buffer-files - (delete (list buffile bufname) whitespace-all-buffer-files)) - (when whitespace-rescan-timer - (disable-timeout whitespace-rescan-timer) - (setq whitespace-rescan-timer nil)))) - -;;;###autoload -(defalias 'global-whitespace-mode 'whitespace-global-mode) - -;;;###autoload -(define-minor-mode whitespace-global-mode - "Toggle using Whitespace mode in new buffers. - -When this mode is active, `whitespace-buffer' is added to -`find-file-hook' and `kill-buffer-hook'." - :global t - :group 'whitespace - (if whitespace-global-mode - (progn - (add-hook 'find-file-hook 'whitespace-buffer) - (add-hook 'write-file-functions 'whitespace-write-file-hook nil t) - (add-hook 'kill-buffer-hook 'whitespace-buffer)) - (remove-hook 'find-file-hook 'whitespace-buffer) - (remove-hook 'write-file-functions 'whitespace-write-file-hook t) - (remove-hook 'kill-buffer-hook 'whitespace-buffer))) - -;;;###autoload -(defun whitespace-write-file-hook () - "Hook function to be called on the buffer when whitespace check is enabled. -This is meant to be added buffer-locally to `write-file-functions'." - (let ((werr nil)) - (if whitespace-auto-cleanup - (whitespace-cleanup-internal) - (setq werr (whitespace-buffer))) - (if (and whitespace-abort-on-error werr) - (error "Abort write due to whitespaces in %s" - buffer-file-name))) - nil) - -(defun whitespace-unload-function () - "Unload the whitespace library." - (if (unintern "whitespace-unload-hook" obarray) - ;; if whitespace-unload-hook is defined, let's get rid of it - ;; and recursively call `unload-feature' - (progn (unload-feature 'whitespace) t) - ;; this only happens in the recursive call - (whitespace-global-mode -1) - (save-current-buffer - (dolist (buf (buffer-list)) - (set-buffer buf) - (remove-hook 'write-file-functions 'whitespace-write-file-hook t))) - ;; continue standard unloading - nil)) - -(defun whitespace-unload-hook () - (remove-hook 'find-file-hook 'whitespace-buffer) - (remove-hook 'write-file-functions 'whitespace-write-file-hook t) - (remove-hook 'kill-buffer-hook 'whitespace-buffer)) - -(add-hook 'whitespace-unload-hook 'whitespace-unload-hook) - -(provide 'whitespace) - -;;; whitespace.el ends here 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/tls.el b/lisp/obsolete/tls.el index cd091c0108e..d1b215cbfb8 100644 --- a/lisp/obsolete/tls.el +++ b/lisp/obsolete/tls.el @@ -47,9 +47,6 @@ (require 'gnutls) -(autoload 'format-spec "format-spec") -(autoload 'format-spec-make "format-spec") - (defgroup tls nil "Transport Layer Security (TLS) parameters." :group 'comm) @@ -224,14 +221,11 @@ Fourth arg PORT is an integer specifying a port to connect to." (while (and (not done) (setq cmd (pop cmds))) (let ((process-connection-type tls-process-connection-type) (formatted-cmd - (format-spec - cmd - (format-spec-make - ?t (car (gnutls-trustfiles)) - ?h host - ?p (if (integerp port) - (int-to-string port) - port))))) + (format-spec cmd `((?t . ,(car (gnutls-trustfiles))) + (?h . ,host) + (?p . ,(if (integerp port) + (number-to-string port) + port)))))) (message "Opening TLS connection with `%s'..." formatted-cmd) (setq process (start-process name buffer shell-file-name shell-command-switch diff --git a/lisp/obsolete/vc-arch.el b/lisp/obsolete/vc-arch.el index bcdefac5187..93bd991eb3a 100644 --- a/lisp/obsolete/vc-arch.el +++ b/lisp/obsolete/vc-arch.el @@ -597,20 +597,21 @@ CALLBACK expects (ENTRIES &optional MORE-TO-COME); see (unless (file-writable-p rl-dir) (error "No writable revlib directory found")) (message "Revlib at %s" rl-dir) - (let* ((archives (directory-files rl-dir 'full (rx (or (not ".") "...")))) + (let* ((archives (directory-files rl-dir 'full + directory-files-no-dot-files-regexp)) (categories (apply 'append (mapcar (lambda (dir) (when (file-directory-p dir) - (directory-files dir 'full - (rx (or (not ".") "..."))))) + (directory-files + dir 'full directory-files-no-dot-files-regexp))) archives))) (branches (apply 'append (mapcar (lambda (dir) (when (file-directory-p dir) - (directory-files dir 'full - (rx (or (not ".") "..."))))) + (directory-files + dir 'full directory-files-no-dot-files-regexp))) categories))) (versions (apply 'append 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/ob-core.el b/lisp/org/ob-core.el index 7654c7ebe41..fe9af1ce602 100644 --- a/lisp/org/ob-core.el +++ b/lisp/org/ob-core.el @@ -2437,7 +2437,7 @@ INFO may provide the values of these header arguments (in the (when location (save-excursion (goto-char location) - (when (looking-at (concat org-babel-result-regexp ".*$")) + (when (looking-at org-babel-result-regexp) (delete-region (if keep-keyword (line-beginning-position 2) (save-excursion @@ -3053,9 +3053,8 @@ of `org-babel-temporary-directory'." (if (eq t (car (file-attributes file))) (delete-directory file) (delete-file file))) - ;; We do not want to delete "." and "..". (directory-files org-babel-temporary-directory 'full - (rx (or (not ".") "...")))) + directory-files-no-dot-files-regexp)) (delete-directory org-babel-temporary-directory)) (error (message "Failed to remove temporary Org-babel directory %s" diff --git a/lisp/org/ob-fortran.el b/lisp/org/ob-fortran.el index 154465f28e1..149058f05f4 100644 --- a/lisp/org/ob-fortran.el +++ b/lisp/org/ob-fortran.el @@ -106,7 +106,7 @@ its header arguments." (defun org-babel-fortran-ensure-main-wrap (body params) "Wrap body in a \"program ... end program\" block if none exists." - (if (string-match "^[ \t]*program[ \t]*.*" (capitalize body)) + (if (string-match "^[ \t]*program\\>" (capitalize body)) (let ((vars (org-babel--get-vars params))) (when vars (error "Cannot use :vars if `program' statement is present")) body) diff --git a/lisp/org/ob-screen.el b/lisp/org/ob-screen.el index ad00ee070d4..837c18f8407 100644 --- a/lisp/org/ob-screen.el +++ b/lisp/org/ob-screen.el @@ -126,7 +126,7 @@ The terminal should shortly flicker." ;; XXX: need to find a better way to do the following (while (not (file-readable-p tmpfile)) ;; do something, otherwise this will be optimized away - (format "org-babel-screen: File not readable yet.")) + (sit-for 0.1)) (setq tmp-string (with-temp-buffer (insert-file-contents-literally tmpfile) (buffer-substring (point-min) (point-max)))) 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..689d134627e 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") @@ -2995,7 +2995,8 @@ Agenda views are separated by `org-agenda-block-separator'." (erase-buffer) (insert (eval-when-compile (let ((header - "Press key for an agenda command: + (copy-sequence + "Press key for an agenda command: -------------------------------- < Buffer, subtree/region restriction a Agenda for current week or day > Remove restriction t List of all TODO entries e Export agenda views @@ -3004,7 +3005,7 @@ s Search for keywords M Like m, but only TODO entries / Multi-occur S Like s, but only TODO entries ? Find :FLAGGED: entries C Configure custom agenda commands * Toggle sticky agenda views # List stuck projects (!=configure) -") +")) (start 0)) (while (string-match "\\(^\\| \\|(\\)\\(\\S-\\)\\( \\|=\\)" @@ -8981,7 +8982,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-capture.el b/lisp/org/org-capture.el index 003cbef1fdf..ace51270175 100644 --- a/lisp/org/org-capture.el +++ b/lisp/org/org-capture.el @@ -1021,7 +1021,7 @@ Store them in the capture property list." (apply #'encode-time 0 0 org-extend-today-until (cl-cdddr (decode-time prompt-time)))) - ((string-match "\\([^ ]+\\)--?[^ ]+[ ]+\\(.*\\)" + ((string-match "\\([^ ]+\\)-[^ ]+[ ]+\\(.*\\)" org-read-date-final-answer) ;; Replace any time range by its start. (apply #'encode-time 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..abba29952e6 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. @@ -2005,7 +2005,7 @@ the table and kill the editing buffer." text) (goto-char (point-min)) (while (re-search-forward "^#.*\n?" nil t) (replace-match "")) - (while (re-search-forward "\\([ \t]*\n[ \t]*\\)+" nil t) + (while (re-search-forward "[ \t]*\n[ \t\n]*" nil t) (replace-match " ")) (setq text (org-trim (buffer-string))) (set-window-configuration cw) @@ -3099,7 +3099,7 @@ function assumes the table is already analyzed (i.e., using (let ((lhs (car e)) (rhs (cdr e))) (cond - ((string-match-p "\\`@-?[-+0-9]+\\$-?[0-9]+\\'" lhs) + ((string-match-p "\\`@[-+0-9]+\\$-?[0-9]+\\'" lhs) ;; This just refers to one fixed field. (push e res)) ((string-match-p "\\`[a-zA-Z][_a-zA-Z0-9]*\\'" lhs) diff --git a/lisp/org/org.el b/lisp/org/org.el index 568f5b9b873..f1a7f61a9a1 100644 --- a/lisp/org/org.el +++ b/lisp/org/org.el @@ -460,7 +460,7 @@ Matched keyword is in group 1.") org-clock-string) t) "\\)?" - " *\\([[<][0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} ?[^]\r\n>]*?[]>]" + " *\\([[<][0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}[^]\r\n>]*[]>]" "\\|" "<%%([^\r\n>]*>\\)") "Matches a timestamp, possibly preceded by a keyword.") @@ -564,14 +564,14 @@ Effort estimates given in this property need to have the format H:MM.") ;;;; Timestamp -(defconst org-ts-regexp "<\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} ?[^\r\n>]*?\\)>" +(defconst org-ts-regexp "<\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}[^\r\n>]*\\)>" "Regular expression for fast time stamp matching.") (defconst org-ts-regexp-inactive - "\\[\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} ?[^\r\n>]*?\\)\\]" + "\\[\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}[^]\r\n>]*\\)\\]" "Regular expression for fast inactive time stamp matching.") -(defconst org-ts-regexp-both "[[<]\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} ?[^]\r\n>]*?\\)[]>]" +(defconst org-ts-regexp-both "[[<]\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}[^]\r\n>]*\\)[]>]" "Regular expression for fast time stamp matching.") (defconst org-ts-regexp0 @@ -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/outline.el b/lisp/outline.el index 28ea8a86e6f..6158ed594e9 100644 --- a/lisp/outline.el +++ b/lisp/outline.el @@ -289,12 +289,19 @@ Turning on outline mode calls the value of `text-mode-hook' and then of (list (list nil (concat "^\\(?:" outline-regexp "\\).*$") 0))) (add-hook 'change-major-mode-hook 'outline-show-all nil t)) +(defvar outline-minor-mode-map) + (defcustom outline-minor-mode-prefix "\C-c@" "Prefix key to use for Outline commands in Outline minor mode. The value of this variable is checked as part of loading Outline mode. After that, changing the prefix key requires manipulating keymaps." - :type 'string - :group 'outlines) + :type 'key-sequence + :group 'outlines + :initialize 'custom-initialize-default + :set (lambda (sym val) + (define-key outline-minor-mode-map outline-minor-mode-prefix nil) + (define-key outline-minor-mode-map val outline-mode-prefix-map) + (set-default sym val))) ;;;###autoload (define-minor-mode outline-minor-mode diff --git a/lisp/password-cache.el b/lisp/password-cache.el index 5e5f3240bc3..f5007579a8a 100644 --- a/lisp/password-cache.el +++ b/lisp/password-cache.el @@ -31,7 +31,8 @@ ;; ;; Minibuffer prompt for password. ;; => "foo" ;; -;; (password-cache-add "test" "foo") +;; (password-cache-add "test" (read-passwd "Password? ")) +;; ;; Minibuffer prompt from read-passwd, which returns "foo". ;; => nil ;; (password-read "Password? " "test") diff --git a/lisp/play/animate.el b/lisp/play/animate.el index ff464b68049..8dec55178b1 100644 --- a/lisp/play/animate.el +++ b/lisp/play/animate.el @@ -1,4 +1,4 @@ -;;; animate.el --- make text dance +;;; animate.el --- make text dance -*- lexical-binding:t -*- ;; Copyright (C) 2001-2020 Free Software Foundation, Inc. @@ -84,7 +84,7 @@ (defun animate-place-char (char vpos hpos) (goto-char (window-start)) (let (abbrev-mode) - (dotimes (i vpos) + (dotimes (_ vpos) (end-of-line) (if (= (forward-line 1) 1) (insert "\n")))) diff --git a/lisp/play/bubbles.el b/lisp/play/bubbles.el index 6842cb06302..903c0686063 100644 --- a/lisp/play/bubbles.el +++ b/lisp/play/bubbles.el @@ -80,6 +80,7 @@ ;;; Code: (defconst bubbles-version "0.5" "Version number of bubbles.el.") +(make-obsolete-variable 'bubbles-version nil "28.1") (require 'gamegrid) @@ -975,16 +976,14 @@ Set `bubbles--col-offset' and `bubbles--row-offset'." (* image-vert-size (bubbles--grid-height))) 2))))) -(defun bubbles--remove-overlays () - "Remove all overlays." - (if (fboundp 'remove-overlays) - (remove-overlays))) +(define-obsolete-function-alias 'bubbles--remove-overlays + 'remove-overlays "28.1") (defun bubbles--initialize () "Initialize Bubbles game." (bubbles--initialize-faces) (bubbles--initialize-images) - (bubbles--remove-overlays) + (remove-overlays) (switch-to-buffer (get-buffer-create "*bubbles*")) (bubbles--compute-offsets) @@ -1408,7 +1407,7 @@ Return t if new char is non-empty." (defun bubbles--show-images () "Update images in the bubbles buffer." - (bubbles--remove-overlays) + (remove-overlays) (if (and (display-images-p) bubbles--images-ok (not (eq bubbles-graphics-theme 'ascii))) diff --git a/lisp/play/dissociate.el b/lisp/play/dissociate.el index 3768a14ad82..9a6300c0fd2 100644 --- a/lisp/play/dissociate.el +++ b/lisp/play/dissociate.el @@ -1,4 +1,4 @@ -;;; dissociate.el --- scramble text amusingly for Emacs +;;; dissociate.el --- scramble text amusingly for Emacs -*- lexical-binding:t -*- ;; Copyright (C) 1985, 2001-2020 Free Software Foundation, Inc. diff --git a/lisp/play/gametree.el b/lisp/play/gametree.el index aa99b553244..ba74afce298 100644 --- a/lisp/play/gametree.el +++ b/lisp/play/gametree.el @@ -324,7 +324,7 @@ This value is simply the outline heading level of the current line." (defun gametree-hack-file-layout () (save-excursion (goto-char (point-min)) - (if (looking-at "[^\n]*-*-[^\n]*gametree-local-layout: \\([^;\n]*\\);") + (if (looking-at "[^\n]*-[^\n]*gametree-local-layout: \\([^;\n]*\\);") (progn (goto-char (match-beginning 1)) (delete-region (point) (match-end 1)) diff --git a/lisp/play/gomoku.el b/lisp/play/gomoku.el index 6e0061d461a..403398672b1 100644 --- a/lisp/play/gomoku.el +++ b/lisp/play/gomoku.el @@ -110,8 +110,8 @@ One useful value to include is `turn-on-font-lock' to highlight the pieces." (define-key map "u" 'gomoku-move-ne) ; u (define-key map "b" 'gomoku-move-sw) ; b (define-key map "n" 'gomoku-move-se) ; n - (define-key map "h" 'backward-char) ; h - (define-key map "l" 'forward-char) ; l + (define-key map "h" 'gomoku-move-left) ; h + (define-key map "l" 'gomoku-move-right) ; l (define-key map "j" 'gomoku-move-down) ; j (define-key map "k" 'gomoku-move-up) ; k @@ -119,11 +119,13 @@ One useful value to include is `turn-on-font-lock' to highlight the pieces." (define-key map [kp-9] 'gomoku-move-ne) (define-key map [kp-1] 'gomoku-move-sw) (define-key map [kp-3] 'gomoku-move-se) - (define-key map [kp-4] 'backward-char) - (define-key map [kp-6] 'forward-char) + (define-key map [kp-4] 'gomoku-move-left) + (define-key map [kp-6] 'gomoku-move-right) (define-key map [kp-2] 'gomoku-move-down) (define-key map [kp-8] 'gomoku-move-up) + (define-key map "\C-b" 'gomoku-move-left) ; C-b + (define-key map "\C-f" 'gomoku-move-right) ; C-f (define-key map "\C-n" 'gomoku-move-down) ; C-n (define-key map "\C-p" 'gomoku-move-up) ; C-p @@ -146,6 +148,10 @@ One useful value to include is `turn-on-font-lock' to highlight the pieces." (define-key map [mouse-2] 'gomoku-mouse-play) (define-key map [drag-mouse-2] 'gomoku-mouse-play) + (define-key map [remap backward-char] 'gomoku-move-left) + (define-key map [remap left-char] 'gomoku-move-left) + (define-key map [remap forward-char] 'gomoku-move-right) + (define-key map [remap right-char] 'gomoku-move-right) (define-key map [remap previous-line] 'gomoku-move-up) (define-key map [remap next-line] 'gomoku-move-down) (define-key map [remap move-beginning-of-line] 'gomoku-beginning-of-line) @@ -954,6 +960,11 @@ If the game is finished, this command requests for another game." ;; 2 instead of 1 because WINDOW-HEIGHT includes the mode line ! gomoku-square-height))) +(defun gomoku-point-x () + "Return the board column where point is." + (1+ (/ (- (current-column) gomoku-x-offset) + gomoku-square-width))) + (defun gomoku-point-y () "Return the board row where point is." (1+ (/ (- (count-lines (point-min) (point)) @@ -1143,13 +1154,28 @@ If the game is finished, this command requests for another game." (skip-chars-forward gomoku--intangible-chars) (when (eobp) (skip-chars-backward gomoku--intangible-chars) - (forward-char -1))) + (gomoku-move-left))) (skip-chars-backward gomoku--intangible-chars) (if (bobp) (skip-chars-forward gomoku--intangible-chars) - (forward-char -1)))) + (gomoku-move-left)))) (setq gomoku--last-pos (point))) +;; forward-char and backward-char don't always move the right number +;; of characters. Also, these functions check if you're on the edge of +;; the screen. +(defun gomoku-move-right () + "Move point right one column on the Gomoku board." + (interactive) + (when (< (gomoku-point-x) gomoku-board-width) + (forward-char gomoku-square-width))) + +(defun gomoku-move-left () + "Move point left one column on the Gomoku board." + (interactive) + (when (> (gomoku-point-x) 1) + (backward-char gomoku-square-width))) + ;; previous-line and next-line don't work right with intangible newlines (defun gomoku-move-down () "Move point down one row on the Gomoku board." @@ -1171,25 +1197,25 @@ If the game is finished, this command requests for another game." "Move point North East on the Gomoku board." (interactive) (gomoku-move-up) - (forward-char)) + (gomoku-move-right)) (defun gomoku-move-se () "Move point South East on the Gomoku board." (interactive) (gomoku-move-down) - (forward-char)) + (gomoku-move-right)) (defun gomoku-move-nw () "Move point North West on the Gomoku board." (interactive) (gomoku-move-up) - (backward-char)) + (gomoku-move-left)) (defun gomoku-move-sw () "Move point South West on the Gomoku board." (interactive) (gomoku-move-down) - (backward-char)) + (gomoku-move-left)) (defun gomoku-beginning-of-line () "Move point to first square on the Gomoku board row." diff --git a/lisp/play/snake.el b/lisp/play/snake.el index d7c0683a05f..70d80c464fc 100644 --- a/lisp/play/snake.el +++ b/lisp/play/snake.el @@ -192,6 +192,7 @@ and then start moving it leftwards.") (defvar snake-null-map (let ((map (make-sparse-keymap 'snake-null-map))) (define-key map "n" 'snake-start-game) + (define-key map "q" 'quit-window) map) "Keymap for finished Snake games.") diff --git a/lisp/play/spook.el b/lisp/play/spook.el index 8e69cd971bb..ed91dadcbca 100644 --- a/lisp/play/spook.el +++ b/lisp/play/spook.el @@ -1,4 +1,4 @@ -;;; spook.el --- spook phrase utility for overloading the NSA line eater +;;; spook.el --- spook phrase utility for overloading the NSA line eater -*- lexical-binding:t -*- ;; Copyright (C) 1988, 1993, 2001-2020 Free Software Foundation, Inc. @@ -45,13 +45,11 @@ (defcustom spook-phrases-file (expand-file-name "spook.lines" data-directory) "Keep your favorite phrases here." - :type 'file - :group 'spook) + :type 'file) (defcustom spook-phrase-default-count 15 "Default number of phrases to insert." - :type 'integer - :group 'spook) + :type 'integer) ;;;###autoload (defun spook () diff --git a/lisp/printing.el b/lisp/printing.el index 181092ee999..b8879befae3 100644 --- a/lisp/printing.el +++ b/lisp/printing.el @@ -5622,8 +5622,6 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order." ;; header (let ((versions (concat "printing v" pr-version " ps-print v" ps-print-version))) - ;; to keep compatibility with Emacs 20 & 21: - ;; DO NOT REPLACE `?\ ' BY `?\s' (widget-insert (make-string (- 79 (length versions)) ?\ ) versions)) (pr-insert-italic "\nCurrent Directory : " 1) (pr-insert-italic default-directory) diff --git a/lisp/progmodes/autoconf.el b/lisp/progmodes/autoconf.el index 5d5811b47d1..d12bed7e27d 100644 --- a/lisp/progmodes/autoconf.el +++ b/lisp/progmodes/autoconf.el @@ -1,4 +1,4 @@ -;;; autoconf.el --- mode for editing Autoconf configure.ac files +;;; autoconf.el --- mode for editing Autoconf configure.ac files -*- lexical-binding: t; -*- ;; Copyright (C) 2000-2020 Free Software Foundation, Inc. diff --git a/lisp/progmodes/bug-reference.el b/lisp/progmodes/bug-reference.el index 75ebc29710c..c52331f84fa 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) @@ -139,12 +139,312 @@ The second subexpression should match the bug reference (usually a number)." (when url (browse-url url)))))) +(defun bug-reference--maybe-setup-from-vc (url url-rx bug-rx bug-url-fmt) + (when (string-match url-rx url) + (setq-local bug-reference-bug-regexp bug-rx) + (setq-local bug-reference-url-format + (let (groups) + (dotimes (i (/ (length (match-data)) 2)) + (push (match-string i url) groups)) + (funcall bug-url-fmt (nreverse groups)))))) + +(defvar bug-reference-setup-from-vc-alist + `(;; + ;; GNU projects on savannah. + ;; + ;; Not all of them use debbugs but that doesn't really matter + ;; because the auto-setup is only performed if + ;; `bug-reference-url-format' and `bug-reference-bug-regexp' + ;; aren't set already. + ("git\\.\\(?:sv\\|savannah\\)\\.gnu\\.org:" + "\\<\\([Bb]ug ?#?\\)\\([0-9]+\\(?:#[0-9]+\\)?\\)\\>" + ,(lambda (_) "https://debbugs.gnu.org/%s")) + ;; + ;; GitHub projects. + ;; + ;; Here #17 may refer to either an issue or a pull request but + ;; visiting the issue/17 web page will automatically redirect to + ;; the pull/17 page if 17 is a PR. Explicit user/project#17 links + ;; to possibly different projects are also supported. + ("[/@]github.com[/:]\\([.A-Za-z0-9_/-]+\\)\\.git" + "\\([.A-Za-z0-9_/-]+\\)?\\(?:#\\)\\([0-9]+\\)\\>" + ,(lambda (groups) + (let ((ns-project (nth 1 groups))) + (lambda () + (concat "https://github.com/" + (or + ;; Explicit user/proj#18 link. + (match-string 1) + ns-project) + "/issues/" + (match-string 2)))))) + ;; + ;; GitLab projects. + ;; + ;; Here #18 is an issue and !17 is a merge request. Explicit + ;; namespace/project#18 or namespace/project!17 references to + ;; possibly different projects are also supported. + ("[/@]gitlab.com[/:]\\([.A-Za-z0-9_/-]+\\)\\.git" + "\\(?1:[.A-Za-z0-9_/-]+\\)?\\(?3:[#!]\\)\\(?2:[0-9]+\\)\\>" + ,(lambda (groups) + (let ((ns-project (nth 1 groups))) + (lambda () + (concat "https://gitlab.com/" + (or (match-string 1) + ns-project) + "/-/" + (if (string= (match-string 3) "#") + "issues/" + "merge_requests/") + (match-string 2))))))) + "An alist for setting up `bug-reference-mode' based on VC URL. + +Each element has the form (URL-REGEXP BUG-REGEXP URL-FORMAT-FN). + +URL-REGEXP is matched against the version control URL of the +current buffer's file. If it matches, BUG-REGEXP is set as +`bug-reference-bug-regexp'. URL-FORMAT-FN is a function of one +argument that receives a list of the groups 0 to N of matching +URL-REGEXP against the VCS URL and returns the value to be set as +`bug-reference-url-format'.") + +(defun bug-reference-try-setup-from-vc () + "Try setting up `bug-reference-mode' based on VC information. +Test each configuration in `bug-reference-setup-from-vc-alist' +and apply it if applicable." + (let ((file-or-dir (or buffer-file-name + ;; Catches modes such as vc-dir and Magit. + default-directory))) + (when file-or-dir + (let* ((backend (vc-responsible-backend file-or-dir t)) + (url + (or (ignore-errors + (vc-call-backend backend 'repository-url "upstream")) + (ignore-errors + (vc-call-backend backend 'repository-url))))) + (when url + (catch 'found + (dolist (config bug-reference-setup-from-vc-alist) + (when (apply #'bug-reference--maybe-setup-from-vc + url config) + (throw 'found t))))))))) + +(defvar bug-reference-setup-from-mail-alist + `((,(regexp-opt '("emacs" "auctex" "gnus" "tramp" "orgmode") 'words) + ,(regexp-opt '("@debbugs.gnu.org" "-devel@gnu.org" + ;; List-Id of Gnus devel mailing list. + "ding.gnus.org")) + "\\([Bb]ug ?#?\\)\\([0-9]+\\(?:#[0-9]+\\)?\\)" + "https://debbugs.gnu.org/%s")) + "An alist for setting up `bug-reference-mode' in mail modes. + +This takes action if `bug-reference-mode' is enabled in group and +message buffers of Emacs mail clients. Currently, only Gnus is +supported. + +Each element has the form + + (GROUP-REGEXP HEADER-REGEXP BUG-REGEXP URL-FORMAT) + +GROUP-REGEXP is a regexp matched against the current mail folder +or newsgroup name. HEADER-REGEXP is a regexp matched against the +From, To, Cc, Newsgroup, and List-ID header values of the current +mail or newsgroup message. If any of those matches, BUG-REGEXP +is set as `bug-reference-bug-regexp' and URL-FORMAT is set as +`bug-reference-url-format'. + +Note: In Gnus, if a summary buffer has been set up based on +GROUP-REGEXP, all article buffers opened from there will get the +same `bug-reference-url-format' and `bug-reference-url-format'.") + +(defvar gnus-newsgroup-name) + +(defun bug-reference--maybe-setup-from-mail (group header-values) + "Set up according to mail GROUP or HEADER-VALUES. +Group is a mail group/folder name and HEADER-VALUES is a list of +mail header values, e.g., the values of From, To, Cc, List-ID, +and Newsgroup. + +If any GROUP-REGEXP or HEADER-REGEXP of +`bug-reference-setup-from-mail-alist' matches GROUP or any +element in HEADER-VALUES, the corresponding BUG-REGEXP and +URL-FORMAT are set." + (catch 'setup-done + (dolist (config bug-reference-setup-from-mail-alist) + (when (or + (and group + (car config) + (string-match-p (car config) group)) + (and header-values + (nth 1 config) + (catch 'matching-header + (dolist (h header-values) + (when (and h (string-match-p (nth 1 config) h)) + (throw 'matching-header t)))))) + (setq-local bug-reference-bug-regexp (nth 2 config)) + (setq-local bug-reference-url-format (nth 3 config)) + (throw 'setup-done t))))) + +(defun bug-reference-try-setup-from-gnus () + "Try setting up `bug-reference-mode' based on Gnus group or article. +Test each configuration in `bug-reference-setup-from-mail-alist' +and set it if applicable." + (when (and (derived-mode-p 'gnus-summary-mode) + (bound-and-true-p gnus-newsgroup-name)) + ;; Gnus reuses its article buffer so we have to check whenever the + ;; article changes. + (add-hook 'gnus-article-prepare-hook + #'bug-reference--try-setup-gnus-article) + (bug-reference--maybe-setup-from-mail gnus-newsgroup-name nil))) + +(defvar gnus-article-buffer) +(defvar gnus-original-article-buffer) +(defvar gnus-summary-buffer) + +(defun bug-reference--try-setup-gnus-article () + (with-demoted-errors + "Error in bug-reference--try-setup-gnus-article: %S" + (when (and bug-reference-mode ;; Only if enabled in article buffers. + (derived-mode-p + 'gnus-article-mode + ;; Apparently, gnus-article-prepare-hook is run in the + ;; summary buffer... + 'gnus-summary-mode) + gnus-article-buffer + gnus-original-article-buffer + (buffer-live-p (get-buffer gnus-article-buffer)) + (buffer-live-p (get-buffer gnus-original-article-buffer))) + (with-current-buffer gnus-article-buffer + (catch 'setup-done + ;; Copy over the values from the summary buffer. + (when (and gnus-summary-buffer + (buffer-live-p gnus-summary-buffer)) + (setq-local bug-reference-bug-regexp + (with-current-buffer gnus-summary-buffer + bug-reference-bug-regexp)) + (setq-local bug-reference-url-format + (with-current-buffer gnus-summary-buffer + bug-reference-url-format)) + (when (and bug-reference-bug-regexp + bug-reference-url-format) + (throw 'setup-done t))) + ;; If the summary had no values, try setting according to + ;; the values of the From, To, and Cc headers. + (let (header-values) + (with-current-buffer + (get-buffer gnus-original-article-buffer) + (save-excursion + (goto-char (point-min)) + ;; The Newsgroup is omitted because we already matched + ;; based on group name in the summary buffer. + (dolist (field '("list-id" "to" "from" "cc")) + (let ((val (mail-fetch-field field))) + (when val + (push val header-values)))))) + (bug-reference--maybe-setup-from-mail nil header-values))))))) + +(defvar bug-reference-setup-from-irc-alist + `((,(concat "#" (regexp-opt '("emacs" "gnus" "org-mode" "rcirc" + "erc") 'words)) + "freenode" + "\\([Bb]ug ?#?\\)\\([0-9]+\\(?:#[0-9]+\\)?\\)" + "https://debbugs.gnu.org/%s")) + "An alist for setting up `bug-reference-mode' in IRC modes. + +This takes action if `bug-reference-mode' is enabled in IRC +channels using one of Emacs' IRC clients (rcirc and ERC). +Currently, rcirc and ERC are supported. + +Each element has the form + + (CHANNEL-REGEXP NETWORK-REGEXP BUG-REGEXP URL-FORMAT) + +CHANNEL-REGEXP is a regexp matched against the current IRC +channel name (e.g. #emacs). NETWORK-REGEXP is matched against +the IRC network name (e.g. freenode). Both entries are optional. +If all given entries match, BUG-REGEXP is set as +`bug-reference-bug-regexp' and URL-FORMAT is set as +`bug-reference-url-format'.") + +(defun bug-reference--maybe-setup-from-irc (channel network) + "Set up according to IRC CHANNEL or NETWORK. +CHANNEL is an IRC channel name (or generally a target, i.e., it +could also be a user name) and NETWORK is that channel's network +name. + +If any `bug-reference-setup-from-irc-alist' entry's +CHANNEL-REGEXP and NETWORK-REGEXP match CHANNEL and NETWORK, the +corresponding BUG-REGEXP and URL-FORMAT are set." + (catch 'setup-done + (dolist (config bug-reference-setup-from-irc-alist) + (let ((channel-rx (car config)) + (network-rx (nth 1 config))) + (when (and + ;; One of both has to be given. + (or channel-rx network-rx) + ;; The args have to be set. + channel network) + (when (and + (or (null channel-rx) + (string-match-p channel-rx channel)) + (or (null network-rx) + (string-match-p network-rx network))) + (setq-local bug-reference-bug-regexp (nth 2 config)) + (setq-local bug-reference-url-format (nth 3 config)) + (throw 'setup-done t))))))) + +(defvar rcirc-target) +(defvar rcirc-server-buffer) +(defvar rcirc-server) + +(defun bug-reference-try-setup-from-rcirc () + "Try setting up `bug-reference-mode' based on rcirc channel and server. +Test each configuration in `bug-reference-setup-from-irc-alist' +and set it if applicable." + (when (derived-mode-p 'rcirc-mode) + (bug-reference--maybe-setup-from-irc + rcirc-target + (and rcirc-server-buffer + (buffer-live-p rcirc-server-buffer) + (with-current-buffer rcirc-server-buffer + rcirc-server))))) + +(declare-function erc-format-target "erc") +(declare-function erc-network-name "erc-networks") + +(defun bug-reference-try-setup-from-erc () + "Try setting up `bug-reference-mode' based on ERC channel and server. +Test each configuration in `bug-reference-setup-from-irc-alist' +and set it if applicable." + (when (derived-mode-p 'erc-mode) + (bug-reference--maybe-setup-from-irc + (erc-format-target) + (erc-network-name)))) + +(defun bug-reference--run-auto-setup () + (when (or bug-reference-mode + bug-reference-prog-mode) + ;; Automatic setup only if the variables aren't already set, e.g., + ;; by a local variables section in the file. + (unless (and bug-reference-bug-regexp + bug-reference-url-format) + (with-demoted-errors + "Error during bug-reference auto-setup: %S" + (catch 'setup + (dolist (f (list #'bug-reference-try-setup-from-vc + #'bug-reference-try-setup-from-gnus + #'bug-reference-try-setup-from-rcirc + #'bug-reference-try-setup-from-erc)) + (when (funcall f) + (throw 'setup t)))))))) + ;;;###autoload (define-minor-mode bug-reference-mode "Toggle hyperlinking bug references in the buffer (Bug Reference mode)." nil "" nil + :after-hook (bug-reference--run-auto-setup) (if bug-reference-mode (jit-lock-register #'bug-reference-fontify) (jit-lock-unregister #'bug-reference-fontify) @@ -158,6 +458,7 @@ The second subexpression should match the bug reference (usually a number)." nil "" nil + :after-hook (bug-reference--run-auto-setup) (if bug-reference-prog-mode (jit-lock-register #'bug-reference-fontify) (jit-lock-unregister #'bug-reference-fontify) diff --git a/lisp/progmodes/cc-align.el b/lisp/progmodes/cc-align.el index f30477dc787..6172afecbcf 100644 --- a/lisp/progmodes/cc-align.el +++ b/lisp/progmodes/cc-align.el @@ -790,6 +790,38 @@ arglist-cont-nonempty." (or (c-lineup-assignments langelem) c-basic-offset)) +(defun c-lineup-ternary-bodies (langelem) + "Line up true and false branches of a ternary operator (i.e. `?:'). +More precisely, if the line starts with a colon which is a part of +a said operator, align it with corresponding question mark; otherwise +return nil. For example: + + return arg % 2 == 0 ? arg / 2 + : (3 * arg + 1); <- c-lineup-ternary-bodies + +Works with: arglist-cont, arglist-cont-nonempty and statement-cont." + (save-excursion + (back-to-indentation) + (when (and (eq ?: (char-after)) + (not (eq ?: (char-after (1+ (point)))))) + (let ((limit (c-langelem-pos langelem)) (depth 1)) + (catch 'done + (while (and (c-syntactic-skip-backward "^?:" limit t) + (not (bobp))) + (backward-char) + (cond ((eq (char-after) ??) + ;; If we've found a question mark, decrease depth. If we've + ;; reached zero, we've found the one we were looking for. + (when (zerop (setq depth (1- depth))) + (throw 'done (vector (current-column))))) + ((or (eq ?: (char-before)) (eq ?? (char-before))) + ;; Step over `::' and `?:' operators. We don't have to + ;; handle `?:' here but doing so saves an iteration. + (if (eq (point) limit) + (throw 'done nil) + (goto-char (1- (point))))) + ((setq depth (1+ depth)))))))))) ; Otherwise increase depth. + (defun c-lineup-cascaded-calls (langelem) "Line up \"cascaded calls\" under each other. If the line begins with \"->\" or \".\" and the preceding line ends diff --git a/lisp/progmodes/cc-awk.el b/lisp/progmodes/cc-awk.el index fd61e3e3287..52e6da6f4ac 100644 --- a/lisp/progmodes/cc-awk.el +++ b/lisp/progmodes/cc-awk.el @@ -1003,7 +1003,7 @@ std\\(err\\|in\\|out\\)\\|user\\)\\)\\>\ ;; Matches an unterminated string/regexp, NOT including the eol at the end. (defconst c-awk-harmless-pattern-characters* - (concat "\\([^{;#/\"\\\\\n\r]\\|" c-awk-esc-pair-re "\\)*")) + (concat "\\([^{;#/\"\\\n\r]\\|" c-awk-esc-pair-re "\\)*")) ;; Matches any "harmless" character in a pattern or an escaped character pair. (defun c-awk-at-statement-end-p () diff --git a/lisp/progmodes/cc-cmds.el b/lisp/progmodes/cc-cmds.el index 1071191775b..1b557c41a5d 100644 --- a/lisp/progmodes/cc-cmds.el +++ b/lisp/progmodes/cc-cmds.el @@ -48,6 +48,7 @@ (cc-bytecomp-defvar filladapt-mode) ; c-fill-paragraph contains a kludge ; which looks at this. (cc-bytecomp-defun electric-pair-post-self-insert-function) +(cc-bytecomp-defvar c-indent-to-body-directives) ;; Indentation / Display syntax functions (defvar c-fix-backslashes t) @@ -512,11 +513,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 @@ -1441,6 +1442,98 @@ keyword on the line, the keyword is not inserted inside a literal, and (indent-according-to-mode) (delete-char -2))))) +(defun c-align-cpp-indent-to-body () + "Align a \"#pragma\" line under the previous line. +This function is intented for use as a member of `c-special-indent-hook'." + (when (assq 'cpp-macro c-syntactic-context) + (when + (save-excursion + (save-match-data + (back-to-indentation) + (and + (looking-at (concat c-opt-cpp-symbol "[ \t]*\\([a-zA-Z0-9_]+\\)")) + (member (match-string-no-properties 1) + c-cpp-indent-to-body-directives)))) + (c-indent-line (delete '(cpp-macro) c-syntactic-context))))) + +(defvar c-cpp-indent-to-body-flag nil) +;; Non-nil when CPP directives such as "#pragma" should be indented to under +;; the preceding statement. +(make-variable-buffer-local 'c-cpp-indent-to-body-flag) + +(defun c-electric-pragma () + "Reindent the current line if appropriate. + +This function is used to reindent a preprocessor line when the +symbol for the directive, typically \"pragma\", triggers this +function as a hook function of an abbreviation. + +The \"#\" of the preprocessor construct is aligned under the +first anchor point of the line's syntactic context. + +The line is reindented if the construct is not in a string or +comment, there is exactly one \"#\" contained in optional +whitespace before it on the current line, and `c-electric-flag' +and `c-syntactic-indentation' are both non-nil." + (save-excursion + (save-match-data + (when + (and + c-cpp-indent-to-body-flag + c-electric-flag + c-syntactic-indentation + last-abbrev-location + c-opt-cpp-symbol ; "#" or nil. + (progn (back-to-indentation) + (looking-at (concat c-opt-cpp-symbol "[ \t]*"))) + (>= (match-end 0) last-abbrev-location) + (not (c-literal-limits))) + (c-indent-line (delete '(cpp-macro) (c-guess-basic-syntax))))))) + +(defun c-add-indent-to-body-to-abbrev-table (d) + ;; Create an abbreviation table entry for the directive D, and add it to the + ;; current abbreviation table. Existing abbreviation (e.g. for "else") do + ;; not get overwritten. + (when (and c-buffer-is-cc-mode + local-abbrev-table + (not (abbrev-symbol d local-abbrev-table))) + (condition-case nil + (define-abbrev local-abbrev-table d d 'c-electric-pragma 0 t) + (wrong-number-of-arguments + (define-abbrev local-abbrev-table d d 'c-electric-pragma))))) + +(defun c-clear-stale-indent-to-body-abbrevs () + ;; Fill in this comment. FIXME!!! + (when (fboundp 'abbrev-get) + (mapatoms (lambda (a) + (when (and (abbrev-get a ':system) ; Preserve a user's abbrev! + (not (member (symbol-name a) c-std-abbrev-keywords)) + (not (member (symbol-name a) + c-cpp-indent-to-body-directives))) + (unintern a local-abbrev-table))) + local-abbrev-table))) + +(defun c-toggle-cpp-indent-to-body (&optional arg) + "Toggle the C preprocessor indent-to-body feature. +When enabled, preprocessor directives which are words in +`c-indent-to-body-directives' are indented as if they were statements. + +Optional numeric ARG, if supplied, turns on the feature when positive, +turns it off when negative, and just toggles it when zero or +left out." + (interactive "P") + (setq c-cpp-indent-to-body-flag + (c-calculate-state arg c-cpp-indent-to-body-flag)) + (if c-cpp-indent-to-body-flag + (progn + (c-clear-stale-indent-to-body-abbrevs) + (mapc 'c-add-indent-to-body-to-abbrev-table + c-cpp-indent-to-body-directives) + (add-hook 'c-special-indent-hook 'c-align-cpp-indent-to-body nil t)) + (remove-hook 'c-special-indent-hook 'c-align-cpp-indent-to-body t)) + (message "c-cpp-indent-to-body %sabled" + (if c-cpp-indent-to-body-flag "en" "dis"))) + (declare-function subword-forward "subword" (&optional arg)) @@ -2024,6 +2117,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/cc-defs.el b/lisp/progmodes/cc-defs.el index a1e3a236a11..9a3d7adf61d 100644 --- a/lisp/progmodes/cc-defs.el +++ b/lisp/progmodes/cc-defs.el @@ -87,7 +87,7 @@ ;;; Variables also used at compile time. -(defconst c-version "5.34.1" +(defconst c-version "5.34.2" "CC Mode version number.") (defconst c-version-sym (intern c-version)) @@ -445,6 +445,15 @@ to it is returned. This function does not modify the point or the mark." ;; Emacs and earlier XEmacs `(next-single-property-change ,position ,prop ,object ,limit))) +(defmacro c-previous-single-property-change (position prop &optional object limit) + ;; See the doc string for either of the defuns expanded to. + (if (and c-use-extents + (fboundp 'previous-single-char-property-change)) + ;; XEmacs >= 2005-01-25 + `(previous-single-char-property-change ,position ,prop ,object ,limit) + ;; Emacs and earlier XEmacs + `(previous-single-property-change ,position ,prop ,object ,limit))) + (defmacro c-region-is-active-p () ;; Return t when the region is active. The determination of region ;; activeness is different in both Emacs and XEmacs. @@ -1047,15 +1056,6 @@ MODE is either a mode symbol or a list of mode symbols." ;; properties set on a single character and that never spread to any ;; other characters. -(defmacro c-put-syn-tab (pos value) - ;; Set both the syntax-table and the c-fl-syn-tab text properties at POS to - ;; VALUE (which should not be nil). - `(let ((-pos- ,pos) - (-value- ,value)) - (c-put-char-property -pos- 'syntax-table -value-) - (c-put-char-property -pos- 'c-fl-syn-tab -value-) - (c-truncate-lit-pos-cache -pos-))) - (eval-and-compile ;; Constant used at compile time to decide whether or not to use ;; XEmacs extents. Check all the extent functions we'll use since @@ -1183,13 +1183,6 @@ MODE is either a mode symbol or a list of mode symbols." ;; Emacs < 21. `(c-clear-char-property-fun ,pos ',property)))) -(defmacro c-clear-syn-tab (pos) - ;; Remove both the 'syntax-table and `c-fl-syn-tab properties at POS. - `(let ((-pos- ,pos)) - (c-clear-char-property -pos- 'syntax-table) - (c-clear-char-property -pos- 'c-fl-syn-tab) - (c-truncate-lit-pos-cache -pos-))) - (defmacro c-min-property-position (from to property) ;; Return the first position in the range [FROM to) where the text property ;; PROPERTY is set, or `most-positive-fixnum' if there is no such position. @@ -1235,8 +1228,18 @@ MODE is either a mode symbol or a list of mode symbols." ;; Remove all occurrences of the `syntax-table' and `c-fl-syn-tab' text ;; properties between FROM and TO. `(let ((-from- ,from) (-to- ,to)) - (c-clear-char-properties -from- -to- 'syntax-table) - (c-clear-char-properties -from- -to- 'c-fl-syn-tab))) + (when (and + c-min-syn-tab-mkr c-max-syn-tab-mkr + (< -from- c-max-syn-tab-mkr) + (> -to- c-min-syn-tab-mkr)) + (let ((pos -from-)) + (while (and + (< pos -to-) + (setq pos (c-min-property-position pos -to- 'c-fl-syn-tab)) + (< pos -to-)) + (c-clear-syn-tab pos) + (setq pos (1+ pos))))) + (c-clear-char-properties -from- -to- 'syntax-table))) (defmacro c-search-forward-char-property (property value &optional limit) "Search forward for a text-property PROPERTY having value VALUE. @@ -1456,28 +1459,6 @@ with value CHAR in the region [FROM to)." (c-put-char-property (point) ,property ,value) (forward-char))))) -(defmacro c-with-extended-string-fences (beg end &rest body) - ;; If needed, extend the region with "mirrored" c-fl-syn-tab properties to - ;; contain the region (BEG END), then evaluate BODY. If this mirrored - ;; region was initially empty, restore it afterwards. - `(let ((-beg- ,beg) - (-end- ,end) - ) - (cond - ((null c-fl-syn-tab-region) - (unwind-protect - (progn - (c-restore-string-fences -beg- -end-) - ,@body) - (c-clear-string-fences))) - ((and (>= -beg- (car c-fl-syn-tab-region)) - (<= -end- (cdr c-fl-syn-tab-region))) - ,@body) - (t ; Crudely extend the mirrored region. - (setq -beg- (min -beg- (car c-fl-syn-tab-region)) - -end- (max -end- (cdr c-fl-syn-tab-region))) - (c-restore-string-fences -beg- -end-) - ,@body)))) ;; Macros to put overlays (Emacs) or extents (XEmacs) on buffer text. ;; For our purposes, these are characterized by being possible to diff --git a/lisp/progmodes/cc-engine.el b/lisp/progmodes/cc-engine.el index bccef6890f8..c3a98d9c5cf 100644 --- a/lisp/progmodes/cc-engine.el +++ b/lisp/progmodes/cc-engine.el @@ -163,7 +163,9 @@ (defvar c-doc-line-join-re) (defvar c-doc-bright-comment-start-re) (defvar c-doc-line-join-end-ch) -(defvar c-fl-syn-tab-region) +(cc-bytecomp-defvar c-min-syn-tab-mkr) +(cc-bytecomp-defvar c-max-syn-tab-mkr) +(cc-bytecomp-defun c-clear-syn-tab) (cc-bytecomp-defun c-clear-string-fences) (cc-bytecomp-defun c-restore-string-fences) @@ -405,7 +407,7 @@ comment at the start of cc-engine.el for more info." (when (and (car c-macro-cache) (> (point) (car c-macro-cache)) ; in case we have a ; zero-sized region. - (not (eq (char-before (1- (point))) ?\\))) + (not lim)) (setcdr c-macro-cache (point)) (setq c-macro-cache-syntactic nil))))))) @@ -1580,6 +1582,7 @@ comment at the start of cc-engine.el for more info." (save-excursion (backward-char) (looking-at "\\s(")) (c-crosses-statement-barrier-p (point) end))))) +(make-obsolete 'c-at-expression-start-p nil "CC mode 5.35") ;; A set of functions that covers various idiosyncrasies in @@ -1642,6 +1645,21 @@ comment at the start of cc-engine.el for more info." (forward-char 2) t)))) +(defmacro c-forward-comment-minus-1 () + "Call (forward-comment -1), taking care of escaped newlines. +Return the result of `forward-comment' if it gets called, nil otherwise." + `(if (not comment-end-can-be-escaped) + (forward-comment -1) + (when (and (< (skip-syntax-backward " >") 0) + (eq (char-after) ?\n)) + (forward-char)) + (cond + ((and (eq (char-before) ?\n) + (eq (char-before (1- (point))) ?\\)) + (backward-char) + nil) + (t (forward-comment -1))))) + (defun c-backward-single-comment () "Move backward past whitespace and the closest preceding comment, if any. Return t if a comment was found, nil otherwise. In either case, the @@ -1675,12 +1693,12 @@ This function does not do any hidden buffer changes." ;; same line. (re-search-forward "\\=\\s *[\n\r]" start t) - (if (if (forward-comment -1) + (if (if (c-forward-comment-minus-1) (if (eolp) ;; If forward-comment above succeeded and we're at eol ;; then the newline we moved over above didn't end a ;; line comment, so we give it another go. - (forward-comment -1) + (c-forward-comment-minus-1) t)) ;; Emacs <= 20 and XEmacs move back over the closer of a @@ -1709,7 +1727,7 @@ comment at the start of cc-engine.el for more info." (if (let (moved-comment) (while - (and (not (setq moved-comment (forward-comment -1))) + (and (not (setq moved-comment (c-forward-comment-minus-1))) ;; Cope specifically with ^M^J here - ;; forward-comment sometimes gets stuck after ^Ms, ;; sometimes after ^M^J. @@ -1895,52 +1913,29 @@ comment at the start of cc-engine.el for more info." (defun c-enclosing-c++-attribute () ;; If we're in C++ Mode, and point is within a correctly balanced [[ ... ]] ;; attribute structure, return a cons of its starting and ending positions. - ;; Otherwise, return nil. We use the c-{in,is}-sws-face text properties for - ;; this determination, this macro being intended only for use in the *-sws-* - ;; functions and macros. The match data are NOT preserved over this macro. - (let (attr-end pos-is-sws) - (and - (c-major-mode-is 'c++-mode) - (> (point) (point-min)) - (setq pos-is-sws - (if (get-text-property (1- (point)) 'c-is-sws) - (1- (point)) - (1- (previous-single-property-change - (point) 'c-is-sws nil (point-min))))) - (save-excursion - (goto-char pos-is-sws) - (setq attr-end (c-looking-at-c++-attribute))) - (> attr-end (point)) - (cons pos-is-sws attr-end)))) - -(defun c-slow-enclosing-c++-attribute () - ;; Like `c-enclosing-c++-attribute', but does not depend on the c-i[ns]-sws - ;; properties being set. + ;; Otherwise, return nil. (and (c-major-mode-is 'c++-mode) (save-excursion - (let ((paren-state (c-parse-state)) + (let ((lim (max (- (point) 200) (point-min))) cand) (while - (progn - (setq cand - (catch 'found-cand - (while (cdr paren-state) - (when (and (numberp (car paren-state)) - (numberp (cadr paren-state)) - (eq (car paren-state) - (1+ (cadr paren-state))) - (eq (char-after (car paren-state)) ?\[) - (eq (char-after (cadr paren-state)) ?\[)) - (throw 'found-cand (cadr paren-state))) - (setq paren-state (cdr paren-state))))) - (and cand - (not - (and (c-go-list-forward cand) - (eq (char-before) ?\]) - (eq (char-before (1- (point))) ?\]))))) - (setq paren-state (cdr paren-state))) - (and cand (cons cand (point))))))) + (and + (progn + (skip-chars-backward "^[;{}" lim) + (eq (char-before) ?\[)) + (not (eq (char-before (1- (point))) ?\[)) + (> (point) lim)) + (backward-char)) + (and (eq (char-before) ?\[) + (eq (char-before (1- (point))) ?\[) + (progn (backward-char 2) t) + (setq cand (point)) + (c-go-list-forward nil (min (+ (point) 200) (point-max))) + (eq (char-before) ?\]) + (eq (char-before (1- (point))) ?\]) + (not (c-literal-limits)) + (cons cand (point))))))) (defun c-invalidate-sws-region-before (beg end) ;; Called from c-before-change. BEG and END are the bounds of the change @@ -2988,9 +2983,7 @@ comment at the start of cc-engine.el for more info." c-block-comment-awkward-chars))) (and (nth 4 s) (nth 7 s) ; Line comment (not (memq (char-before here) '(?\\ ?\n))))))) - (c-with-extended-string-fences - pos here - (setq s (parse-partial-sexp pos here nil nil s)))) + (setq s (parse-partial-sexp pos here nil nil s))) (when (not (eq near-pos here)) (c-semi-put-near-cache-entry here s)) (cond @@ -3122,7 +3115,7 @@ comment at the start of cc-engine.el for more info." (not base) ; FIXME!!! Compare base and far-base?? ; (2019-05-21) (not end) - (> here end)) + (>= here end)) (progn (setq far-base-and-state (c-parse-ps-state-below here) far-base (car far-base-and-state) @@ -3135,7 +3128,7 @@ comment at the start of cc-engine.el for more info." (or (and (> here base) (null end)) (null (nth 8 s)) - (and end (> here end)) + (and end (>= here end)) (not (or (and (nth 3 s) ; string @@ -3194,6 +3187,24 @@ comment at the start of cc-engine.el for more info." c-semi-near-cache-limit (min c-semi-near-cache-limit pos) c-full-near-cache-limit (min c-full-near-cache-limit pos))) +(defun c-foreign-truncate-lit-pos-cache (beg _end) + "Truncate CC Mode's literal cache. + +This function should be added to the `before-change-functions' +hook by major modes that use CC Mode's filling functionality +without initializing CC Mode. Currently (2020-06) these are +js-mode and mhtml-mode." + (c-truncate-lit-pos-cache beg)) + +(defun c-foreign-init-lit-pos-cache () + "Initialize CC Mode's literal cache. + +This function should be called from the mode functions of major +modes which use CC Mode's filling functionality without +initializing CC Mode. Currently (2020-06) these are js-mode and +mhtml-mode." + (c-truncate-lit-pos-cache 1)) + ;; A system for finding noteworthy parens before the point. @@ -11685,7 +11696,16 @@ comment at the start of cc-engine.el for more info." (not (c-in-literal)) )))) nil) - (t t)))))) + (t t))))) + ((and + (c-major-mode-is 'c++-mode) + (eq (char-after) ?\[) + ;; Be careful of "operator []" + (not (save-excursion + (c-backward-token-2 1 nil lim) + (looking-at c-opt-op-identifier-prefix)))) + (setq braceassignp t) + nil)) (when (eq braceassignp 'dontknow) (cond ((and (not (eq (char-after) ?,)) @@ -11876,17 +11896,6 @@ comment at the start of cc-engine.el for more info." (cons (list beg) type))))) (error nil)))) -(defun c-looking-at-bos (&optional _lim) - ;; Return non-nil if between two statements or declarations, assuming - ;; point is not inside a literal or comment. - ;; - ;; Obsolete - `c-at-statement-start-p' or `c-at-expression-start-p' - ;; are recommended instead. - ;; - ;; This function might do hidden buffer changes. - (c-at-statement-start-p)) -(make-obsolete 'c-looking-at-bos 'c-at-statement-start-p "22.1") - (defun c-looking-at-statement-block () ;; Point is at an opening brace. If this is a statement block (i.e. the ;; elements in the block are terminated by semicolons, or the block is @@ -12057,7 +12066,7 @@ comment at the start of cc-engine.el for more info." (c-backward-token-2 1 nil lim) (and (not (and (c-on-identifier) - (looking-at c-symbol-chars))) + (looking-at c-symbol-char-key))) (not (looking-at c-opt-op-identifier-prefix))))))) (cons 'inlambda bracket-pos)) ((and c-recognize-paren-inexpr-blocks diff --git a/lisp/progmodes/cc-fonts.el b/lisp/progmodes/cc-fonts.el index 2cbbc66c14f..386cc2f16fe 100644 --- a/lisp/progmodes/cc-fonts.el +++ b/lisp/progmodes/cc-fonts.el @@ -3016,6 +3016,84 @@ need for `pike-font-lock-extra-types'.") (c-font-lock-doc-comments "/[*/]!" limit autodoc-font-lock-doc-comments))))) +;; Doxygen + +(defconst doxygen-font-lock-doc-comments + ;; TODO: Handle @code, @verbatim, @dot, @f etc. better by not highlighting + ;; text inside of those commands. Something smarter than just regexes may be + ;; needed to do that efficiently. + `((,(concat + ;; Make sure that the special character has not been escaped. E.g. in + ;; `\@foo' only `\@' is a command (similarly for other characters like + ;; `\\foo', `\<foo' and `\&foo'). The downside now is that we don't + ;; match command started just after an escaped character, e.g. in + ;; `\@\foo' we should match `\@' as well as `\foo' but only the former + ;; is matched. + "\\(?:^\\|[^\\@]\\)\\(" + ;; Doxygen commands start with backslash or an at sign. Note that for + ;; brevity in the comments only `\' will be mentioned. + "[\\@]\\(?:" + ;; Doxygen commands except those starting with `f' + "[a-eg-z][a-z]*" + ;; Doxygen command starting with `f': + "\\|f\\(?:" + "[][$}]" ; \f$ \f} \f[ \f] + "\\|{\\(?:[a-zA-Z]+\\*?}{?\\)?" ; \f{ \f{env} \f{env}{ + "\\|[a-z]+" ; \foo + "\\)" + "\\|~[a-zA-Z]*" ; \~ \~language + "\\|[$@&~<=>#%\".|\\\\]" ; single-character escapes + "\\|::\\|---?" ; \:: \-- \--- + "\\)" + ;; HTML tags and entities: + "\\|</?\\sw\\(?:\\sw\\|\\s \\|[=\n\r*.:]\\|\"[^\"]*\"\\|'[^']*'\\)*>" + "\\|&\\(?:\\sw+\\|#[0-9]+\\|#x[0-9a-fA-F]+\\);" + "\\)") + 1 ,c-doc-markup-face-name prepend nil) + ;; Commands inside of strings are not commands so override highlighting with + ;; string face. This also affects HTML attribute values if they are + ;; surrounded with double quotes which may or may not be considered a good + ;; thing. + ("\\(?:^\\|[^\\@]\\)\\(\"[^\"[:cntrl:]]+\"\\)" + 1 font-lock-string-face prepend nil) + ;; HTML comments inside of the Doxygen comments. + ("\\(?:^\\|[^\\@]\\)\\(<!--.*?-->\\)" + 1 font-lock-comment-face prepend nil) + ;; Autolinking. Doxygen auto-links anything that is a class name but we have + ;; no hope of matching those. We are, however, able to match functions and + ;; members using explicit scoped syntax. For functions, we can also find + ;; them by noticing argument-list. Note that Doxygen accepts `::' as well + ;; as `#' as scope operators. + (,(let* ((ref "[\\@]ref\\s-+") + (ref-opt (concat "\\(?:" ref "\\)?")) + (id "[a-zA-Z_][a-zA-Z_0-9]*") + (args "\\(?:()\\|([^()]*)\\)") + (scope "\\(?:#\\|::\\)")) + (concat + "\\(?:^\\|[^\\@/%:]\\)\\(?:" + ref-opt "\\(?1:" scope "?" "\\(?:" id scope "\\)+" "~?" id "\\)" + "\\|" ref-opt "\\(?1:" scope "~?" id "\\)" + "\\|" ref-opt "\\(?1:" scope "?" "~?" id "\\)" args + "\\|" ref "\\(?1:" "~?" id "\\)" + "\\|" ref-opt "\\(?1:~[A-Z][a-zA-Z0-9_]+\\)" + "\\)")) + 1 font-lock-function-name-face prepend nil) + ;; Match URLs and emails. This has two purposes. First of all, Doxygen + ;; autolinks URLs. Second of all, `@bar' in `foo@bar.baz' has been matched + ;; above as a command; try and overwrite it. + (,(let* ((host "[A-Za-z0-9]\\(?:[A-Za-z0-9-]\\{0,61\\}[A-Za-z0-9]\\)") + (fqdn (concat "\\(?:" host "\\.\\)+" host)) + (comp "[!-(*--/-=?-~]+") + (path (concat "/\\(?:" comp "[.]+" "\\)*" comp))) + (concat "\\(?:mailto:\\)?[a-zA-0_.]+@" fqdn + "\\|https?://" fqdn "\\(?:" path "\\)?")) + 0 font-lock-keyword-face prepend nil))) + +(defconst doxygen-font-lock-keywords + `((,(lambda (limit) + (c-font-lock-doc-comments "/\\(?:/[/!]\\|\\*[\\*!]\\)" + limit doxygen-font-lock-doc-comments))))) + ;; 2006-07-10: awk-font-lock-keywords has been moved back to cc-awk.el. (cc-provide 'cc-fonts) diff --git a/lisp/progmodes/cc-langs.el b/lisp/progmodes/cc-langs.el index e7e7cfd4b09..b77bf3303b6 100644 --- a/lisp/progmodes/cc-langs.el +++ b/lisp/progmodes/cc-langs.el @@ -1174,7 +1174,7 @@ since CC Mode treats every identifier as an expression." ;; Exception. ,@(when (c-major-mode-is 'c++-mode) - '((prefix "throw"))) + '((prefix "throw" "co_await" "co_yield"))) ;; Sequence. (left-assoc ",")) @@ -1769,7 +1769,7 @@ ender." `comment-start-skip' is initialized from this." ;; Default: Allow the last char of the comment starter(s) to be ;; repeated, then allow any amount of horizontal whitespace. - t (concat "\\(" + t (concat "\\(?:" (c-concat-separated (mapcar (lambda (cs) (when cs @@ -2040,6 +2040,7 @@ the appropriate place for that." (c-lang-defconst c-return-kwds "Keywords which return a value to the calling function." t '("return") + c++ '("return" "co_return") idl nil) (c-lang-defconst c-return-key @@ -2415,7 +2416,8 @@ If any of these also are on `c-type-list-kwds', `c-ref-list-kwds', `c-<>-type-kwds', or `c-<>-arglist-kwds' then the associated clauses will be handled." t nil - objc '("@class" "@end" "@defs") + objc '("@class" "@defs" "@end" "@property" "@dynamic" "@synthesize" + "@compatibility_alias") java '("import" "package") pike '("import" "inherit")) @@ -2538,7 +2540,8 @@ one of `c-type-list-kwds', `c-ref-list-kwds', "Access protection label keywords in classes." t nil c++ '("private" "protected" "public") - objc '("@private" "@protected" "@public")) + objc '("@private" "@protected" "@package" "@public" + "@required" "@optional")) (c-lang-defconst c-protection-key ;; A regexp match an element of `c-protection-kwds' cleanly. @@ -2753,7 +2756,7 @@ identifiers that follows the type in a normal declaration." "Statement keywords followed directly by a substatement." t '("do" "else") c++ '("do" "else" "try") - objc '("do" "else" "@finally" "@try") + objc '("do" "else" "@finally" "@try" "@autoreleasepool") java '("do" "else" "finally" "try") idl nil) @@ -2783,7 +2786,7 @@ Keywords here should also be in `c-block-stmt-1-kwds'." java '("for" "if" "switch" "while" "catch" "synchronized") idl nil pike '("for" "if" "switch" "while" "foreach") - awk '("for" "if" "while")) + awk '("for" "if" "switch" "while")) (c-lang-defconst c-block-stmt-2-key ;; Regexp matching the start of any statement followed by a paren sexp @@ -2822,6 +2825,7 @@ Keywords here should also be in `c-block-stmt-1-kwds'." (c-lang-defconst c-simple-stmt-kwds "Statement keywords followed by an expression or nothing." t '("break" "continue" "goto" "return") + c++ '("break" "continue" "goto" "return" "co_return") objc '("break" "continue" "goto" "return" "@throw") ;; Note: `goto' is not valid in Java, but the keyword is still reserved. java '("break" "continue" "goto" "return" "throw") @@ -2862,8 +2866,7 @@ nevertheless contains a list separated with `;' and not `,'." (c-lang-defconst c-case-kwds "The keyword(s) which introduce a \"case\" like construct. This construct is \"<keyword> <expression> :\"." - t '("case") - awk nil) + t '("case")) (c-lang-defconst c-case-kwds-regexp ;; Adorned regexp matching any "case"-like keyword. @@ -2895,7 +2898,8 @@ This construct is \"<keyword> <expression> :\"." c++ (append '("nullptr") (c-lang-const c-constant-kwds c)) - objc '("nil" "Nil" "YES" "NO" "NS_DURING" "NS_HANDLER" "NS_ENDHANDLER") + objc '("nil" "Nil" "YES" "NO" "IBAction" "IBOutlet" + "NS_DURING" "NS_HANDLER" "NS_ENDHANDLER") idl '("TRUE" "FALSE") java '("true" "false" "null") ; technically "literals", not keywords pike '("UNDEFINED")) ;; Not a keyword, but practically works as one. @@ -3030,7 +3034,14 @@ Note that Java specific rules are currently applied to tell this from ;; can start a declaration.) "entity" "process" "service" "session" "storage")) - +(c-lang-defconst c-std-abbrev-keywords + "List of keywords which may need to cause electric indentation." + t '("else" "while") + c++ (append (c-lang-const c-std-abbrev-keywords) '("catch")) + java (append (c-lang-const c-std-abbrev-keywords) '("catch" "finally")) + idl nil) +(c-lang-defvar c-std-abbrev-keywords (c-lang-const c-std-abbrev-keywords)) + ;;; Constants built from keywords. ;; Note: No `*-kwds' language constants may be defined below this point. @@ -3405,8 +3416,14 @@ regexp should match \"(\" if parentheses are valid in declarators. The end of the first submatch is taken as the end of the operator. Identifier syntax is in effect when this is matched (see `c-identifier-syntax-table')." - t (if (c-lang-const c-type-modifier-kwds) - (concat (regexp-opt (c-lang-const c-type-modifier-kwds) t) "\\>") + t (if (or (c-lang-const c-type-modifier-kwds) (c-lang-const c-modifier-kwds)) + (concat + (regexp-opt (c--delete-duplicates + (append (c-lang-const c-type-modifier-kwds) + (c-lang-const c-modifier-kwds)) + :test 'string-equal) + t) + "\\>") ;; Default to a regexp that never matches. regexp-unmatchable) ;; Check that there's no "=" afterwards to avoid matching tokens diff --git a/lisp/progmodes/cc-mode.el b/lisp/progmodes/cc-mode.el index 066bec60091..81bcd101fe4 100644 --- a/lisp/progmodes/cc-mode.el +++ b/lisp/progmodes/cc-mode.el @@ -278,6 +278,29 @@ control). See \"cc-mode.el\" for more info." (setq defs (cdr defs))))) (put 'c-define-abbrev-table 'lisp-indent-function 1) +(defun c-populate-abbrev-table () + ;; Insert the standard keywords which may need electric indentation into the + ;; current mode's abbreviation table. + (let ((table (intern (concat (symbol-name major-mode) "-abbrev-table"))) + (defs c-std-abbrev-keywords) + ) + (unless (and (boundp table) + (abbrev-table-p (symbol-value table))) + (define-abbrev-table table nil)) + (setq local-abbrev-table (symbol-value table)) + (while defs + (unless (intern-soft (car defs) local-abbrev-table) ; Don't overwrite the + ; abbrev's use count. + (condition-case nil + (define-abbrev (symbol-value table) + (car defs) (car defs) + 'c-electric-continued-statement 0 t) + (wrong-number-of-arguments + (define-abbrev (symbol-value table) + (car defs) (car defs) + 'c-electric-continued-statement 0)))) + (setq defs (cdr defs))))) + (defun c-bind-special-erase-keys () ;; Only used in Emacs to bind C-c C-<delete> and C-c C-<backspace> ;; to the proper keys depending on `normal-erase-is-backspace'. @@ -535,6 +558,18 @@ preferably use the `c-mode-menu' language constant directly." ;; and `after-change-functions'. Note that this variable is not set when ;; `c-before-change' is invoked by a change to text properties. +(defvar c-min-syn-tab-mkr nil) +;; The minimum buffer position where there's a `c-fl-syn-tab' text property, +;; or nil if there aren't any. This is a marker, or nil if there's currently +;; no such text property. +(make-variable-buffer-local 'c-min-syn-tab-mkr) + +(defvar c-max-syn-tab-mkr nil) +;; The maximum buffer position plus 1 where there's a `c-fl-syn-tab' text +;; property, or nil if there aren't any. This is a marker, or nil if there's +;; currently no such text property. +(make-variable-buffer-local 'c-max-syn-tab-mkr) + (defun c-basic-common-init (mode default-style) "Do the necessary initialization for the syntax handling routines and the line breaking/filling code. Intended to be used by other @@ -550,6 +585,8 @@ that requires a literal mode spec at compile time." (setq c-buffer-is-cc-mode mode) + (c-populate-abbrev-table) + ;; these variables should always be buffer local; they do not affect ;; indentation style. (make-local-variable 'comment-start) @@ -606,6 +643,10 @@ that requires a literal mode spec at compile time." ;; Initialize the "brace stack" cache. (c-init-bs-cache) + ;; Keep track of where `c-fl-syn-tab' text properties are set. + (setq c-min-syn-tab-mkr nil) + (setq c-max-syn-tab-mkr nil) + (when (or c-recognize-<>-arglists (c-major-mode-is 'awk-mode) (c-major-mode-is '(java-mode c-mode c++-mode objc-mode pike-mode))) @@ -1207,52 +1248,94 @@ Note that the style variables are always made local to the buffer." (c-put-char-property (1- (point)) 'syntax-table '(15))) (t nil))))) -(defvar c-fl-syn-tab-region nil) - ;; Non-nil when a `c-restore-string-fences' is "in force". It's value is a - ;; cons of the BEG and END of the region currently "mirroring" the - ;; c-fl-syn-tab properties as syntax-table properties. +(defun c-put-syn-tab (pos value) + ;; Set both the syntax-table and the c-fl-syn-tab text properties at POS to + ;; VALUE (which should not be nil). + ;; `(let ((-pos- ,pos) + ;; (-value- ,value)) + (c-put-char-property pos 'syntax-table value) + (c-put-char-property pos 'c-fl-syn-tab value) + (cond + ((null c-min-syn-tab-mkr) + (setq c-min-syn-tab-mkr (copy-marker pos t))) + ((< pos c-min-syn-tab-mkr) + (move-marker c-min-syn-tab-mkr pos))) + (cond + ((null c-max-syn-tab-mkr) + (setq c-max-syn-tab-mkr (copy-marker (1+ pos) nil))) + ((>= pos c-max-syn-tab-mkr) + (move-marker c-max-syn-tab-mkr (1+ pos)))) + (c-truncate-lit-pos-cache pos)) + +(defun c-clear-syn-tab (pos) + ;; Remove both the 'syntax-table and `c-fl-syn-tab properties at POS. + (c-clear-char-property pos 'syntax-table) + (c-clear-char-property pos 'c-fl-syn-tab) + (when c-min-syn-tab-mkr + (if (and (eq pos (marker-position c-min-syn-tab-mkr)) + (eq (1+ pos) (marker-position c-max-syn-tab-mkr))) + (progn + (move-marker c-min-syn-tab-mkr nil) + (move-marker c-max-syn-tab-mkr nil) + (setq c-min-syn-tab-mkr nil c-max-syn-tab-mkr nil)) + (when (eq pos (marker-position c-min-syn-tab-mkr)) + (move-marker c-min-syn-tab-mkr + (if (c-get-char-property (1+ pos) 'c-fl-syn-tab) + (1+ pos) + (c-next-single-property-change + (1+ pos) 'c-fl-syn-tab nil c-max-syn-tab-mkr)))) + (when (eq (1+ pos) (marker-position c-max-syn-tab-mkr)) + (move-marker c-max-syn-tab-mkr + (if (c-get-char-property (1- pos) 'c-fl-syn-tab) + pos + (c-previous-single-property-change + pos 'c-fl-syn-tab nil (1+ c-min-syn-tab-mkr))))))) + (c-truncate-lit-pos-cache pos)) (defun c-clear-string-fences () - ;; Clear syntax-table text properties in the region defined by - ;; `c-cl-syn-tab-region' which are "mirrored" by c-fl-syn-tab text - ;; properties. However, any such " character which ends up not being + ;; Clear syntax-table text properties which are "mirrored" by c-fl-syn-tab + ;; text properties. However, any such " character which ends up not being ;; balanced by another " is left with a '(1) syntax-table property. - (when c-fl-syn-tab-region - (let ((beg (car c-fl-syn-tab-region)) - (end (cdr c-fl-syn-tab-region)) - s pos) - (setq pos beg) + (when + (and c-min-syn-tab-mkr c-max-syn-tab-mkr) + (let (s pos) + (setq pos c-min-syn-tab-mkr) (while (and - (< pos end) - (setq pos - (c-min-property-position pos end 'c-fl-syn-tab)) - (< pos end)) + (< pos c-max-syn-tab-mkr) + (setq pos (c-min-property-position pos + c-max-syn-tab-mkr + 'c-fl-syn-tab)) + (< pos c-max-syn-tab-mkr)) (c-clear-char-property pos 'syntax-table) (setq pos (1+ pos))) ;; Check we haven't left any unbalanced "s. (save-excursion - (setq pos beg) + (setq pos c-min-syn-tab-mkr) ;; Is there already an unbalanced " before BEG? - (setq pos (c-min-property-position pos end 'c-fl-syn-tab)) - (when (< pos end) (goto-char pos)) + (setq pos (c-min-property-position pos c-max-syn-tab-mkr + 'c-fl-syn-tab)) + (when (< pos c-max-syn-tab-mkr) + (goto-char pos)) (when (and (save-match-data (c-search-backward-char-property-with-value-on-char 'c-fl-syn-tab '(15) ?\" (max (- (point) 500) (point-min)))) (not (equal (c-get-char-property (point) 'syntax-table) '(1)))) (setq pos (1+ pos))) - (while (< pos end) + (while (< pos c-max-syn-tab-mkr) (setq pos - (c-min-property-position pos end 'c-fl-syn-tab)) - (when (< pos end) + (c-min-property-position pos c-max-syn-tab-mkr 'c-fl-syn-tab)) + (when (< pos c-max-syn-tab-mkr) (if (memq (char-after pos) c-string-delims) (progn ;; Step over the ". - (setq s (parse-partial-sexp pos end nil nil nil + (setq s (parse-partial-sexp pos c-max-syn-tab-mkr + nil nil nil 'syntax-table)) ;; Seek a (bogus) matching ". - (setq s (parse-partial-sexp (point) end nil nil s + (setq s (parse-partial-sexp (point) c-max-syn-tab-mkr + nil nil s 'syntax-table)) ;; When a bogus matching " is found, do nothing. ;; Otherwise mark the " with 'syntax-table '(1). @@ -1262,23 +1345,22 @@ Note that the style variables are always made local to the buffer." (c-get-char-property (1- (point)) 'c-fl-syn-tab)) (c-put-char-property pos 'syntax-table '(1))) (setq pos (point))) - (setq pos (1+ pos)))))) - (setq c-fl-syn-tab-region nil)))) - -(defun c-restore-string-fences (beg end) - ;; Restore any syntax-table text properties in the region (BEG END) which - ;; are "mirrored" by c-fl-syn-tab text properties. - (let ((pos beg)) - (while - (and - (< pos end) - (setq pos - (c-min-property-position pos end 'c-fl-syn-tab)) - (< pos end)) - (c-put-char-property pos 'syntax-table - (c-get-char-property pos 'c-fl-syn-tab)) - (setq pos (1+ pos))) - (setq c-fl-syn-tab-region (cons beg end)))) + (setq pos (1+ pos))))))))) + +(defun c-restore-string-fences () + ;; Restore any syntax-table text properties which are "mirrored" by + ;; c-fl-syn-tab text properties. + (when (and c-min-syn-tab-mkr c-max-syn-tab-mkr) + (let ((pos c-min-syn-tab-mkr)) + (while + (and + (< pos c-max-syn-tab-mkr) + (setq pos + (c-min-property-position pos c-max-syn-tab-mkr 'c-fl-syn-tab)) + (< pos c-max-syn-tab-mkr)) + (c-put-char-property pos 'syntax-table + (c-get-char-property pos 'c-fl-syn-tab)) + (setq pos (1+ pos)))))) (defvar c-bc-changed-stringiness nil) ;; Non-nil when, in a before-change function, the deletion of a range of text @@ -1406,7 +1488,7 @@ Note that the style variables are always made local to the buffer." ;; Move to end of logical line (as it will be after the change, or as it ;; was before unescaping a NL.) - (re-search-forward "\\(\\\\\\(.\\|\n\\)\\|[^\\\n\r]\\)*" nil t) + (re-search-forward "\\(?:\\\\\\(?:.\\|\n\\)\\|[^\\\n\r]\\)*" nil t) ;; We're at an EOLL or point-max. (if (equal (c-get-char-property (point) 'syntax-table) '(15)) (if (memq (char-after) '(?\n ?\r)) @@ -1514,7 +1596,7 @@ Note that the style variables are always made local to the buffer." (progn (goto-char (min (1+ end) ; 1+, in case a NL has become escaped. (point-max))) - (re-search-forward "\\(\\\\\\(.\\|\n\\)\\|[^\\\n\r]\\)*" + (re-search-forward "\\(?:\\\\\\(?:.\\|\n\\)\\|[^\\\n\r]\\)*" nil t) (point)) c-new-END)) @@ -1595,7 +1677,7 @@ Note that the style variables are always made local to the buffer." (c-beginning-of-macro)))) (goto-char (1+ end)) ; After the \ ;; Search forward for EOLL - (setq lim (re-search-forward "\\(\\\\\\(.\\|\n\\)\\|[^\\\n\r]\\)*" + (setq lim (re-search-forward "\\(?:\\\\\\(?:.\\|\n\\)\\|[^\\\n\r]\\)*" nil t)) (goto-char (1+ end)) (when (c-search-forward-char-property-with-value-on-char @@ -1888,7 +1970,7 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") (widen) (unwind-protect (progn - (c-restore-string-fences (point-min) (point-max)) + (c-restore-string-fences) (save-excursion ;; Are we inserting/deleting stuff in the middle of an ;; identifier? @@ -2018,7 +2100,7 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") (widen) (unwind-protect (progn - (c-restore-string-fences (point-min) (point-max)) + (c-restore-string-fences) (when (> end (point-max)) ;; Some emacsen might return positions past the end. This ;; has been observed in Emacs 20.7 when rereading a buffer @@ -2183,7 +2265,7 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") enclosing-attribute pos1) (unless lit-start (c-backward-syntactic-ws) - (when (setq enclosing-attribute (c-slow-enclosing-c++-attribute)) + (when (setq enclosing-attribute (c-enclosing-c++-attribute)) (goto-char (car enclosing-attribute))) ; Only happens in C++ Mode. (when (setq pos1 (c-on-identifier)) (goto-char pos1) @@ -2255,69 +2337,48 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") ;; line was fouled up by context fontification. (save-restriction (widen) - (let (new-beg new-end new-region case-fold-search string-fence-beg lim) - ;; Check how far back we need to extend the region where we reapply the - ;; string fence syntax-table properties. These must be in place for the - ;; coming fontification operations. - (save-excursion - (goto-char (if c-in-after-change-fontification - (min beg c-new-BEG) - beg)) - (setq lim (max (- (point) 500) (point-min))) - (while + (let (new-beg new-end new-region case-fold-search) + (c-save-buffer-state nil + ;; Temporarily reapply the string fence syntax-table properties. + (unwind-protect (progn - (skip-chars-backward "^\"" lim) - (or (bobp) (backward-char)) - (save-excursion - (eq (logand (skip-chars-backward "\\\\") 1) 1)))) - (setq string-fence-beg - (cond ((c-get-char-property (point) 'c-fl-syn-tab) - (point)) - (c-in-after-change-fontification - c-new-BEG) - (t beg))) - (c-save-buffer-state nil - ;; Temporarily reapply the string fence syntax-table properties. - (c-with-extended-string-fences - string-fence-beg (if c-in-after-change-fontification - (max end c-new-END) - end) - - (if (and c-in-after-change-fontification - (< beg c-new-END) (> end c-new-BEG)) - ;; Region and the latest after-change fontification region overlap. - ;; Determine the upper and lower bounds of our adjusted region - ;; separately. - (progn - (if (<= beg c-new-BEG) - (setq c-in-after-change-fontification nil)) - (setq new-beg - (if (and (>= beg (c-point 'bol c-new-BEG)) - (<= beg c-new-BEG)) - ;; Either jit-lock has accepted `c-new-BEG', or has - ;; (probably) extended the change region spuriously - ;; to BOL, which position likely has a - ;; syntactically different position. To ensure - ;; correct fontification, we start at `c-new-BEG', - ;; assuming any characters to the left of - ;; `c-new-BEG' on the line do not require - ;; fontification. - c-new-BEG - (setq new-region (c-before-context-fl-expand-region beg end) - new-end (cdr new-region)) - (car new-region))) - (setq new-end - (if (and (>= end (c-point 'bol c-new-END)) - (<= end c-new-END)) - c-new-END - (or new-end - (cdr (c-before-context-fl-expand-region beg end)))))) - ;; Context (etc.) fontification. - (setq new-region (c-before-context-fl-expand-region beg end) - new-beg (car new-region) new-end (cdr new-region))) - ;; Finally invoke font lock's functionality. - (funcall (default-value 'font-lock-fontify-region-function) - new-beg new-end verbose))))))) + (c-restore-string-fences) + (if (and c-in-after-change-fontification + (< beg c-new-END) (> end c-new-BEG)) + ;; Region and the latest after-change fontification region overlap. + ;; Determine the upper and lower bounds of our adjusted region + ;; separately. + (progn + (if (<= beg c-new-BEG) + (setq c-in-after-change-fontification nil)) + (setq new-beg + (if (and (>= beg (c-point 'bol c-new-BEG)) + (<= beg c-new-BEG)) + ;; Either jit-lock has accepted `c-new-BEG', or has + ;; (probably) extended the change region spuriously + ;; to BOL, which position likely has a + ;; syntactically different position. To ensure + ;; correct fontification, we start at `c-new-BEG', + ;; assuming any characters to the left of + ;; `c-new-BEG' on the line do not require + ;; fontification. + c-new-BEG + (setq new-region (c-before-context-fl-expand-region beg end) + new-end (cdr new-region)) + (car new-region))) + (setq new-end + (if (and (>= end (c-point 'bol c-new-END)) + (<= end c-new-END)) + c-new-END + (or new-end + (cdr (c-before-context-fl-expand-region beg end)))))) + ;; Context (etc.) fontification. + (setq new-region (c-before-context-fl-expand-region beg end) + new-beg (car new-region) new-end (cdr new-region))) + ;; Finally invoke font lock's functionality. + (funcall (default-value 'font-lock-fontify-region-function) + new-beg new-end verbose)) + (c-clear-string-fences)))))) (defun c-after-font-lock-init () ;; Put on `font-lock-mode-hook'. This function ensures our after-change @@ -2444,11 +2505,6 @@ opening \" and the next unescaped end of line." (funcall (c-lang-const c-make-mode-syntax-table c)) "Syntax table used in c-mode buffers.") -(c-define-abbrev-table 'c-mode-abbrev-table - '(("else" "else" c-electric-continued-statement 0) - ("while" "while" c-electric-continued-statement 0)) - "Abbreviation table used in c-mode buffers.") - (defvar c-mode-map (let ((map (c-make-inherited-keymap))) map) @@ -2521,13 +2577,21 @@ Key bindings: (defconst c-or-c++-mode--regexp (eval-when-compile - (let ((id "[a-zA-Z0-9_]+") (ws "[ \t\r]+") (ws-maybe "[ \t\r]*")) + (let ((id "[a-zA-Z_][a-zA-Z0-9_]*") (ws "[ \t]+") (ws-maybe "[ \t]*") + (headers '("string" "string_view" "iostream" "map" "unordered_map" + "set" "unordered_set" "vector" "tuple"))) (concat "^" ws-maybe "\\(?:" - "using" ws "\\(?:namespace" ws "std;\\|std::\\)" - "\\|" "namespace" "\\(:?" ws id "\\)?" ws-maybe "{" - "\\|" "class" ws id ws-maybe "[:{\n]" - "\\|" "template" ws-maybe "<.*>" - "\\|" "#include" ws-maybe "<\\(?:string\\|iostream\\|map\\)>" + "using" ws "\\(?:namespace" ws + "\\|" id "::" + "\\|" id ws-maybe "=\\)" + "\\|" "\\(?:inline" ws "\\)?namespace" + "\\(:?" ws "\\(?:" id "::\\)*" id "\\)?" ws-maybe "{" + "\\|" "class" ws id + "\\(?:" ws "final" "\\)?" ws-maybe "[:{;\n]" + "\\|" "struct" ws id "\\(?:" ws "final" ws-maybe "[:{\n]" + "\\|" ws-maybe ":\\)" + "\\|" "template" ws-maybe "<.*?>" + "\\|" "#include" ws-maybe "<" (regexp-opt headers) ">" "\\)"))) "A regexp applied to C header files to check if they are really C++.") @@ -2543,6 +2607,7 @@ should be used. This function attempts to use file contents to determine whether the code is C or C++ and based on that chooses whether to enable `c-mode' or `c++-mode'." + (interactive) (if (save-excursion (save-restriction (save-match-data @@ -2560,12 +2625,6 @@ the code is C or C++ and based on that chooses whether to enable (funcall (c-lang-const c-make-mode-syntax-table c++)) "Syntax table used in c++-mode buffers.") -(c-define-abbrev-table 'c++-mode-abbrev-table - '(("else" "else" c-electric-continued-statement 0) - ("while" "while" c-electric-continued-statement 0) - ("catch" "catch" c-electric-continued-statement 0)) - "Abbreviation table used in c++-mode buffers.") - (defvar c++-mode-map (let ((map (c-make-inherited-keymap))) map) @@ -2614,11 +2673,6 @@ Key bindings: (funcall (c-lang-const c-make-mode-syntax-table objc)) "Syntax table used in objc-mode buffers.") -(c-define-abbrev-table 'objc-mode-abbrev-table - '(("else" "else" c-electric-continued-statement 0) - ("while" "while" c-electric-continued-statement 0)) - "Abbreviation table used in objc-mode buffers.") - (defvar objc-mode-map (let ((map (c-make-inherited-keymap))) map) @@ -2665,13 +2719,6 @@ Key bindings: (funcall (c-lang-const c-make-mode-syntax-table java)) "Syntax table used in java-mode buffers.") -(c-define-abbrev-table 'java-mode-abbrev-table - '(("else" "else" c-electric-continued-statement 0) - ("while" "while" c-electric-continued-statement 0) - ("catch" "catch" c-electric-continued-statement 0) - ("finally" "finally" c-electric-continued-statement 0)) - "Abbreviation table used in java-mode buffers.") - (defvar java-mode-map (let ((map (c-make-inherited-keymap))) map) @@ -2683,7 +2730,7 @@ Key bindings: ;; since it's practically impossible to write a regexp that reliably ;; matches such a construct. Other tools are necessary. (defconst c-Java-defun-prompt-regexp - "^[ \t]*\\(\\(\\(public\\|protected\\|private\\|const\\|abstract\\|synchronized\\|final\\|static\\|threadsafe\\|transient\\|native\\|volatile\\)\\s-+\\)*\\(\\(\\([[a-zA-Z][][_$.a-zA-Z0-9]*[][_$.a-zA-Z0-9]+\\|[[a-zA-Z]\\)\\s-*\\)\\s-+\\)\\)?\\(\\([[a-zA-Z][][_$.a-zA-Z0-9]*\\s-+\\)\\s-*\\)?\\([_a-zA-Z][^][ \t:;.,{}()\^?=]*\\|\\([_$a-zA-Z][_$.a-zA-Z0-9]*\\)\\)\\s-*\\(([^);{}]*)\\)?\\([] \t]*\\)\\(\\s-*\\<throws\\>\\s-*\\(\\([_$a-zA-Z][_$.a-zA-Z0-9]*\\)[, \t\n\r\f\v]*\\)+\\)?\\s-*") + "^[ \t]*\\(\\(\\(public\\|protected\\|private\\|const\\|abstract\\|synchronized\\|final\\|static\\|threadsafe\\|transient\\|native\\|volatile\\)\\s-+\\)*\\(\\(\\([[a-zA-Z][][_$.a-zA-Z0-9]+\\|[[a-zA-Z]\\)\\s-*\\)\\s-+\\)\\)?\\(\\([[a-zA-Z][][_$.a-zA-Z0-9]*\\s-+\\)\\s-*\\)?\\([_a-zA-Z][^][ \t:;.,{}()\^?=]*\\|\\([_$a-zA-Z][_$.a-zA-Z0-9]*\\)\\)\\s-*\\(([^);{}]*)\\)?\\([] \t]*\\)\\(\\s-*\\<throws\\>\\s-*\\(\\([_$a-zA-Z][_$.a-zA-Z0-9]*\\)[, \t\n\r\f\v]*\\)+\\)?\\s-*") (easy-menu-define c-java-menu java-mode-map "Java Mode Commands" (cons "Java" (c-lang-const c-mode-menu java))) @@ -2722,9 +2769,6 @@ Key bindings: (funcall (c-lang-const c-make-mode-syntax-table idl)) "Syntax table used in idl-mode buffers.") -(c-define-abbrev-table 'idl-mode-abbrev-table nil - "Abbreviation table used in idl-mode buffers.") - (defvar idl-mode-map (let ((map (c-make-inherited-keymap))) map) @@ -2767,11 +2811,6 @@ Key bindings: (funcall (c-lang-const c-make-mode-syntax-table pike)) "Syntax table used in pike-mode buffers.") -(c-define-abbrev-table 'pike-mode-abbrev-table - '(("else" "else" c-electric-continued-statement 0) - ("while" "while" c-electric-continued-statement 0)) - "Abbreviation table used in pike-mode buffers.") - (defvar pike-mode-map (let ((map (c-make-inherited-keymap))) map) @@ -2819,11 +2858,6 @@ Key bindings: ;;;###autoload (add-to-list 'interpreter-mode-alist '("nawk" . awk-mode)) ;;;###autoload (add-to-list 'interpreter-mode-alist '("gawk" . awk-mode)) -(c-define-abbrev-table 'awk-mode-abbrev-table - '(("else" "else" c-electric-continued-statement 0) - ("while" "while" c-electric-continued-statement 0)) - "Abbreviation table used in awk-mode buffers.") - (defvar awk-mode-map (let ((map (c-make-inherited-keymap))) map) diff --git a/lisp/progmodes/cc-vars.el b/lisp/progmodes/cc-vars.el index 556ff6059f1..b885f6ae1d8 100644 --- a/lisp/progmodes/cc-vars.el +++ b/lisp/progmodes/cc-vars.el @@ -576,6 +576,7 @@ comment styles: javadoc -- Javadoc style for \"/** ... */\" comments (default in Java mode). autodoc -- Pike autodoc style for \"//! ...\" comments (default in Pike mode). gtkdoc -- GtkDoc style for \"/** ... **/\" comments (default in C and C++ modes). + doxygen -- Doxygen style. The value may also be a list of doc comment styles, in which case all of them are recognized simultaneously (presumably with markup cues @@ -1649,6 +1650,15 @@ white space either before or after the operator, but not both." :type 'boolean :group 'c) +(defcustom c-cpp-indent-to-body-directives '("pragma") + "Preprocessor directives which will be indented as statements. + +A list of Preprocessor directives which when reindented, or newly +typed in, will cause the \"#\" introducing the directive to be +indented as a statement." + :type '(repeat string) + :group 'c) + ;; Initialize the next two to a regexp which never matches. (defvar c-noise-macro-with-parens-name-re regexp-unmatchable) (make-variable-buffer-local 'c-noise-macro-with-parens-name-re) diff --git a/lisp/progmodes/cfengine.el b/lisp/progmodes/cfengine.el index 9ddb2ab2bbb..a8fe485b702 100644 --- a/lisp/progmodes/cfengine.el +++ b/lisp/progmodes/cfengine.el @@ -1294,10 +1294,10 @@ Calls `cfengine-cf-promises' with \"-s json\"." 'symbols)) syntax))) -(defun cfengine3-documentation-function () +(defun cfengine3-documentation-function (&rest _ignored) "Document CFengine 3 functions around point. -Intended as the value of `eldoc-documentation-function', which see. -Use it by enabling `eldoc-mode'." +Intended as the value of `eldoc-documentation-functions', which +see. Use it by enabling `eldoc-mode'." (let ((fdef (cfengine3--current-function))) (when fdef (cfengine3-format-function-docstring fdef)))) @@ -1322,7 +1322,7 @@ Use it by enabling `eldoc-mode'." (set (make-local-variable 'parens-require-spaces) nil) (set (make-local-variable 'comment-start) "# ") (set (make-local-variable 'comment-start-skip) - "\\(\\(?:^\\|[^\\\\\n]\\)\\(?:\\\\\\\\\\)*\\)#+[ \t]*") + "\\(\\(?:^\\|[^\\\n]\\)\\(?:\\\\\\\\\\)*\\)#+[ \t]*") ;; Like Lisp mode. Without this, we lose with, say, ;; `backward-up-list' when there's an unbalanced quote in a ;; preceding comment. @@ -1390,12 +1390,8 @@ to the action header." (when buffer-file-name (shell-quote-argument buffer-file-name))))) - ;; For emacs < 25.1 where `eldoc-documentation-function' defaults to - ;; nil. - (or eldoc-documentation-function - (setq-local eldoc-documentation-function #'ignore)) - (add-function :before-until (local 'eldoc-documentation-function) - #'cfengine3-documentation-function) + (add-hook 'eldoc-documentation-functions + #'cfengine3-documentation-function nil t) (add-hook 'completion-at-point-functions #'cfengine3-completion-function nil t) diff --git a/lisp/progmodes/cl-font-lock.el b/lisp/progmodes/cl-font-lock.el new file mode 100644 index 00000000000..7ef43fd4490 --- /dev/null +++ b/lisp/progmodes/cl-font-lock.el @@ -0,0 +1,289 @@ +;;; cl-font-lock.el --- Pretty Common Lisp font locking -*- lexical-binding: t; -*- +;; Copyright (C) 2019-2020 Free Software Foundation, Inc. + +;; Author: Yue Daian <sheepduke@gmail.com> +;; Maintainer: Spenser Truex <web@spensertruex.com> +;; Created: 2019-06-16 +;; Old-Version: 0.3.0 +;; Package-Requires: ((emacs "24.5")) +;; Keywords: lisp wp files convenience +;; URL: https://github.com/cl-font-lock/cl-font-lock +;; Homepage: https://github.com/cl-font-lock/cl-font-lock + +;; 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 <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Highlight all the symbols in the Common Lisp ANSI Standard. +;; Adds font-lock regexes to lisp-mode. + +;;;; Todo: + +;; - Integrate better into `lisp-mode' (e.g. enable it by default). +;; - Distinguish functions from macros like `pushnew'. + +;;; Code: + +;; The list of built-in functions and variables was actually not +;; extracted from the standard, but from SBCL with the following +;; (Common Lisp) code: + +;; (defvar *functions* nil) +;; (defvar *symbols* nil) +;; (defvar *types* nil) + +;; (let ((pack (find-package :common-lisp))) +;; (do-all-symbols (sym) +;; (cond +;; ((not (eql pack (symbol-package sym))) nil) +;; ((fboundp sym) (pushnew sym *functions*)) +;; ((find-class sym nil) (pushnew sym *types*)) +;; (t (pushnew sym *symbols*))))) + + +(defvar cl-font-lock-built-in--functions + '("+" "-" "/" "/=" "<" "<=" "=" ">" ">=" "*" "1-" "1+" "abs" "acons" "acos" + "acosh" "add-method" "adjoin" "adjustable-array-p" "adjust-array" + "allocate-instance" "alpha-char-p" "alphanumericp" "and" "append" "apply" + "apropos" "apropos-list" "aref" "arithmetic-error-operands" + "arithmetic-error-operation" "array-dimension" "array-dimensions" + "array-displacement" "array-element-type" "array-has-fill-pointer-p" + "array-in-bounds-p" "arrayp" "array-rank" "array-row-major-index" + "array-total-size" "ash" "asin" "asinh" "assoc" "assoc-if" "assoc-if-not" + "atan" "atanh" "atom" "bit" "bit-and" "bit-andc1" "bit-andc2" "bit-eqv" + "bit-ior" "bit-nand" "bit-nor" "bit-not" "bit-orc1" "bit-orc2" + "bit-vector-p" "bit-xor" "boole" "both-case-p" "boundp" + "broadcast-stream-streams" "butlast" "byte" "byte-position" "byte-size" + "call-method" "call-next-method" "car" "catch" "cdr" "ceiling" + "cell-error-name" "change-class" "char" "char/=" "char<" "char<=" "char=" + "char>" "char>=" "character" "characterp" "char-code" "char-downcase" + "char-equal" "char-greaterp" "char-int" "char-lessp" "char-name" + "char-not-equal" "char-not-greaterp" "char-not-lessp" "char-upcase" "cis" + "class-name" "class-of" "clear-input" "clear-output" "close" "clrhash" + "code-char" "coerce" "compile" "compiled-function-p" "compile-file" + "compile-file-pathname" "compiler-macro-function" "complement" "complex" + "complexp" "compute-applicable-methods" "compute-restarts" "concatenate" + "concatenated-stream-streams" "conjugate" "cons" "consp" "constantly" + "constantp" "continue" "copy-alist" "copy-list" "copy-pprint-dispatch" + "copy-readtable" "copy-seq" "copy-structure" "copy-symbol" "copy-tree" + "cos" "cosh" "count" "count-if" "count-if-not" "decf" "decode-float" + "decode-universal-time" "delete" "delete-duplicates" "delete-file" + "delete-if" "delete-if-not" "delete-package" "denominator" "deposit-field" + "describe" "describe-object" "digit-char" "digit-char-p" "directory" + "directory-namestring" "disassemble" "do-all-symbols" "documentation" + "do-external-symbols" "do-symbols" "dpb" "dribble" + "echo-stream-input-stream" "echo-stream-output-stream" "ed" "eighth" "elt" + "encode-universal-time" "endp" "enough-namestring" + "ensure-directories-exist" "ensure-generic-function" "eq" "eql" "equal" + "equalp" "eval" "evenp" "every" "exp" "export" "expt" "fboundp" "fceiling" + "fdefinition" "ffloor" "fifth" "file-author" "file-error-pathname" + "file-length" "file-namestring" "file-position" "file-string-length" + "file-write-date" "fill" "fill-pointer" "find" "find-all-symbols" + "find-class" "find-if" "find-if-not" "find-method" "find-package" + "find-restart" "find-symbol" "finish-output" "first" "float" "float-digits" + "floatp" "float-precision" "float-radix" "float-sign" "floor" "fmakunbound" + "force-output" "format" "formatter" "fourth" "fresh-line" "fround" + "ftruncate" "funcall" "function" "function-keywords" + "function-lambda-expression" "functionp" "gcd" "gensym" "gentemp" "get" + "get-decoded-time" "get-dispatch-macro-character" "getf" "gethash" + "get-internal-real-time" "get-internal-run-time" "get-macro-character" + "get-output-stream-string" "get-properties" "get-setf-expansion" + "get-universal-time" "graphic-char-p" "hash-table-count" "hash-table-p" + "hash-table-rehash-size" "hash-table-rehash-threshold" "hash-table-size" + "hash-table-test" "host-namestring" "identity" "imagpart" "import" "incf" + "initialize-instance" "input-stream-p" "inspect" "integer-decode-float" + "integer-length" "integerp" "interactive-stream-p" "intern" "intersection" + "invalid-method-error" "invoke-debugger" "invoke-restart" + "invoke-restart-interactively" "isqrt" "keywordp" "last" "lcm" "ldb" + "ldb-test" "ldiff" "length" "lisp-implementation-type" + "lisp-implementation-version" "list" "list\\*" "list-all-packages" "listen" + "list-length" "listp" "load" "load-logical-pathname-translations" + "load-time-value" "log" "logand" "logandc1" "logandc2" "logbitp" "logcount" + "logeqv" "logical-pathname" "logical-pathname-translations" "logior" + "lognand" "lognor" "lognot" "logorc1" "logorc2" "logtest" "logxor" + "long-site-name" "loop-finish" "lower-case-p" "machine-instance" + "machine-type" "machine-version" "macroexpand" "macroexpand-1" + "macro-function" "make-array" "make-array" "make-broadcast-stream" + "make-concatenated-stream" "make-condition" "make-dispatch-macro-character" + "make-echo-stream" "make-hash-table" "make-instance" + "make-instances-obsolete" "make-list" "make-load-form" + "make-load-form-saving-slots" "make-method" "make-package" "make-pathname" + "make-random-state" "make-sequence" "make-string" + "make-string-input-stream" "make-string-output-stream" "make-symbol" + "make-synonym-stream" "make-two-way-stream" "makunbound" "map" "mapc" + "mapcan" "mapcar" "mapcon" "maphash" "map-into" "mapl" "maplist" + "mask-field" "max" "member" "member-if" "member-if-not" "merge" + "merge-pathnames" "method-combination-error" "method-qualifiers" "min" + "minusp" "mismatch" "mod" "muffle-warning" "multiple-value-call" + "multiple-value-list" "multiple-value-setq" "name-char" "namestring" + "nbutlast" "nconc" "next-method-p" "nintersection" "ninth" + "no-applicable-method" "no-next-method" "not" "notany" "notevery" "nreconc" + "nreverse" "nset-difference" "nset-exclusive-or" "nstring-capitalize" + "nstring-downcase" "nstring-upcase" "nsublis" "nsubst" "nsubst-if" + "nsubst-if-not" "nsubstitute" "nsubstitute-if" "nsubstitute-if-not" "nth" + "nthcdr" "nth-value" "null" "numberp" "numerator" "nunion" "oddp" "open" + "open-stream-p" "or" "output-stream-p" "package-error-package" + "package-name" "package-nicknames" "packagep" "package-shadowing-symbols" + "package-used-by-list" "package-use-list" "pairlis" "parse-integer" + "parse-namestring" "pathname" "pathname-device" "pathname-directory" + "pathname-host" "pathname-match-p" "pathname-name" "pathnamep" + "pathname-type" "pathname-version" "peek-char" "phase" "plusp" "pop" + "position" "position-if" "position-if-not" "pprint" "pprint-dispatch" + "pprint-exit-if-list-exhausted" "pprint-fill" "pprint-indent" + "pprint-linear" "pprint-logical-block" "pprint-newline" "pprint-pop" + "pprint-tab" "pprint-tabular" "prin1" "prin1-to-string" "princ" + "princ-to-string" "print" "print-not-readable-object" "print-object" + "print-unreadable-object" "probe-file" "provide" "psetf" "psetq" "push" + "pushnew" "quote" "random" "random-state-p" "rassoc" "rassoc-if" + "rassoc-if-not" "rational" "rationalize" "rationalp" "read" "read-byte" + "read-char" "read-char-no-hang" "read-delimited-list" "read-from-string" + "read-line" "read-preserving-whitespace" "read-sequence" "readtable-case" + "readtablep" "realp" "realpart" "reduce" "reinitialize-instance" "rem" + "remf" "remhash" "remove" "remove-duplicates" "remove-if" "remove-if-not" + "remove-method" "remprop" "rename-file" "rename-package" "replace" + "require" "rest" "restart-name" "revappend" "reverse" "room" "rotatef" + "round" "row-major-aref" "rplaca" "rplacd" "sbit" "scale-float" "schar" + "search" "second" "set" "set-difference" "set-dispatch-macro-character" + "set-exclusive-or" "setf" "set-macro-character" "set-pprint-dispatch" + "setq" "set-syntax-from-char" "seventh" "shadow" "shadowing-import" + "shared-initialize" "shiftf" "short-site-name" "signum" + "simple-bit-vector-p" "simple-condition-format-arguments" + "simple-condition-format-control" "simple-string-p" "simple-vector-p" "sin" + "sinh" "sixth" "sleep" "slot-boundp" "slot-exists-p" "slot-makunbound" + "slot-missing" "slot-unbound" "slot-value" "software-type" + "software-version" "some" "sort" "special-operator-p" "sqrt" "stable-sort" + "standard-char-p" "step" "store-value" "stream-element-type" + "stream-error-stream" "stream-external-format" "streamp" "string" + "string/=" "string<" "string<=" "string=" "string>" "string>=" + "string-capitalize" "string-downcase" "string-equal" "string-greaterp" + "string-left-trim" "string-lessp" "string-not-equal" "string-not-greaterp" + "string-not-lessp" "stringp" "string-right-trim" "string-trim" + "string-upcase" "sublis" "subseq" "subsetp" "subst" "subst-if" + "subst-if-not" "substitute" "substitute-if" "substitute-if-not" "subtypep" + "svref" "sxhash" "symbol-function" "symbol-name" "symbolp" "symbol-package" + "symbol-plist" "symbol-value" "synonym-stream-symbol" "tailp" "tan" "tanh" + "tenth" "terpri" "third" "throw" "time" "trace" + "translate-logical-pathname" "translate-pathname" "tree-equal" "truename" + "truncate" "two-way-stream-input-stream" "two-way-stream-output-stream" + "type-error-datum" "type-error-expected-type" "type-of" "typep" + "unbound-slot-instance" "unexport" "unintern" "union" "unread-char" + "untrace" "unuse-package" "update-instance-for-different-class" + "update-instance-for-redefined-class" "upgraded-array-element-type" + "upgraded-complex-part-type" "upper-case-p" "use-package" + "user-homedir-pathname" "use-value" "values" "values-list" "vector" + "vectorp" "vector-pop" "vector-push" "vector-push-extend" "wild-pathname-p" + "write" "write-byte" "write-char" "write-line" "write-sequence" + "write-string" "write-to-string" "yes-or-no-p" "y-or-n-p" "zerop")) + +(defvar cl-font-lock-built-in--variables + '("//" "///" "\\*load-pathname\\*" "\\*print-pprint-dispatch\\*" + "\\*break-on-signals\\*" "\\*load-print\\*" "\\*print-pprint-dispatch\\*" + "\\*break-on-signals\\*" "\\*load-truename\\*" "\\*print-pretty\\*" + "\\*load-verbose\\*" "\\*print-radix\\*" "\\*compile-file-pathname\\*" + "\\*macroexpand-hook\\*" "\\*print-readably\\*" + "\\*compile-file-pathname\\*" "\\*modules\\*" "\\*print-right-margin\\*" + "\\*compile-file-truename\\*" "\\*package\\*" "\\*print-right-margin\\*" + "\\*compile-file-truename\\*" "\\*print-array\\*" "\\*query-io\\*" + "\\*compile-print\\*" "\\*print-base\\*" "\\*random-state\\*" + "\\*compile-verbose\\*" "\\*default-pathname-defaults\\*" + "\\*print-length\\*" "\\*readtable\\*" "\\*error-output\\*" + "\\*print-level\\*" "\\*standard-input\\*" "\\*print-case\\*" + "\\*read-base\\*" "\\*compile-verbose\\*" "\\*print-circle\\*" + "\\*print-lines\\*" "\\*standard-output\\*" "\\*features\\*" + "\\*print-miser-width\\*" "\\*read-default-float-format\\*" + "\\*debug-io\\*" "\\*print-escape\\*" "\\*read-eval\\*" + "\\*debugger-hook\\*" "\\*print-gensym\\*" "\\*read-suppress\\*" + "\\*terminal-io\\*" "\\*gensym-counter\\*" "\\*print-miser-width\\*" + "\\*trace-output\\*" "array-dimension-limit" "array-rank-limit" + "array-total-size-limit" "boole-1" "boole-2" "boole-and" "boole-andc1" + "boole-andc2" "boole-c1" "boole-c2" "boole-clr" "boole-eqv" "boole-ior" + "boole-nand" "boole-nor" "boole-orc1" "boole-orc2" "boole-set" "boole-xor" + "call-arguments-limit" "char-code-limit" "double-float-epsilon" + "double-float-negative-epsilon" "internal-time-units-per-second" + "lambda-list-keywords" "lambda-parameters-limit" + "least-negative-double-float" "least-negative-long-float" + "least-negative-normalized-double-float" + "least-negative-normalized-long-float" + "least-negative-normalized-short-float" + "least-negative-normalized-single-float" "least-negative-short-float" + "least-negative-single-float" "least-positive-double-float" + "least-positive-long-float" "least-positive-normalized-double-float" + "least-positive-normalized-long-float" + "least-positive-normalized-short-float" + "least-positive-normalized-single-float" "least-positive-short-float" + "least-positive-single-float" "long-float-epsilon" + "long-float-negative-epsilon" "most-negative-double-float" + "most-negative-fixnum" "most-negative-long-float" + "most-negative-short-float" "most-negative-single-float" + "most-positive-double-float" "most-positive-fixnum" + "most-positive-long-float" "most-positive-short-float" + "most-positive-single-float" "multiple-values-limit" "short-float-epsilon" + "short-float-negative-epsilon" "single-float-epsilon" + "single-float-negative-epsilon" "pi")) + +(defvar cl-font-lock-built-in--types + '("arithmetic-error" "array" "base-char" "base-string" "bignum" "bit-vector" + "boolean" "broadcast-stream" "built-in-class" "cell-error" "class" + "compiled-function" "concatenated-stream" "condition" "control-error" + "division-by-zero" "double-float" "echo-stream" "end-of-file" + "extended-char" "file-error" "file-stream" "fixnum" + "floating-point-inexact" "floating-point-invalid-operation" + "floating-point-overflow" "floating-point-underflow" "generic-function" + "hash-table" "integer" "keyword" "long-float" "method" "method-combination" + "number" "package" "package-error" "parse-error" "print-not-readable" + "program-error" "random-state" "ratio" "reader-error" "readtable" "real" + "restart" "sequence" "serious-condition" "short-float" "signed-byte" + "simple-array" "simple-base-string" "simple-bit-vector" "simple-condition" + "simple-error" "simple-string" "simple-type-error" "simple-vector" + "simple-warning" "single-float" "standard-char" "standard-class" + "standard-generic-function" "standard-method" "standard-object" + "storage-condition" "stream" "stream-error" "string-stream" + "structure-class" "structure-object" "style-warning" "symbol" + "synonym-stream" "two-way-stream" "type-error" "unbound-slot" + "unbound-variable" "undefined-function" "unsigned-byte" "warning")) + +(defvar cl-font-lock-built-in--symbols + '("compilation-speed" "compiler-macro" "debug" "declaration" "dynamic-extent" + "ftype" "ignorable" "ignore" "inline" "notinline" "optimize" "otherwise" + "safety" "satisfies" "space" "special" "speed" "structure" "type")) + +(defvar cl-font-lock--character-names + '("newline" "space" "rubout" "page" "tab" "backspace" "return" "linefeed")) + +(defvar cl-font-lock-built-in-keywords + (mapcar (lambda (s) + `(,(regexp-opt (symbol-value (car s)) 'symbols) + . ,(cdr s))) + '((cl-font-lock-built-in--functions . font-lock-function-name-face) + (cl-font-lock-built-in--variables . font-lock-variable-name-face) + (cl-font-lock-built-in--types . font-lock-type-face) + (cl-font-lock-built-in--symbols . font-lock-builtin-face) + (cl-font-lock--character-names . font-lock-variable-name-face)))) + +;;;###autoload +(define-minor-mode cl-font-lock-built-in-mode + "Highlight built-in functions, variables, and types in `lisp-mode'." + :global t + (funcall + (if cl-font-lock-built-in-mode + #'font-lock-add-keywords + #'font-lock-remove-keywords) + 'lisp-mode + cl-font-lock-built-in-keywords)) + +(provide 'cl-font-lock) + +;;; cl-font-lock.el ends here diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el index 455f181f501..3106c61585e 100644 --- a/lisp/progmodes/compile.el +++ b/lisp/progmodes/compile.el @@ -265,6 +265,20 @@ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1)) (java "^\\(?:[ \t]+at \\|==[0-9]+== +\\(?:at\\|b\\(y\\)\\)\\).+(\\([^()\n]+\\):\\([0-9]+\\))$" 2 3 nil (1)) + (javac + ,(concat + ;; line1 + "^\\(\\(?:[A-Za-z]:\\)?[^:\n]+\\):" ;file + "\\([0-9]+\\): " ;line + "\\(warning: \\)?.*\n" ;type (optional) and message + ;; line2: source line containing error + ".*\n" + ;; line3: single "^" under error position in line2 + " *\\^$") + 1 2 + ,(lambda () (1- (current-column))) + (3)) + (jikes-file "^\\(?:Found\\|Issued\\) .* compiling \"\\(.+\\)\":$" 1 nil nil 0) @@ -302,8 +316,8 @@ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1)) (gcc-include "^\\(?:In file included \\| \\|\t\\)from \ \\([0-9]*[^0-9\n]\\(?:[^\n :]\\| [^-/\n]\\|:[^ \n]\\)*?\\):\ -\\([0-9]+\\)\\(?::\\([0-9]+\\)\\)?\\(?:\\(:\\)\\|\\(,\\|$\\)\\)?" - 1 2 3 (4 . 5)) +\\([0-9]+\\)\\(?::\\([0-9]+\\)\\)?\\(?:\\([:,]\\|$\\)\\)?" + 1 2 3 (nil . 4)) (ruby-Test::Unit "^ [[ ]?\\([^ (].*\\):\\([1-9][0-9]*\\)\\(\\]\\)?:in " 1 2) @@ -646,6 +660,16 @@ matched file names, and weeding out false positives." :link `(file-link :tag "example file" ,(expand-file-name "compilation.txt" data-directory))) +(defvar compilation-error-case-fold-search nil + "If non-nil, use case-insensitive matching of compilation errors +by the regexps of `compilation-error-regexp-alist' and +`compilation-error-regexp-alist-alist'. +If nil, matching is case-sensitive. + +This variable should only be set for backward compatibility as a temporary +measure. The proper solution is to use a regexp that matches the +messages without case-folding.") + ;;;###autoload(put 'compilation-directory 'safe-local-variable 'stringp) (defvar compilation-directory nil "Directory to restore to when doing `recompile'.") @@ -1435,7 +1459,8 @@ to `compilation-error-regexp-alist' if RULES is nil." (if (symbolp item) (setq item (cdr (assq item compilation-error-regexp-alist-alist)))) - (let ((file (nth 1 item)) + (let ((case-fold-search compilation-error-case-fold-search) + (file (nth 1 item)) (line (nth 2 item)) (col (nth 3 item)) (type (nth 4 item)) @@ -1455,9 +1480,15 @@ to `compilation-error-regexp-alist' if RULES is nil." nil) ;; Not anchored or anchored but already allows empty spaces. (t (setq pat (concat "^\\(?: \\)?" (substring pat 1))))) - (if (consp file) (setq fmt (cdr file) file (car file))) - (if (consp line) (setq end-line (cdr line) line (car line))) - (if (consp col) (setq end-col (cdr col) col (car col))) + (if (and (consp file) (not (functionp file))) + (setq fmt (cdr file) + file (car file))) + (if (and (consp line) (not (functionp line))) + (setq end-line (cdr line) + line (car line))) + (if (and (consp col) (not (functionp col))) + (setq end-col (cdr col) + col (car col))) (unless (or (null (nth 5 item)) (integerp (nth 5 item))) (error "HYPERLINK should be an integer: %s" (nth 5 item))) @@ -2342,12 +2373,10 @@ and runs `compilation-filter-hook'." (set-marker min nil) (set-marker max nil)))))) -;;; test if a buffer is a compilation buffer, assuming we're in the buffer (defsubst compilation-buffer-internal-p () "Test if inside a compilation buffer." (local-variable-p 'compilation-locs)) -;;; test if a buffer is a compilation buffer, using compilation-buffer-internal-p (defsubst compilation-buffer-p (buffer) "Test if BUFFER is a compilation buffer." (with-current-buffer buffer diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el index 5fee2df5863..6122caf5189 100644 --- a/lisp/progmodes/cperl-mode.el +++ b/lisp/progmodes/cperl-mode.el @@ -1306,7 +1306,7 @@ the last)." cperl-maybe-white-and-comment-rex ; whitespace-comments "\\(\\sw\\|_\\)+" ; attr-name ;; attr-arg (1 level of internal parens allowed!) - "\\((\\(\\\\.\\|[^\\\\()]\\|([^\\\\()]*)\\)*)\\)?" + "\\((\\(\\\\.\\|[^\\()]\\|([^\\()]*)\\)*)\\)?" "\\(" ; optional : (XXX allows trailing???) cperl-maybe-white-and-comment-rex ; whitespace-comments ":\\)?" @@ -1406,7 +1406,7 @@ the last)." (defvar cperl-font-locking nil) ;; NB as it stands the code in cperl-mode assumes this only has one -;; element. If XEmacs 19 support were dropped, this could all be simplified. +;; element. Since XEmacs 19 support has been dropped, this could all be simplified. (defvar cperl-compilation-error-regexp-alist ;; This look like a paranoiac regexp: could anybody find a better one? (which WORKS). '(("^[^\n]* \\(file\\|at\\) \\([^ \t\n]+\\) [^\n]*line \\([0-9]+\\)[\\., \n]" @@ -3560,19 +3560,18 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', "\\(\\`\n?\\|^\n\\)=" ; POD "\\|" ;; One extra () before this: - "<<~?" ; HERE-DOC - "\\(" ; 1 + 1 + "<<\\(~?\\)" ; HERE-DOC, indented-p = capture 2 + "\\(" ; 2 + 1 ;; First variant "BLAH" or just ``. "[ \t]*" ; Yes, whitespace is allowed! - "\\([\"'`]\\)" ; 2 + 1 = 3 - "\\([^\"'`\n]*\\)" ; 3 + 1 - "\\3" + "\\([\"'`]\\)" ; 3 + 1 = 4 + "\\([^\"'`\n]*\\)" ; 4 + 1 + "\\4" "\\|" ;; Second variant: Identifier or \ID (same as 'ID') or empty - "\\\\?\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" ; 4 + 1, 5 + 1 + "\\\\?\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" ; 5 + 1, 6 + 1 ;; Do not have <<= or << 30 or <<30 or << $blah. ;; "\\([^= \t0-9$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" ; 6 + 1 - "\\(\\)" ; To preserve count of pars :-( 6 + 1 "\\)" "\\|" ;; 1+6 extra () before this: @@ -3762,11 +3761,11 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', ;; ;; "\\([^= \t0-9$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" ; 6 + 1 ;; "\\(\\)" ; To preserve count of pars :-( 6 + 1 ;; "\\)" - ((match-beginning 2) ; 1 + 1 + ((match-beginning 3) ; 2 + 1 (setq b (point) tb (match-beginning 0) c (and ; not HERE-DOC - (match-beginning 5) + (match-beginning 6) (save-match-data (or (looking-at "[ \t]*(") ; << function_call() (save-excursion ; 1 << func_name, or $foo << 10 @@ -3793,17 +3792,17 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (looking-at "\\(printf?\\|say\\|system\\|exec\\|sort\\)\\>"))) (error t))))))) (error nil))) ; func(<<EOF) - (and (not (match-beginning 6)) ; Empty + (and (not (match-beginning 7)) ; Empty (looking-at "[ \t]*[=0-9$@%&(]")))))) (if c ; Not here-doc nil ; Skip it. - (setq c (match-end 2)) ; 1 + 1 - (if (match-beginning 5) ;4 + 1 - (setq b1 (match-beginning 5) ; 4 + 1 - e1 (match-end 5)) ; 4 + 1 - (setq b1 (match-beginning 4) ; 3 + 1 - e1 (match-end 4))) ; 3 + 1 + (setq c (match-end 3)) ; 2 + 1 + (if (match-beginning 6) ;6 + 1 + (setq b1 (match-beginning 6) ; 5 + 1 + e1 (match-end 6)) ; 5 + 1 + (setq b1 (match-beginning 5) ; 4 + 1 + e1 (match-end 5))) ; 4 + 1 (setq tag (buffer-substring b1 e1) qtag (regexp-quote tag)) (cond (cperl-pod-here-fontify @@ -3818,8 +3817,10 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (setq b (point)) ;; We do not search to max, since we may be called from ;; some hook of fontification, and max is random - (or (and (re-search-forward (concat "^[ \t]*" qtag "$") - stop-point 'toend) + (or (and (re-search-forward + (concat "^" (when (equal (match-string 2) "~") "[ \t]*") + qtag "$") + stop-point 'toend) ;;;(eq (following-char) ?\n) ; XXXX WHY??? ) (progn ; Pretend we matched at the end @@ -5659,16 +5660,16 @@ indentation and initial hashes. Behaves usually outside of comment." '("^[ \t]*format[ \t]+\\([a-zA-Z_][a-zA-Z_0-9:]*\\)[ \t]*=[ \t]*$" 1 font-lock-function-name-face) (cond ((featurep 'font-lock-extra) - '("\\([]}\\\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" + '("\\([]}\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" (2 font-lock-string-face t) (0 '(restart 2 t)))) ; To highlight $a{bc}{ef} (font-lock-anchored - '("\\([]}\\\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" + '("\\([]}\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" (2 font-lock-string-face t) ("\\=[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" nil nil (1 font-lock-string-face t)))) - (t '("\\([]}\\\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" + (t '("\\([]}\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" 2 font-lock-string-face t))) '("[[ \t{,(]\\(-?[a-zA-Z0-9_:]+\\)[ \t]*=>" 1 font-lock-string-face t) @@ -5752,7 +5753,7 @@ indentation and initial hashes. Behaves usually outside of comment." (if (eq (char-after (match-beginning 2)) ?%) 'cperl-hash-face 'cperl-array-face) - t) ; arrays and hashes + nil) ; arrays and hashes ("\\(\\([$@]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)" 1 (if (= (- (match-end 2) (match-beginning 2)) 1) @@ -6499,9 +6500,10 @@ If optional argument ALL is `recursive', will process Perl files in subdirectories too." (interactive) (let ((cmd "etags") - (args '("-l" "none" "-r" + (args `("-l" "none" "-r" ;; 1=fullname 2=package? 3=name 4=proto? 5=attrs? (VERY APPROX!) - "/\\<" cperl-sub-regexp "[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)\\)[ \\t]*\\(([^()]*)[ \t]*\\)?\\([ \t]*:[^#{;]*\\)?\\([{#]\\|$\\)/\\3/" + ,(concat + "/\\<" cperl-sub-regexp "[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)\\)[ \\t]*\\(([^()]*)[ \t]*\\)?\\([ \t]*:[^#{;]*\\)?\\([{#]\\|$\\)/\\3/") "-r" "/\\<package[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)\\)[ \\t]*\\([#;]\\|$\\)/\\1/" "-r" @@ -6786,6 +6788,7 @@ Use as (or topdir (setq topdir default-directory)) (let ((tags-file-name "TAGS") + (inhibit-read-only t) (case-fold-search nil) xs rel) (save-excursion diff --git a/lisp/progmodes/cwarn.el b/lisp/progmodes/cwarn.el index dfb987bf99a..6e84f4f1bcc 100644 --- a/lisp/progmodes/cwarn.el +++ b/lisp/progmodes/cwarn.el @@ -4,7 +4,7 @@ ;; Author: Anders Lindgren ;; Keywords: c, languages, faces -;; Version: 1.3.1 +;; Old-Version: 1.3.1 ;; This file is part of GNU Emacs. @@ -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/ebnf-abn.el b/lisp/progmodes/ebnf-abn.el index dc6bd44e482..bf9b0e961ba 100644 --- a/lisp/progmodes/ebnf-abn.el +++ b/lisp/progmodes/ebnf-abn.el @@ -474,11 +474,10 @@ (aset ebnf-abn-token-table ?\; 'comment))) -;; replace the range "\240-\377" (see `ebnf-range-regexp'). (defconst ebnf-abn-non-terminal-chars - (ebnf-range-regexp "-_0-9A-Za-z" ?\240 ?\377)) + "-_0-9A-Za-z\u00a0-\u00ff") (defconst ebnf-abn-non-terminal-letter-chars - (ebnf-range-regexp "A-Za-z" ?\240 ?\377)) + "A-Za-z\u00a0-\u00ff") (defun ebnf-abn-lex () @@ -572,9 +571,8 @@ See documentation for variable `ebnf-abn-lex'." (not eor-p))) -;; replace the range "\177-\237" (see `ebnf-range-regexp'). (defconst ebnf-abn-comment-chars - (ebnf-range-regexp "^\n\000-\010\016-\037" ?\177 ?\237)) + "^\n\000-\010\016-\037\177\u0080-\u009f") (defun ebnf-abn-skip-comment () @@ -612,9 +610,8 @@ See documentation for variable `ebnf-abn-lex'." (ebnf-buffer-substring ebnf-abn-comment-chars)) -;; replace the range "\240-\377" (see `ebnf-range-regexp'). (defconst ebnf-abn-string-chars - (ebnf-range-regexp " -!#-~" ?\240 ?\377)) + " !#-~\u00a0-\u00ff") (defun ebnf-abn-string () diff --git a/lisp/progmodes/ebnf-bnf.el b/lisp/progmodes/ebnf-bnf.el index 583740d3617..4e11862c1dc 100644 --- a/lisp/progmodes/ebnf-bnf.el +++ b/lisp/progmodes/ebnf-bnf.el @@ -419,9 +419,8 @@ (aset ebnf-bnf-token-table ebnf-lex-eop-char 'period))) -;; replace the range "\240-\377" (see `ebnf-range-regexp'). (defconst ebnf-bnf-non-terminal-chars - (ebnf-range-regexp "!#%&'*-,0-:<>@-Z\\\\^-z~" ?\240 ?\377)) + "!#%&'*-,0-:<>@-Z\\\\^-z~\u00a0-\u00ff") (defun ebnf-bnf-lex () @@ -520,9 +519,8 @@ See documentation for variable `ebnf-bnf-lex'." )))) -;; replace the range "\177-\237" (see `ebnf-range-regexp'). (defconst ebnf-bnf-comment-chars - (ebnf-range-regexp "^\n\000-\010\016-\037" ?\177 ?\237)) + "^\n\000-\010\016-\037\177\u0080-\u009f") (defun ebnf-bnf-skip-comment () diff --git a/lisp/progmodes/ebnf-dtd.el b/lisp/progmodes/ebnf-dtd.el index 7e824e487aa..bdebf0db2c1 100644 --- a/lisp/progmodes/ebnf-dtd.el +++ b/lisp/progmodes/ebnf-dtd.el @@ -1108,9 +1108,8 @@ (aset ebnf-dtd-token-table ?\] 'end-subset))) -;; replace the range "\240-\377" (see `ebnf-range-regexp'). (defconst ebnf-dtd-name-chars - (ebnf-range-regexp "-._:0-9A-Za-z" ?\240 ?\377)) + "-._:0-9A-Za-z\u00a0-\u00ff") (defconst ebnf-dtd-decl-alist @@ -1263,11 +1262,10 @@ See documentation for variable `ebnf-dtd-lex'." (format "%s%s;" start char))) -;; replace the range "\240-\377" (see `ebnf-range-regexp'). (defconst ebnf-dtd-double-string-chars - (ebnf-range-regexp "\t -!#-~" ?\240 ?\377)) + "\t -!#-~\u00a0-\u00ff") (defconst ebnf-dtd-single-string-chars - (ebnf-range-regexp "\t -&(-~" ?\240 ?\377)) + "\t -&(-~\u00a0-\u00ff") (defun ebnf-dtd-string (delim) @@ -1287,11 +1285,10 @@ See documentation for variable `ebnf-dtd-lex'." (forward-char))))) -;; replace the range "\177-\237" (see `ebnf-range-regexp'). (defconst ebnf-dtd-comment-chars - (ebnf-range-regexp "^-\000-\010\013\014\016-\037" ?\177 ?\237)) + "^-\000-\010\013\014\016-\037\177\u0080-\u009f") (defconst ebnf-dtd-filename-chars - (ebnf-range-regexp "^-\000-\037" ?\177 ?\237)) + "^-\000-\037\177\u0080-\u009f") (defun ebnf-dtd-skip-comment () diff --git a/lisp/progmodes/ebnf-ebx.el b/lisp/progmodes/ebnf-ebx.el index 2ae6fb67569..20e2d4ca31c 100644 --- a/lisp/progmodes/ebnf-ebx.el +++ b/lisp/progmodes/ebnf-ebx.el @@ -405,11 +405,10 @@ (aset ebnf-ebx-token-table ?/ 'comment))) -;; replace the range "\240-\377" (see `ebnf-range-regexp'). (defconst ebnf-ebx-non-terminal-chars - (ebnf-range-regexp "-_A-Za-z" ?\240 ?\377)) + "-_A-Za-z\u00a0-\u00ff") (defconst ebnf-ebx-non-terminal-letter-chars - (ebnf-range-regexp "A-Za-z" ?\240 ?\377)) + "A-Za-z\u00a0-\u00ff") (defun ebnf-ebx-lex () @@ -488,9 +487,8 @@ See documentation for variable `ebnf-ebx-lex'." )))) -;; replace the range "\177-\237" (see `ebnf-range-regexp'). (defconst ebnf-ebx-constraint-chars - (ebnf-range-regexp "^\000-\010\016-\037]" ?\177 ?\237)) + "^\000-\010\016-\037]\177\u0080-\u009f") (defun ebnf-ebx-skip-constraint () @@ -517,11 +515,10 @@ See documentation for variable `ebnf-ebx-lex'." (not eor-p))) -;; replace the range "\177-\237" (see `ebnf-range-regexp'). (defconst ebnf-ebx-comment-chars - (ebnf-range-regexp "^\000-\010\016-\037\\*" ?\177 ?\237)) + "^\000-\010\016-\037*\177\u0080-\u009f") (defconst ebnf-ebx-filename-chars - (ebnf-range-regexp "^\000-\037\\*" ?\177 ?\237)) + "^\000-\037*\177\u0080-\u009f") (defun ebnf-ebx-skip-comment () @@ -581,11 +578,10 @@ See documentation for variable `ebnf-ebx-lex'." (concat fname (make-string nchar ?*))))) -;; replace the range "\240-\377" (see `ebnf-range-regexp'). (defconst ebnf-ebx-double-string-chars - (ebnf-range-regexp "\t -!#-~" ?\240 ?\377)) + "\t -!#-~\u00a0-\u00ff") (defconst ebnf-ebx-single-string-chars - (ebnf-range-regexp "\t -&(-~" ?\240 ?\377)) + "\t -&(-~\u00a0-\u00ff") (defun ebnf-ebx-string (delim) diff --git a/lisp/progmodes/ebnf-iso.el b/lisp/progmodes/ebnf-iso.el index b52094a5912..466e7785053 100644 --- a/lisp/progmodes/ebnf-iso.el +++ b/lisp/progmodes/ebnf-iso.el @@ -379,9 +379,8 @@ (aset ebnf-iso-token-table ?. 'character))) -;; replace the range "\240-\377" (see `ebnf-range-regexp'). (defconst ebnf-iso-non-terminal-chars - (ebnf-range-regexp " 0-9A-Za-z_" ?\240 ?\377)) + " 0-9A-Za-z_\u00a0-\u00ff") (defun ebnf-iso-lex () @@ -487,9 +486,8 @@ See documentation for variable `ebnf-iso-lex'." )))) -;; replace the range "\177-\237" (see `ebnf-range-regexp'). (defconst ebnf-iso-comment-chars - (ebnf-range-regexp "^*(\000-\010\016-\037" ?\177 ?\237)) + "^*(\000-\010\016-\037\177\u0080-\u009f") (defun ebnf-iso-skip-comment () diff --git a/lisp/progmodes/ebnf-yac.el b/lisp/progmodes/ebnf-yac.el index f5d633e8460..a657c637f82 100644 --- a/lisp/progmodes/ebnf-yac.el +++ b/lisp/progmodes/ebnf-yac.el @@ -397,9 +397,8 @@ See documentation for variable `ebnf-yac-lex'." (< (point) ebnf-limit)) -;; replace the range "\177-\377" (see `ebnf-range-regexp'). (defconst ebnf-yac-skip-chars - (ebnf-range-regexp "^{}/'\"\000-\010\013\016-\037" ?\177 ?\377)) + "^{}/'\"\000-\010\013\016-\037\177\u0080-\u009f") (defun ebnf-yac-skip-code () @@ -442,9 +441,8 @@ See documentation for variable `ebnf-yac-lex'." )) -;; replace the range "\177-\237" (see `ebnf-range-regexp'). (defconst ebnf-yac-comment-chars - (ebnf-range-regexp "^*\000-\010\013\016-\037" ?\177 ?\237)) + "^*\000-\010\013\016-\037\177\u0080-\u009f") (defun ebnf-yac-skip-comment () diff --git a/lisp/progmodes/ebnf2ps.el b/lisp/progmodes/ebnf2ps.el index 640cb576ef6..08cf802bcbe 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) @@ -4979,18 +4962,6 @@ killed after process termination." (kill-buffer (current-buffer)))) -;; function `ebnf-range-regexp' is used to avoid a bug of `skip-chars-forward' -;; on version 20.4.1, that is, it doesn't accept ranges like "\240-\377" (or -;; "\177-\237"), but it accepts the character sequence from \240 to \377 (or -;; from \177 to \237). It seems that version 20.7 has the same problem. -(defun ebnf-range-regexp (prefix from to) - (let (str) - (while (<= from to) - (setq str (concat str (char-to-string from)) - from (1+ from))) - (concat prefix str))) - - (defvar ebnf-map-name (let ((map (make-vector 256 ?\_))) (mapc #'(lambda (char) @@ -5004,8 +4975,6 @@ killed after process termination." (defun ebnf-eps-filename (str) (let* ((len (length str)) (stri 0) - ;; to keep compatibility with Emacs 20 & 21: - ;; DO NOT REPLACE `?\ ' BY `?\s' (new (make-string len ?\ ))) (while (< stri len) (aset new stri (aref ebnf-map-name (aref str stri))) @@ -5987,8 +5956,7 @@ killed after process termination." (point)))) -;; replace the range "\240-\377" (see `ebnf-range-regexp'). -(defconst ebnf-8-bit-chars (ebnf-range-regexp "" ?\240 ?\377)) +(defconst ebnf-8-bit-chars "\u00a0-\u00ff") (defun ebnf-string (chars eos-char kind) @@ -6023,8 +5991,6 @@ killed after process termination." (defun ebnf-trim-right (str) (let* ((len (1- (length str))) (index len)) - ;; to keep compatibility with Emacs 20 & 21: - ;; DO NOT REPLACE `?\ ' BY `?\s' (while (and (> index 0) (= (aref str index) ?\ )) (setq index (1- index))) (if (= index len) diff --git a/lisp/progmodes/ebrowse.el b/lisp/progmodes/ebrowse.el index bb780259333..1c9e805f039 100644 --- a/lisp/progmodes/ebrowse.el +++ b/lisp/progmodes/ebrowse.el @@ -34,6 +34,7 @@ ;;; Code: (require 'cl-lib) +(require 'seq) (require 'easymenu) (require 'view) (require 'ebuff-menu) @@ -52,32 +53,27 @@ "List of directories to search for source files in a class tree. Elements should be directory names; nil as an element means to try to find source files relative to the location of the BROWSE file loaded." - :group 'ebrowse :type '(repeat (choice (const :tag "Default" nil) (string :tag "Directory")))) (defcustom ebrowse-view/find-hook nil "Hooks run after finding or viewing a member or class." - :group 'ebrowse :type 'hook) (defcustom ebrowse-not-found-hook nil "Hooks run when finding or viewing a member or class was not successful." - :group 'ebrowse :type 'hook) (defcustom ebrowse-electric-list-mode-hook nil "Hook called by `ebrowse-electric-position-mode'." - :group 'ebrowse :type 'hook) (defcustom ebrowse-max-positions 50 "Number of markers saved on electric position stack." - :group 'ebrowse :type 'integer) @@ -89,32 +85,27 @@ to find source files relative to the location of the BROWSE file loaded." (defcustom ebrowse-tree-mode-hook nil "Hook run in each new tree buffer." - :group 'ebrowse-tree :type 'hook) (defcustom ebrowse-tree-buffer-name "*Tree*" "The default name of class tree buffers." - :group 'ebrowse-tree :type 'string) (defcustom ebrowse--indentation 4 "The amount by which subclasses are indented in the tree." - :group 'ebrowse-tree :type 'integer) (defcustom ebrowse-source-file-column 40 "The column in which source file names are displayed in the tree." - :group 'ebrowse-tree :type 'integer) (defcustom ebrowse-tree-left-margin 2 "Amount of space left at the left side of the tree display. This space is used to display markers." - :group 'ebrowse-tree :type 'integer) @@ -126,25 +117,21 @@ This space is used to display markers." (defcustom ebrowse-default-declaration-column 25 "The column in which member declarations are displayed in member buffers." - :group 'ebrowse-member :type 'integer) (defcustom ebrowse-default-column-width 25 "The width of the columns in member buffers (short display form)." - :group 'ebrowse-member :type 'integer) (defcustom ebrowse-member-buffer-name "*Members*" "The name of the buffer for member display." - :group 'ebrowse-member :type 'string) (defcustom ebrowse-member-mode-hook nil "Run in each new member buffer." - :group 'ebrowse-member :type 'hook) @@ -156,81 +143,47 @@ This space is used to display markers." (defface ebrowse-tree-mark '((((min-colors 88)) :foreground "red1") (t :foreground "red")) - "Face for the mark character in the Ebrowse tree." - :group 'ebrowse-faces) + "Face for the mark character in the Ebrowse tree.") (defface ebrowse-root-class '((((min-colors 88)) :weight bold :foreground "blue1") (t :weight bold :foreground "blue")) - "Face for root classes in the Ebrowse tree." - :group 'ebrowse-faces) + "Face for root classes in the Ebrowse tree.") (defface ebrowse-file-name '((t :slant italic)) - "Face for filenames in the Ebrowse tree." - :group 'ebrowse-faces) + "Face for filenames in the Ebrowse tree.") (defface ebrowse-default '((t)) - "Face for items in the Ebrowse tree which do not have other faces." - :group 'ebrowse-faces) + "Face for items in the Ebrowse tree which do not have other faces.") (defface ebrowse-member-attribute '((((min-colors 88)) :foreground "red1") (t :foreground "red")) - "Face for member attributes." - :group 'ebrowse-faces) + "Face for member attributes.") (defface ebrowse-member-class '((t :foreground "purple")) - "Face used to display the class title in member buffers." - :group 'ebrowse-faces) + "Face used to display the class title in member buffers.") (defface ebrowse-progress '((((min-colors 88)) :background "blue1") (t :background "blue")) - "Face for progress indicator." - :group 'ebrowse-faces) + "Face for progress indicator.") ;;; Utilities. -(defun ebrowse-some (predicate vector) - "Return true if PREDICATE is true of some element of VECTOR. -If so, return the value returned by PREDICATE." - (let ((length (length vector)) - (i 0) - result) - (while (and (< i length) (not result)) - (setq result (funcall predicate (aref vector i)) - i (1+ i))) - result)) +(define-obsolete-function-alias 'ebrowse-some #'seq-some "28.1") -(defun ebrowse-every (predicate vector) - "Return true if PREDICATE is true of every element of VECTOR." - (let ((length (length vector)) - (i 0) - (result t)) - (while (and (< i length) result) - (setq result (funcall predicate (aref vector i)) - i (1+ i))) - result)) +(define-obsolete-function-alias 'ebrowse-every #'seq-every-p "28.1") (defun ebrowse-position (item list &optional test) "Return the position of ITEM in LIST or nil if not found. Compare items with `eq' or TEST if specified." - (let ((i 0) found) - (cond (test - (while list - (when (funcall test item (car list)) - (setq found i list nil)) - (setq list (cdr list) i (1+ i)))) - (t - (while list - (when (eq item (car list)) - (setq found i list nil)) - (setq list (cdr list) i (1+ i))))) - found)) + (declare (obsolete seq-position "28.1")) + (seq-position list item (or test #'eql))) (defmacro ebrowse-ignoring-completion-case (&rest body) @@ -242,17 +195,13 @@ Compare items with `eq' or TEST if specified." (defmacro ebrowse-for-all-trees (spec &rest body) "For all trees in SPEC, eval BODY." (declare (indent 1) (debug ((sexp form) body))) - (let ((var (make-symbol "var")) - (spec-var (car spec)) + (let ((spec-var (car spec)) (array (cadr spec))) - `(cl-loop for ,var being the symbols of ,array - as ,spec-var = (get ,var 'ebrowse-root) do - (when (vectorp ,spec-var) - ,@body)))) - -;;; Set indentation for macros above. - - + `(maphash (lambda (_k ,spec-var) + (when ,spec-var + (cl-assert (cl-typep ,spec-var 'ebrowse-ts)) + ,@body)) + ,array))) (defsubst ebrowse-set-face (start end face) "Set face of a region START END to FACE." @@ -264,8 +213,7 @@ Compare items with `eq' or TEST if specified." Case is ignored in completions. PROMPT is a string to prompt with; normally it ends in a colon and a space. -TABLE is an alist whose elements' cars are strings, or an obarray. -TABLE can also be a function to do the completion itself. +TABLE is a completion table. If INITIAL-INPUT is non-nil, insert it in the minibuffer initially. If it is (STRING . POSITION), the initial input is STRING, but point is placed POSITION characters into the string." @@ -304,6 +252,9 @@ otherwise use the current frame's width." ;;; Structure definitions +;; Note: These use `(:type vector) :named' in order to match the +;; format used in src/BROWSE. + (cl-defstruct (ebrowse-hs (:type vector) :named) "Header structure found at the head of BROWSE files." ;; A version string that is compared against the version number of @@ -457,19 +408,17 @@ members." This must be the same that `ebrowse' uses.") -(defvar ebrowse--last-regexp nil +(defvar-local ebrowse--last-regexp nil "Last regular expression searched for in tree and member buffers. Each tree and member buffer maintains its own search history.") -(make-variable-buffer-local 'ebrowse--last-regexp) - (defconst ebrowse-member-list-accessors - '(ebrowse-ts-member-variables - ebrowse-ts-member-functions - ebrowse-ts-static-variables - ebrowse-ts-static-functions - ebrowse-ts-friends - ebrowse-ts-types) + (list #'ebrowse-ts-member-variables + #'ebrowse-ts-member-functions + #'ebrowse-ts-static-variables + #'ebrowse-ts-static-functions + #'ebrowse-ts-friends + #'ebrowse-ts-types) "List of accessors for member lists. Each element is the symbol of an accessor function. The nth element must be the accessor for the nth member list @@ -478,8 +427,8 @@ in an `ebrowse-ts' structure.") ;;; FIXME: Add more doc strings for the buffer-local variables below. -(defvar ebrowse--tree-obarray nil - "Obarray holding all `ebrowse-ts' structures of a class tree. +(defvar ebrowse--tree-table nil + "Hash-table holding all `ebrowse-ts' structures of a class tree. Buffer-local in Ebrowse buffers.") @@ -637,12 +586,12 @@ Buffer-local in Ebrowse buffers.") ;;; Operations on `ebrowse-ts' structures (defun ebrowse-files-table (&optional marked-only) - "Return an obarray containing all files mentioned in the current tree. -The tree is expected in the buffer-local variable `ebrowse--tree-obarray'. + "Return a hash table containing all files mentioned in the current tree. +The tree is expected in the buffer-local variable `ebrowse--tree-table'. MARKED-ONLY non-nil means include marked classes only." (let ((files (make-hash-table :test 'equal)) (i -1)) - (ebrowse-for-all-trees (tree ebrowse--tree-obarray) + (ebrowse-for-all-trees (tree ebrowse--tree-table) (when (or (not marked-only) (ebrowse-ts-mark tree)) (let ((class (ebrowse-ts-class tree))) (when (zerop (% (cl-incf i) 20)) @@ -677,7 +626,7 @@ MARKED-ONLY non-nil means include marked classes only." (cl-defun ebrowse-marked-classes-p () "Value is non-nil if any class in the current class tree is marked." - (ebrowse-for-all-trees (tree ebrowse--tree-obarray) + (ebrowse-for-all-trees (tree ebrowse--tree-table) (when (ebrowse-ts-mark tree) (cl-return-from ebrowse-marked-classes-p tree)))) @@ -695,21 +644,21 @@ MARKED-ONLY non-nil means include marked classes only." (ebrowse-cs-name class))) -(defun ebrowse-tree-obarray-as-alist (&optional qualified-names-p) +(defun ebrowse-tree-table-as-alist (&optional qualified-names-p) "Return an alist describing all classes in a tree. Each elements in the list has the form (CLASS-NAME . TREE). CLASS-NAME is the name of the class. TREE is the class tree whose root is QUALIFIED-CLASS-NAME. QUALIFIED-NAMES-P non-nil means return qualified names as CLASS-NAME. -The class tree is found in the buffer-local variable `ebrowse--tree-obarray'." +The class tree is found in the buffer-local variable `ebrowse--tree-table'." (let (alist) (if qualified-names-p - (ebrowse-for-all-trees (tree ebrowse--tree-obarray) + (ebrowse-for-all-trees (tree ebrowse--tree-table) (setq alist (cl-acons (ebrowse-qualified-class-name (ebrowse-ts-class tree)) tree alist))) - (ebrowse-for-all-trees (tree ebrowse--tree-obarray) + (ebrowse-for-all-trees (tree ebrowse--tree-table) (setq alist (cl-acons (ebrowse-cs-name (ebrowse-ts-class tree)) tree alist)))) @@ -751,7 +700,7 @@ computes this information lazily." with result = nil as search = (pop to-search) while search finally return result - do (ebrowse-for-all-trees (ti ebrowse--tree-obarray) + do (ebrowse-for-all-trees (ti ebrowse--tree-table) (when (memq search (ebrowse-ts-subclasses ti)) (unless (memq ti result) (setq result (nconc result (list ti)))) @@ -875,7 +824,7 @@ NOCONFIRM." "Create a new tree buffer for tree TREE. The tree was loaded from file TAGS-FILE. HEADER is the header structure of the file. -CLASSES is an obarray with a symbol for each class in the tree. +CLASSES is a hash-table with an entry for each class in the tree. POP non-nil means popup the buffer up at the end. Return the buffer created." (let ((name ebrowse-tree-buffer-name)) @@ -883,7 +832,7 @@ Return the buffer created." (ebrowse-tree-mode) (setq ebrowse--tree tree ebrowse--tags-file-name tags-file - ebrowse--tree-obarray classes + ebrowse--tree-table classes ebrowse--header header ebrowse--frozen-flag nil) (ebrowse-redraw-tree) @@ -895,13 +844,13 @@ Return the buffer created." -;;; Operations for member obarrays +;;; Operations for member tables (defun ebrowse-fill-member-table () - "Return an obarray holding all members of all classes in the current tree. + "Return a hash table holding all members of all classes in the current tree. -For each member, a symbol is added to the obarray. Members are -extracted from the buffer-local tree `ebrowse--tree-obarray'. +For each member, a symbol is added to the table. Members are +extracted from the buffer-local tree `ebrowse--tree-table'. Each symbol has its property `ebrowse-info' set to a list (TREE MEMBER-LIST MEMBER) where TREE is the tree in which the member is defined, @@ -909,26 +858,23 @@ MEMBER-LIST is a symbol describing the member list in which the member is found, and MEMBER is a MEMBER structure describing the member. The slot `member-table' of the buffer-local header structure of -type `ebrowse-hs' is set to the resulting obarray." +type `ebrowse-hs' is set to the resulting table." (let ((members (make-hash-table :test 'equal)) (i -1)) (setf (ebrowse-hs-member-table ebrowse--header) nil) (garbage-collect) ;; For all classes... - (ebrowse-for-all-trees (c ebrowse--tree-obarray) + (ebrowse-for-all-trees (c ebrowse--tree-table) (when (zerop (% (cl-incf i) 10)) (ebrowse-show-progress "Preparing member lookup" (zerop i))) (dolist (f ebrowse-member-list-accessors) (dolist (m (funcall f c)) - (let* ((member-name (ebrowse-ms-name m)) - (value (gethash member-name members))) - (push (list c f m) value) - (puthash member-name value members))))) + (push (list c f m) (gethash (ebrowse-ms-name m) members))))) (setf (ebrowse-hs-member-table ebrowse--header) members))) (defun ebrowse-member-table (header) - "Return the member obarray. Build it if it hasn't been set up yet. + "Return the member table. Build it if it hasn't been set up yet. HEADER is the tree header structure of the class tree." (when (null (ebrowse-hs-member-table header)) (cl-loop for buffer in (ebrowse-browser-buffer-list) @@ -940,19 +886,18 @@ HEADER is the tree header structure of the class tree." -;;; Operations on TREE obarrays +;;; Operations on TREE tables -(defun ebrowse-build-tree-obarray (tree) +(defun ebrowse-build-tree-table (tree) "Make sure every class in TREE is represented by a unique object. -Build obarray of all classes in TREE." - (let ((classes (make-vector 127 0))) +Build hash table of all classes in TREE." + (let ((classes (make-hash-table :test #'equal))) ;; Add root classes... (cl-loop for root in tree - as sym = - (intern (ebrowse-qualified-class-name (ebrowse-ts-class root)) - classes) - do (unless (get sym 'ebrowse-root) - (setf (get sym 'ebrowse-root) root))) + do (let ((name (ebrowse-qualified-class-name + (ebrowse-ts-class root)))) + (unless (gethash name classes) + (setf (gethash name classes) root)))) ;; Process subclasses (ebrowse-insert-supers tree classes) classes)) @@ -962,7 +907,7 @@ Build obarray of all classes in TREE." "Build base class lists in class tree TREE. CLASSES is an obarray used to collect classes. -Helper function for `ebrowse-build-tree-obarray'. Base classes should +Helper function for `ebrowse-build-tree-table'. Base classes should be ordered so that immediate base classes come first, then the base class of the immediate base class and so on. This means that we must construct the base-class list top down with adding each level at the @@ -974,23 +919,21 @@ if for some reason a circle is in the inheritance graph." as subclasses = (ebrowse-ts-subclasses class) do ;; Make sure every class is represented by a unique object (cl-loop for subclass on subclasses - as sym = (intern - (ebrowse-qualified-class-name - (ebrowse-ts-class (car subclass))) - classes) do - ;; Replace the subclass tree with the one found in - ;; CLASSES if there is already an entry for that class - ;; in it. Otherwise make a new entry. - ;; - ;; CAVEAT: If by some means (e.g., use of the - ;; preprocessor in class declarations, a name is marked - ;; as a subclass of itself on some path, we would end up - ;; in an endless loop. We have to omit subclasses from - ;; the recursion that already have been processed. - (if (get sym 'ebrowse-root) - (setf (car subclass) (get sym 'ebrowse-root)) - (setf (get sym 'ebrowse-root) (car subclass)))) + (let ((name (ebrowse-qualified-class-name + (ebrowse-ts-class (car subclass))))) + ;; Replace the subclass tree with the one found in + ;; CLASSES if there is already an entry for that class + ;; in it. Otherwise make a new entry. + ;; + ;; CAVEAT: If by some means (e.g., use of the + ;; preprocessor in class declarations, a name is marked + ;; as a subclass of itself on some path, we would end up + ;; in an endless loop. We have to omit subclasses from + ;; the recursion that already have been processed. + (if (gethash name classes) + (setf (car subclass) (gethash name classes)) + (setf (gethash name classes) (car subclass))))) ;; Process subclasses (ebrowse-insert-supers subclasses classes))) @@ -1072,20 +1015,17 @@ Tree mode key bindings: (erase-buffer) (message nil)) - (set (make-local-variable 'ebrowse--show-file-names-flag) nil) - (set (make-local-variable 'ebrowse--tree-obarray) (make-vector 127 0)) - (set (make-local-variable 'ebrowse--frozen-flag) nil) + (setq-local ebrowse--show-file-names-flag nil) + (setq-local ebrowse--frozen-flag nil) (setq mode-line-buffer-identification ident) (setq buffer-read-only t) (add-to-invisibility-spec '(ebrowse . t)) - (set (make-local-variable 'revert-buffer-function) - #'ebrowse-revert-tree-buffer-from-file) - (set (make-local-variable 'ebrowse--header) header) - (set (make-local-variable 'ebrowse--tree) tree) - (set (make-local-variable 'ebrowse--tags-file-name) buffer-file-name) - (set (make-local-variable 'ebrowse--tree-obarray) - (and tree (ebrowse-build-tree-obarray tree))) - (set (make-local-variable 'ebrowse--frozen-flag) nil) + (setq-local revert-buffer-function #'ebrowse-revert-tree-buffer-from-file) + (setq-local ebrowse--header header) + (setq-local ebrowse--tree tree) + (setq-local ebrowse--tags-file-name buffer-file-name) + (setq-local ebrowse--tree-table (and tree (ebrowse-build-tree-table tree))) + (setq-local ebrowse--frozen-flag nil) (add-hook 'write-file-functions #'ebrowse-write-file-hook-fn nil t) (modify-syntax-entry ?_ (char-to-string (char-syntax ?a))) @@ -1110,18 +1050,18 @@ Tree mode key bindings: (defun ebrowse-remove-class-and-kill-member-buffers (tree class) "Remove from TREE class CLASS. Kill all member buffers still containing a reference to the class." - (let ((sym (intern-soft (ebrowse-cs-name (ebrowse-ts-class class)) - ebrowse--tree-obarray))) - (setf tree (delq class tree) - (get sym 'ebrowse-root) nil) - (dolist (root tree) - (setf (ebrowse-ts-subclasses root) - (delq class (ebrowse-ts-subclasses root)) - (ebrowse-ts-base-classes root) nil) - (ebrowse-remove-class-and-kill-member-buffers - (ebrowse-ts-subclasses root) class)) - (ebrowse-kill-member-buffers-displaying class) - tree)) + (setf tree (delq class tree) + (gethash (ebrowse-cs-name (ebrowse-ts-class class)) + ebrowse--tree-table) + nil) + (dolist (root tree) + (setf (ebrowse-ts-subclasses root) + (delq class (ebrowse-ts-subclasses root)) + (ebrowse-ts-base-classes root) nil) + (ebrowse-remove-class-and-kill-member-buffers + (ebrowse-ts-subclasses root) class)) + (ebrowse-kill-member-buffers-displaying class) + tree) (defun ebrowse-remove-class-at-point (forced) @@ -1184,7 +1124,7 @@ If given a numeric N-TIMES argument, mark that many classes." (defun ebrowse-mark-all-classes (prefix) "Unmark, with PREFIX mark, all classes in the tree." (interactive "P") - (ebrowse-for-all-trees (tree ebrowse--tree-obarray) + (ebrowse-for-all-trees (tree ebrowse--tree-table) (setf (ebrowse-ts-mark tree) prefix)) (ebrowse-redraw-marks (point-min) (point-max))) @@ -1277,17 +1217,17 @@ With PREFIX, insert that many filenames." (defun ebrowse-browser-buffer-list () "Return a list of all tree or member buffers." - (cl-delete-if-not 'ebrowse-buffer-p (buffer-list))) + (cl-delete-if-not #'ebrowse-buffer-p (buffer-list))) (defun ebrowse-member-buffer-list () "Return a list of all member buffers." - (cl-delete-if-not 'ebrowse-member-buffer-p (buffer-list))) + (cl-delete-if-not #'ebrowse-member-buffer-p (buffer-list))) (defun ebrowse-tree-buffer-list () "Return a list of all tree buffers." - (cl-delete-if-not 'ebrowse-tree-buffer-p (buffer-list))) + (cl-delete-if-not #'ebrowse-tree-buffer-p (buffer-list))) (defun ebrowse-known-class-trees-buffer-list () @@ -1396,7 +1336,7 @@ Pop to member buffer if no prefix ARG, to tree buffer otherwise." "): ") nil nil ebrowse--indentation)))) (when (cl-plusp width) - (set (make-local-variable 'ebrowse--indentation) width) + (setq-local ebrowse--indentation width) (ebrowse-redraw-tree)))) @@ -1409,7 +1349,7 @@ Read a class name from the minibuffer if CLASS is nil." (unless class (setf class (completing-read "Goto class: " - (ebrowse-tree-obarray-as-alist) nil t))) + (ebrowse-tree-table-as-alist) nil t))) (goto-char (point-min)) (widen) (setq ebrowse--last-regexp (concat "\\b" class "\\b")) @@ -1426,37 +1366,37 @@ Read a class name from the minibuffer if CLASS is nil." (defun ebrowse-tree-command:show-member-variables (arg) "Display member variables; with prefix ARG in frozen member buffer." (interactive "P") - (ebrowse-display-member-buffer 'ebrowse-ts-member-variables arg)) + (ebrowse-display-member-buffer #'ebrowse-ts-member-variables arg)) (defun ebrowse-tree-command:show-member-functions (&optional arg) "Display member functions; with prefix ARG in frozen member buffer." (interactive "P") - (ebrowse-display-member-buffer 'ebrowse-ts-member-functions arg)) + (ebrowse-display-member-buffer #'ebrowse-ts-member-functions arg)) (defun ebrowse-tree-command:show-static-member-variables (arg) "Display static member variables; with prefix ARG in frozen member buffer." (interactive "P") - (ebrowse-display-member-buffer 'ebrowse-ts-static-variables arg)) + (ebrowse-display-member-buffer #'ebrowse-ts-static-variables arg)) (defun ebrowse-tree-command:show-static-member-functions (arg) "Display static member functions; with prefix ARG in frozen member buffer." (interactive "P") - (ebrowse-display-member-buffer 'ebrowse-ts-static-functions arg)) + (ebrowse-display-member-buffer #'ebrowse-ts-static-functions arg)) (defun ebrowse-tree-command:show-friends (arg) "Display friend functions; with prefix ARG in frozen member buffer." (interactive "P") - (ebrowse-display-member-buffer 'ebrowse-ts-friends arg)) + (ebrowse-display-member-buffer #'ebrowse-ts-friends arg)) (defun ebrowse-tree-command:show-types (arg) "Display types defined in a class; with prefix ARG in frozen member buffer." (interactive "P") - (ebrowse-display-member-buffer 'ebrowse-ts-types arg)) + (ebrowse-display-member-buffer #'ebrowse-ts-types arg)) @@ -1562,12 +1502,12 @@ The new frame is deleted when you quit viewing the file in that frame." (had-a-buf (get-file-buffer file)) (buf-to-view (find-file-noselect file))) (switch-to-buffer-other-frame buf-to-view) - (set (make-local-variable 'ebrowse--frame-configuration) + (setq-local ebrowse--frame-configuration old-frame-configuration) - (set (make-local-variable 'ebrowse--view-exit-action) + (setq-local ebrowse--view-exit-action (and (not had-a-buf) (not (buffer-modified-p buf-to-view)) - 'kill-buffer)) + #'kill-buffer)) (view-mode-enter (cons (selected-window) (cons (selected-window) t)) 'ebrowse-view-exit-fn))) @@ -1934,7 +1874,7 @@ COLLAPSE non-nil means collapse the branch." (when (memq 'mode-name mode-line-format) (setq mode-line-format (copy-sequence mode-line-format)) (setcar (memq 'mode-name mode-line-format) "Tree Buffers")) - (set (make-local-variable 'Helper-return-blurb) "return to buffer editing") + (setq-local Helper-return-blurb "return to buffer editing") (setq truncate-lines t buffer-read-only t)) @@ -2145,41 +2085,31 @@ See `Electric-command-loop' for a description of STATE and CONDITION." (define-derived-mode ebrowse-member-mode special-mode "Ebrowse-Members" "Major mode for Ebrowse member buffers." (mapc #'make-local-variable - '(ebrowse--decl-column ;display column - ebrowse--n-columns ;number of short columns - ebrowse--column-width ;width of columns above - ebrowse--show-inherited-flag ;include inherited members? - ebrowse--filters ;public, protected, private + '(ebrowse--n-columns ;number of short columns ebrowse--accessor ;vars, functions, friends ebrowse--displayed-class ;class displayed - ebrowse--long-display-flag ;display with regexps? - ebrowse--source-regexp-flag ;show source regexp? - ebrowse--attributes-flag ;show `virtual' and `inline' ebrowse--member-list ;list of members displayed ebrowse--tree ;the class tree ebrowse--member-mode-strings ;part of mode line ebrowse--tags-file-name ; ebrowse--header - ebrowse--tree-obarray - ebrowse--virtual-display-flag - ebrowse--inline-display-flag - ebrowse--const-display-flag - ebrowse--pure-display-flag + ebrowse--tree-table ebrowse--frozen-flag)) ;buffer not automagically reused - (setq mode-line-buffer-identification - (propertized-buffer-identification "C++ Members") - buffer-read-only t - ebrowse--long-display-flag nil - ebrowse--attributes-flag t - ebrowse--show-inherited-flag t - ebrowse--source-regexp-flag nil - ebrowse--filters [0 1 2] - ebrowse--decl-column ebrowse-default-declaration-column - ebrowse--column-width ebrowse-default-column-width - ebrowse--virtual-display-flag nil - ebrowse--inline-display-flag nil - ebrowse--const-display-flag nil - ebrowse--pure-display-flag nil) + (setq-local + mode-line-buffer-identification + (propertized-buffer-identification "C++ Members") + buffer-read-only t + ebrowse--long-display-flag nil ;display with regexps? + ebrowse--attributes-flag t ;show `virtual' and `inline' + ebrowse--show-inherited-flag t ;include inherited members? + ebrowse--source-regexp-flag nil ;show source regexp? + ebrowse--filters [0 1 2] ;public, protected, private + ebrowse--decl-column ebrowse-default-declaration-column ;display column + ebrowse--column-width ebrowse-default-column-width ;width of columns above + ebrowse--virtual-display-flag nil + ebrowse--inline-display-flag nil + ebrowse--const-display-flag nil + ebrowse--pure-display-flag nil) (modify-syntax-entry ?_ (char-to-string (char-syntax ?a)))) @@ -2257,10 +2187,10 @@ make one." (ebrowse-create-tree-buffer ebrowse--tree ebrowse--tags-file-name ebrowse--header - ebrowse--tree-obarray + ebrowse--tree-table 'pop)))) (and buf - (funcall (if arg 'switch-to-buffer 'pop-to-buffer) buf)) + (funcall (if arg #'switch-to-buffer #'pop-to-buffer) buf)) buf)) @@ -2276,8 +2206,9 @@ make one." (defun ebrowse-cyclic-display-next/previous-member-list (incr) "Switch buffer to INCR'th next/previous list of members." - (let ((index (ebrowse-position ebrowse--accessor - ebrowse-member-list-accessors))) + (let ((index (seq-position ebrowse-member-list-accessors + ebrowse--accessor + #'eql))) (setf ebrowse--accessor (cond ((cl-plusp incr) (or (nth (1+ index) @@ -2306,37 +2237,37 @@ make one." (defun ebrowse-display-function-member-list () "Display the list of member functions." (interactive) - (ebrowse-display-member-list-for-accessor 'ebrowse-ts-member-functions)) + (ebrowse-display-member-list-for-accessor #'ebrowse-ts-member-functions)) (defun ebrowse-display-variables-member-list () "Display the list of member variables." (interactive) - (ebrowse-display-member-list-for-accessor 'ebrowse-ts-member-variables)) + (ebrowse-display-member-list-for-accessor #'ebrowse-ts-member-variables)) (defun ebrowse-display-static-variables-member-list () "Display the list of static member variables." (interactive) - (ebrowse-display-member-list-for-accessor 'ebrowse-ts-static-variables)) + (ebrowse-display-member-list-for-accessor #'ebrowse-ts-static-variables)) (defun ebrowse-display-static-functions-member-list () "Display the list of static member functions." (interactive) - (ebrowse-display-member-list-for-accessor 'ebrowse-ts-static-functions)) + (ebrowse-display-member-list-for-accessor #'ebrowse-ts-static-functions)) (defun ebrowse-display-friends-member-list () "Display the list of friends." (interactive) - (ebrowse-display-member-list-for-accessor 'ebrowse-ts-friends)) + (ebrowse-display-member-list-for-accessor #'ebrowse-ts-friends)) (defun ebrowse-display-types-member-list () "Display the list of types." (interactive) - (ebrowse-display-member-list-for-accessor 'ebrowse-ts-types)) + (ebrowse-display-member-list-for-accessor #'ebrowse-ts-types)) @@ -2565,8 +2496,8 @@ TAGS-FILE is the file name of the BROWSE file." "Force buffer redisplay." (interactive) (let ((display-fn (if ebrowse--long-display-flag - 'ebrowse-draw-member-long-fn - 'ebrowse-draw-member-short-fn))) + #'ebrowse-draw-member-long-fn + #'ebrowse-draw-member-short-fn))) (with-silent-modifications (erase-buffer) ;; Show this class @@ -2610,7 +2541,7 @@ the class cursor is on." "Start point for member buffer creation. LIST is the member list to display. STAND-ALONE non-nil means the member buffer is standalone. CLASS is its class." - (let* ((classes ebrowse--tree-obarray) + (let* ((classes ebrowse--tree-table) (tree ebrowse--tree) (tags-file ebrowse--tags-file-name) (header ebrowse--header) @@ -2630,7 +2561,7 @@ means the member buffer is standalone. CLASS is its class." (setq ebrowse--member-list (funcall list class) ebrowse--displayed-class class ebrowse--accessor list - ebrowse--tree-obarray classes + ebrowse--tree-table classes ebrowse--frozen-flag stand-alone ebrowse--tags-file-name tags-file ebrowse--header header @@ -2842,7 +2773,7 @@ REPEAT, if specified, says repeat the search REPEAT times." (cl-defun ebrowse-move-point-to-member (name &optional count &aux member) - "Set point on member NAME in the member buffer + "Set point on member NAME in the member buffer. COUNT, if specified, says search the COUNT'th member with the same name." (goto-char (point-min)) (widen) @@ -2867,7 +2798,8 @@ COMPL-LIST is a completion list to use." (class (or (ebrowse-completing-read-value title compl-list initial) (error "Not found")))) (setf ebrowse--displayed-class class - ebrowse--member-list (funcall ebrowse--accessor ebrowse--displayed-class)) + ebrowse--member-list (funcall ebrowse--accessor + ebrowse--displayed-class)) (ebrowse-redisplay-member-buffer))) @@ -2875,7 +2807,9 @@ COMPL-LIST is a completion list to use." "Switch member buffer to a class read from the minibuffer." (interactive) (ebrowse-switch-member-buffer-to-other-class - "Goto class: " (ebrowse-tree-obarray-as-alist))) + "Goto class: " + ;; FIXME: Why not use the hash-table as-is? + (ebrowse-tree-table-as-alist))) (defun ebrowse-switch-member-buffer-to-base-class (arg) @@ -2927,8 +2861,9 @@ Prefix arg INC specifies which one." (cl-first supers)))) (unless tree (error "Not found")) (setq containing-list (ebrowse-ts-subclasses tree))))) - (setq index (+ inc (ebrowse-position ebrowse--displayed-class - containing-list))) + (setq index (+ inc (seq-position containing-list + ebrowse--displayed-class + #'eql))) (cond ((cl-minusp index) (message "No previous class")) ((null (nth index containing-list)) (message "No next class"))) (setq index (max 0 (min index (1- (length containing-list))))) @@ -2943,16 +2878,16 @@ Prefix arg INC specifies which one." Prefix arg ARG says which class should be displayed. Default is the first derived class." (interactive "P") - (cl-flet ((ebrowse-tree-obarray-as-alist () + (cl-flet ((ebrowse-tree-table-as-alist () (cl-loop for s in (ebrowse-ts-subclasses ebrowse--displayed-class) - collect (cons (ebrowse-cs-name - (ebrowse-ts-class s)) s)))) + collect (cons (ebrowse-cs-name (ebrowse-ts-class s)) + s)))) (let ((subs (or (ebrowse-ts-subclasses ebrowse--displayed-class) (error "No derived classes")))) (if (and arg (cl-second subs)) (ebrowse-switch-member-buffer-to-other-class - "Goto derived class: " (ebrowse-tree-obarray-as-alist)) + "Goto derived class: " (ebrowse-tree-table-as-alist)) (setq ebrowse--displayed-class (cl-first subs) ebrowse--member-list (funcall ebrowse--accessor ebrowse--displayed-class)) @@ -3403,7 +3338,8 @@ It is a list (TREE ACCESSOR MEMBER)." (switch-to-buffer buffer) (setq ebrowse--displayed-class (cl-first info) ebrowse--accessor (cl-second info) - ebrowse--member-list (funcall ebrowse--accessor ebrowse--displayed-class)) + ebrowse--member-list (funcall ebrowse--accessor + ebrowse--displayed-class)) (ebrowse-redisplay-member-buffer))) (ebrowse-move-point-to-member (ebrowse-ms-name (cl-third info))))) @@ -3513,28 +3449,20 @@ KIND is an additional string printed in the buffer." (_ "unknown")) "\n"))) -(defvar ebrowse-last-completion nil +(defvar-local ebrowse-last-completion nil "Text inserted by the last completion operation.") -(defvar ebrowse-last-completion-start nil +(defvar-local ebrowse-last-completion-start nil "String which was the basis for the last completion operation.") -(defvar ebrowse-last-completion-location nil +(defvar-local ebrowse-last-completion-location nil "Buffer position at which the last completion operation was initiated.") -(defvar ebrowse-last-completion-obarray nil +(defvar-local ebrowse-last-completion-table nil "Member used in last completion operation.") - - -(make-variable-buffer-local 'ebrowse-last-completion-obarray) -(make-variable-buffer-local 'ebrowse-last-completion-location) -(make-variable-buffer-local 'ebrowse-last-completion) -(make-variable-buffer-local 'ebrowse-last-completion-start) - - (defun ebrowse-some-member-table () "Return a hash table containing all members of a tree. @@ -3552,7 +3480,7 @@ use choose a tree." (defun ebrowse-cyclic-successor-in-string-list (string list) "Return the item following STRING in LIST. If STRING is the last element, return the first element as successor." - (or (nth (1+ (ebrowse-position string list 'string=)) list) + (or (nth (1+ (seq-position list string #'string=)) list) (cl-first list))) @@ -3583,7 +3511,7 @@ completion." ;; expansion ended, insert the next expansion. ((eq (point) ebrowse-last-completion-location) (setf list (all-completions ebrowse-last-completion-start - ebrowse-last-completion-obarray) + ebrowse-last-completion-table) completion (ebrowse-cyclic-successor-in-string-list ebrowse-last-completion list)) (cond ((null completion) @@ -3599,7 +3527,7 @@ completion." ;; buffer: Start new completion. (t (let* ((members (ebrowse-some-member-table)) - (completion (cl-first (all-completions pattern members nil)))) + (completion (cl-first (all-completions pattern members)))) (cond ((eq completion t)) ((null completion) (error "Can't find completion for `%s'" pattern)) @@ -3610,14 +3538,14 @@ completion." (setf ebrowse-last-completion-location (point) ebrowse-last-completion-start pattern ebrowse-last-completion completion - ebrowse-last-completion-obarray members)))))))) + ebrowse-last-completion-table members)))))))) ;;; Tags query replace & search -(defvar ebrowse-tags-loop-form () - "Form for `ebrowse-loop-continue'. -Evaluated for each file in the tree. If it returns nil, proceed +(defvar ebrowse-tags-loop-call '(ignore) + "Function call for `ebrowse-loop-continue'. +Passed to `apply' for each file in the tree. If it returns nil, proceed with the next file.") (defvar ebrowse-tags-next-file-list () @@ -3684,7 +3612,7 @@ TREE-BUFFER if indirectly specifies which files to loop over." (when first-time (ebrowse-tags-next-file first-time tree-buffer) (goto-char (point-min))) - (while (not (eval ebrowse-tags-loop-form)) + (while (not (apply ebrowse-tags-loop-call)) (ebrowse-tags-next-file) (message "Scanning file `%s'..." buffer-file-name) (goto-char (point-min)))) @@ -3697,9 +3625,9 @@ If marked classes exist, process marked classes, only. If regular expression is nil, repeat last search." (interactive "sTree search (regexp): ") (if (and (string= regexp "") - (eq (car ebrowse-tags-loop-form) 're-search-forward)) + (eq (car ebrowse-tags-loop-call) #'re-search-forward)) (ebrowse-tags-loop-continue) - (setq ebrowse-tags-loop-form (list 're-search-forward regexp nil t)) + (setq ebrowse-tags-loop-call `(re-search-forward ,regexp nil t)) (ebrowse-tags-loop-continue 'first-time))) @@ -3709,10 +3637,11 @@ If regular expression is nil, repeat last search." With prefix arg, process files of marked classes only." (interactive "sTree query replace (regexp): \nsTree query replace %s by: ") - (setq ebrowse-tags-loop-form - (list 'and (list 'save-excursion - (list 're-search-forward from nil t)) - (list 'not (list 'perform-replace from to t t nil)))) + (setq ebrowse-tags-loop-call + (list (lambda () + (and (save-excursion + (re-search-forward from nil t)) + (not (perform-replace from to t t nil)))))) (ebrowse-tags-loop-continue 'first-time)) @@ -3737,7 +3666,7 @@ looks like a function call to the member." (cl-values-list (ebrowse-tags-read-name header "Find calls of: ")))) ;; Set tags loop form to search for member and begin loop. (setq regexp (concat "\\<" name "[ \t]*(") - ebrowse-tags-loop-form (list 're-search-forward regexp nil t)) + ebrowse-tags-loop-call `(re-search-forward ,regexp nil t)) (ebrowse-tags-loop-continue 'first-time tree-buffer)))) @@ -3746,7 +3675,7 @@ looks like a function call to the member." ;;; Structures of this kind are the elements of the position stack. -(cl-defstruct (ebrowse-position (:type vector) :named) +(cl-defstruct (ebrowse-position) file-name ; in which file point ; point in file target ; t if target of a jump @@ -3839,18 +3768,10 @@ Prefix arg ARG says how much." ;;; Electric position list -(defvar ebrowse-electric-position-mode-map () - "Keymap used in electric position stack window.") - - -(defvar ebrowse-electric-position-mode-hook nil - "If non-nil, its value is called by `ebrowse-electric-position-mode'.") - - -(unless ebrowse-electric-position-mode-map +(defvar ebrowse-electric-position-mode-map (let ((map (make-keymap)) (submap (make-keymap))) - (setq ebrowse-electric-position-mode-map map) + ;; FIXME: Yuck! (fillarray (car (cdr map)) 'ebrowse-electric-position-undefined) (fillarray (car (cdr submap)) 'ebrowse-electric-position-undefined) (define-key map "\e" submap) @@ -3873,14 +3794,19 @@ Prefix arg ARG says how much." (define-key map "\e\C-v" 'scroll-other-window) (define-key map "\e>" 'end-of-buffer) (define-key map "\e<" 'beginning-of-buffer) - (define-key map "\e>" 'end-of-buffer))) + (define-key map "\e>" 'end-of-buffer) + map) + "Keymap used in electric position stack window.") + + +(defvar ebrowse-electric-position-mode-hook nil + "If non-nil, its value is called by `ebrowse-electric-position-mode'.") -(put 'ebrowse-electric-position-mode 'mode-class 'special) (put 'ebrowse-electric-position-undefined 'suppress-keymap t) (define-derived-mode ebrowse-electric-position-mode - fundamental-mode "Electric Position Menu" + special-mode "Electric Position Menu" "Mode for electric position buffers. Runs the hook `ebrowse-electric-position-mode-hook'." (setq mode-line-buffer-identification "Electric Position Menu") @@ -3888,7 +3814,7 @@ Runs the hook `ebrowse-electric-position-mode-hook'." (setq mode-line-format (copy-sequence mode-line-format)) ;; FIXME: Why not set `mode-name' to "Positions"? (setcar (memq 'mode-name mode-line-format) "Positions")) - (set (make-local-variable 'Helper-return-blurb) "return to buffer editing") + (setq-local Helper-return-blurb "return to buffer editing") (setq truncate-lines t buffer-read-only t)) @@ -4101,7 +4027,7 @@ NUMBER-OF-INSTANCE-VARIABLES NUMBER-OF-STATIC-FUNCTIONS NUMBER-OF-STATIC-VARIABLES:" (let ((classes 0) (member-functions 0) (member-variables 0) (static-functions 0) (static-variables 0)) - (ebrowse-for-all-trees (tree ebrowse--tree-obarray) + (ebrowse-for-all-trees (tree ebrowse--tree-table) (cl-incf classes) (cl-incf member-functions (length (ebrowse-ts-member-functions tree))) (cl-incf member-variables (length (ebrowse-ts-member-variables tree))) @@ -4391,10 +4317,4 @@ EVENT is the mouse event." (provide 'ebrowse) - -;; Local variables: -;; eval:(put 'ebrowse-ignoring-completion-case 'lisp-indent-hook 0) -;; eval:(put 'ebrowse-for-all-trees 'lisp-indent-hook 1) -;; End: - ;;; ebrowse.el ends here diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index f39ecf9b7bc..2f44118edb5 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -231,8 +231,35 @@ Comments in the form will be lost." (setq-local electric-pair-text-pairs elisp-pairs))))) (remove-hook 'electric-pair-mode-hook #'emacs-lisp-set-electric-text-pairs)) +(defun elisp-enable-lexical-binding (&optional interactive) + "Make the current buffer use `lexical-binding'." + (interactive "p") + (if lexical-binding + (when interactive + (message "lexical-binding already enabled!") + (ding)) + (when (or (not interactive) + (y-or-n-p (format "Enable lexical-binding in this %s? " + (if buffer-file-name "file" "buffer")))) + (setq-local lexical-binding t) + (add-file-local-variable-prop-line 'lexical-binding t interactive)))) + +(defvar elisp--dynlex-modeline-map + (let ((map (make-sparse-keymap))) + (define-key map [mode-line mouse-1] 'elisp-enable-lexical-binding) + map)) + ;;;###autoload -(define-derived-mode emacs-lisp-mode prog-mode "Emacs-Lisp" +(define-derived-mode emacs-lisp-mode lisp-data-mode + `("ELisp" + (lexical-binding (:propertize "/l" + help-echo "Using lexical-binding mode") + (:propertize "/d" + help-echo "Using old dynamic scoping mode\n\ +mouse-1: Enable lexical-binding mode" + face warning + mouse-face mode-line-highlight + local-map ,elisp--dynlex-modeline-map))) "Major mode for editing Lisp code to run in Emacs. Commands: Delete converts tabs to spaces as it moves back. @@ -241,35 +268,28 @@ Blank lines separate paragraphs. Semicolons start comments. \\{emacs-lisp-mode-map}" :group 'lisp (defvar project-vc-external-roots-function) - (lisp-mode-variables nil nil 'elisp) + (setcar font-lock-defaults + '(lisp-el-font-lock-keywords + lisp-el-font-lock-keywords-1 + lisp-el-font-lock-keywords-2)) + (setf (nth 2 font-lock-defaults) nil) (add-hook 'after-load-functions #'elisp--font-lock-flush-elisp-buffers) (if (boundp 'electric-pair-text-pairs) (setq-local electric-pair-text-pairs - (append '((?\` . ?\') (?‘ . ?’)) + (append '((?\` . ?\') (?\‘ . ?\’)) electric-pair-text-pairs)) (add-hook 'electric-pair-mode-hook #'emacs-lisp-set-electric-text-pairs)) - (setq-local electric-quote-string t) - (setq imenu-case-fold-search nil) - (add-function :before-until (local 'eldoc-documentation-function) - #'elisp-eldoc-documentation-function) + (add-hook 'eldoc-documentation-functions + #'elisp-eldoc-funcall nil t) + (add-hook 'eldoc-documentation-functions + #'elisp-eldoc-var-docstring nil t) (add-hook 'xref-backend-functions #'elisp--xref-backend nil t) (setq-local project-vc-external-roots-function #'elisp-load-path-roots) (add-hook 'completion-at-point-functions #'elisp-completion-at-point nil 'local) - ;; .dir-locals.el and lock files will cause the byte-compiler and - ;; checkdoc emit spurious warnings, because they don't follow the - ;; conventions of Emacs Lisp sources. Until we have a better fix, - ;; like teaching elisp-mode about files that only hold data - ;; structures, we disable the ELisp Flymake backend for these files. - (unless - (let* ((bfname (buffer-file-name)) - (fname (and (stringp bfname) (file-name-nondirectory bfname)))) - (and (stringp fname) - (or (string-match "\\`\\.#" fname) - (string-equal dir-locals-file fname)))) - (add-hook 'flymake-diagnostic-functions #'elisp-flymake-checkdoc nil t) - (add-hook 'flymake-diagnostic-functions - #'elisp-flymake-byte-compile nil t))) + (add-hook 'flymake-diagnostic-functions #'elisp-flymake-checkdoc nil t) + (add-hook 'flymake-diagnostic-functions + #'elisp-flymake-byte-compile nil t)) ;; Font-locking support. @@ -637,18 +657,16 @@ functions are annotated with \"<f>\" via the ;; WORKAROUND: This is nominally a constant, but the text properties ;; are not preserved thru dump if use defconst. See bug#21237. (defvar elisp--xref-format - (let ((str "(%s %s)")) - (put-text-property 1 3 'face 'font-lock-keyword-face str) - (put-text-property 4 6 'face 'font-lock-function-name-face str) - str)) + #("(%s %s)" + 1 3 (face font-lock-keyword-face) + 4 6 (face font-lock-function-name-face))) ;; WORKAROUND: This is nominally a constant, but the text properties ;; are not preserved thru dump if use defconst. See bug#21237. (defvar elisp--xref-format-extra - (let ((str "(%s %s %s)")) - (put-text-property 1 3 'face 'font-lock-keyword-face str) - (put-text-property 4 6 'face 'font-lock-function-name-face str) - str)) + #("(%s %s %s)" + 1 3 (face font-lock-keyword-face) + 4 6 (face font-lock-function-name-face))) (defvar find-feature-regexp);; in find-func.el @@ -845,11 +863,12 @@ non-nil result supercedes the xrefs produced by xrefs)) -(declare-function project-external-roots "project") +(declare-function xref-apropos-regexp "xref" (pattern)) -(cl-defmethod xref-backend-apropos ((_backend (eql elisp)) regexp) +(cl-defmethod xref-backend-apropos ((_backend (eql elisp)) pattern) (apply #'nconc - (let (lst) + (let ((regexp (xref-apropos-regexp pattern)) + lst) (dolist (sym (apropos-internal regexp)) (push (elisp--xref-find-definitions sym) lst)) (nreverse lst)))) @@ -1386,20 +1405,27 @@ which see." or argument string for functions. 2 - `function' if function args, `variable' if variable documentation.") -(defun elisp-eldoc-documentation-function () - "`eldoc-documentation-function' (which see) for Emacs Lisp." - (let ((current-symbol (elisp--current-symbol)) - (current-fnsym (elisp--fnsym-in-current-sexp))) - (cond ((null current-fnsym) - nil) - ((eq current-symbol (car current-fnsym)) - (or (apply #'elisp-get-fnsym-args-string current-fnsym) - (elisp-get-var-docstring current-symbol))) - (t - (or (elisp-get-var-docstring current-symbol) - (apply #'elisp-get-fnsym-args-string current-fnsym)))))) - -(defun elisp-get-fnsym-args-string (sym &optional index prefix) +(defun elisp-eldoc-funcall (callback &rest _ignored) + "Document function call at point. +Intended for `eldoc-documentation-functions' (which see)." + (let* ((sym-info (elisp--fnsym-in-current-sexp)) + (fn-sym (car sym-info))) + (when fn-sym + (funcall callback (apply #'elisp-get-fnsym-args-string sym-info) + :thing fn-sym + :face (if (functionp fn-sym) + 'font-lock-function-name-face + 'font-lock-keyword-face))))) + +(defun elisp-eldoc-var-docstring (callback &rest _ignored) + "Document variable at point. +Intended for `eldoc-documentation-functions' (which see)." + (let ((sym (elisp--current-symbol))) + (when sym (funcall callback (elisp-get-var-docstring sym) + :thing sym + :face 'font-lock-variable-name-face)))) + +(defun elisp-get-fnsym-args-string (sym &optional index) "Return a string containing the parameter list of the function SYM. If SYM is a subr and no arglist is obtainable from the docstring or elsewhere, return a 1-line docstring." @@ -1425,20 +1451,13 @@ or elsewhere, return a 1-line docstring." ;; Stringify, and store before highlighting, downcasing, etc. (elisp--last-data-store sym (elisp-function-argstring args) 'function)))))) - ;; Highlight, truncate. + ;; Highlight (if argstring (elisp--highlight-function-argument - sym argstring index - (or prefix - (concat (propertize (symbol-name sym) 'face - (if (functionp sym) - 'font-lock-function-name-face - 'font-lock-keyword-face)) - ": ")))))) - -(defun elisp--highlight-function-argument (sym args index prefix) - "Highlight argument INDEX in ARGS list for function SYM. -In the absence of INDEX, just call `eldoc-docstring-format-sym-doc'." + sym argstring index)))) + +(defun elisp--highlight-function-argument (sym args index) + "Highlight argument INDEX in ARGS list for function SYM." ;; FIXME: This should probably work on the list representation of `args' ;; rather than its string representation. ;; FIXME: This function is much too long, we need to split it up! @@ -1541,7 +1560,6 @@ In the absence of INDEX, just call `eldoc-docstring-format-sym-doc'." (when start (setq doc (copy-sequence args)) (add-text-properties start end (list 'face argument-face) doc)) - (setq doc (eldoc-docstring-format-sym-doc prefix doc)) doc))) ;; Return a string containing a brief (one-line) documentation string for @@ -1554,9 +1572,7 @@ In the absence of INDEX, just call `eldoc-docstring-format-sym-doc'." (t (let ((doc (documentation-property sym 'variable-documentation t))) (when doc - (let ((doc (eldoc-docstring-format-sym-doc - sym (elisp--docstring-first-line doc) - 'font-lock-variable-name-face))) + (let ((doc (elisp--docstring-first-line doc))) (elisp--last-data-store sym doc 'variable))))))) (defun elisp--last-data-store (symbol doc type) diff --git a/lisp/progmodes/etags.el b/lisp/progmodes/etags.el index 897f105019e..edadbbdafc1 100644 --- a/lisp/progmodes/etags.el +++ b/lisp/progmodes/etags.el @@ -2080,8 +2080,8 @@ file name, add `tag-partial-file-name-match-p' to the list value.") (cl-defmethod xref-backend-definitions ((_backend (eql etags)) symbol) (etags--xref-find-definitions symbol)) -(cl-defmethod xref-backend-apropos ((_backend (eql etags)) symbol) - (etags--xref-find-definitions symbol t)) +(cl-defmethod xref-backend-apropos ((_backend (eql etags)) pattern) + (etags--xref-find-definitions (xref-apropos-regexp pattern) t)) (defun etags--xref-find-definitions (pattern &optional regexp?) ;; This emulates the behavior of `find-tag-in-order' but instead of diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el index 1ed733b7e37..37e73241e5d 100644 --- a/lisp/progmodes/flymake.el +++ b/lisp/progmodes/flymake.el @@ -4,9 +4,12 @@ ;; Author: Pavel Kobyakov <pk_at_work@yahoo.com> ;; Maintainer: João Távora <joaotavora@gmail.com> -;; Version: 1.0.8 -;; Package-Requires: ((emacs "26.1")) +;; Version: 1.0.9 ;; Keywords: c languages tools +;; Package-Requires: ((emacs "26.1") (eldoc "1.1.0")) + +;; This is a GNU ELPA :core package. Avoid functionality that is not +;; compatible with the version of Emacs recorded above. ;; This file is part of GNU Emacs. @@ -999,6 +1002,7 @@ special *Flymake log* buffer." :group 'flymake :lighter (add-hook 'after-change-functions 'flymake-after-change-function nil t) (add-hook 'after-save-hook 'flymake-after-save-hook nil t) (add-hook 'kill-buffer-hook 'flymake-kill-buffer-hook nil t) + (add-hook 'eldoc-documentation-functions 'flymake-eldoc-function nil t) ;; If Flymake happened to be alrady already ON, we must cleanup ;; existing diagnostic overlays, lest we forget them by blindly @@ -1016,6 +1020,7 @@ special *Flymake log* buffer." :group 'flymake :lighter (remove-hook 'after-save-hook 'flymake-after-save-hook t) (remove-hook 'kill-buffer-hook 'flymake-kill-buffer-hook t) ;;+(remove-hook 'find-file-hook (function flymake-find-file-hook) t) + (remove-hook 'eldoc-documentation-functions 'flymake-eldoc-function t) (mapc #'delete-overlay (flymake--overlays)) @@ -1083,6 +1088,14 @@ START and STOP and LEN are as in `after-change-functions'." (flymake-mode) (flymake-log :warning "Turned on in `flymake-find-file-hook'"))) +(defun flymake-eldoc-function (report-doc &rest _) + "Document diagnostics at point. +Intended for `eldoc-documentation-functions' (which see)." + (let ((diags (flymake-diagnostics (point)))) + (when diags + (funcall report-doc + (mapconcat #'flymake-diagnostic-text diags "\n"))))) + (defun flymake-goto-next-error (&optional n filter interactive) "Go to Nth next Flymake diagnostic that matches FILTER. Interactively, always move to the next diagnostic. With a prefix diff --git a/lisp/progmodes/fortran.el b/lisp/progmodes/fortran.el index 811951eaaaf..abc860b9478 100644 --- a/lisp/progmodes/fortran.el +++ b/lisp/progmodes/fortran.el @@ -429,7 +429,7 @@ The only difference is, it returns t in a case when the default returns nil." fortran-font-lock-keywords-1 ;; All type specifiers plus their declared items. (list - (list (concat fortran-type-types "[ \t(/]*\\(*\\)?") + (list (concat fortran-type-types "[ \t(/]*\\(\\*\\)?") ;; Type specifier. '(1 font-lock-type-face) ;; Declaration item (or just /.../ block name). diff --git a/lisp/progmodes/gdb-mi.el b/lisp/progmodes/gdb-mi.el index e785acd2840..c1184211d06 100644 --- a/lisp/progmodes/gdb-mi.el +++ b/lisp/progmodes/gdb-mi.el @@ -92,6 +92,8 @@ (require 'json) (require 'bindat) (require 'cl-lib) +(require 'cl-seq) +(eval-when-compile (require 'pcase)) (declare-function speedbar-change-initial-expansion-list "speedbar" (new-default)) @@ -105,13 +107,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. @@ -211,7 +224,9 @@ Only used for files that Emacs can't find.") (defvar gdb-source-file-list nil "List of source files for the current executable.") (defvar gdb-first-done-or-error t) -(defvar gdb-source-window nil) +(defvar gdb-source-window-list nil + "List of windows used for displaying source files. +Sorted in most-recently-visited-first order.") (defvar gdb-inferior-status nil) (defvar gdb-continuation nil) (defvar gdb-supports-non-stop nil) @@ -242,6 +257,27 @@ Possible values are these symbols: disposition of output generated by commands that gdb mode sends to gdb on its own behalf.") +(defvar gdb--window-configuration-before nil + "Stores the window configuration before starting GDB.") + +(defcustom gdb-restore-window-configuration-after-quit nil + "If non-nil, restore window configuration as of before GDB started. + +Possible values are: + t -- Always restore. + nil -- Don't restore. + `if-gdb-show-main' -- Restore only if variable `gdb-show-main' + is non-nil + `if-gdb-many-windows' -- Restore only if variable `gdb-many-windows' + is non-nil." + :type '(choice + (const :tag "Always restore" t) + (const :tag "Don't restore" nil) + (const :tag "Depends on `gdb-show-main'" 'if-gdb-show-main) + (const :tag "Depends on `gdb-many-windows'" 'if-gdb-many-windows)) + :group 'gdb + :version "28.1") + (defcustom gdb-discard-unordered-replies t "Non-nil means discard any out-of-order GDB replies. This protects against lost GDB replies, assuming that GDB always @@ -592,6 +628,40 @@ Also display the main routine in the disassembly buffer if present." :group 'gdb :version "22.1") +(defcustom gdb-window-configuration-directory user-emacs-directory + "Directory where GDB window configuration files are stored. +If nil, use `default-directory'." + :type 'string + :group 'gdb + :version "28.1") + +(defcustom gdb-default-window-configuration-file nil + "If non-nil, load this window configuration (layout) on startup. +This should be the full name of the window configuration file. +If this is not an absolute path, GDB treats it as a relative path +and looks under `gdb-window-configuration-directory'. + +Note that this variable only takes effect when variable +`gdb-many-windows' is t." + :type 'string + :group 'gdb + :version "28.1") + +(defcustom gdb-display-source-buffer-action '(nil . ((inhibit-same-window . t))) + "`display-buffer' action used when GDB displays a source buffer." + :type 'list + :group 'gdb + :version "28.1") + +(defcustom gdb-max-source-window-count 1 + "Maximum number of source windows to use. +Until there are such number of source windows on screen, GDB +tries to open a new window when visiting a new source file; after +that GDB starts to reuse existing source windows." + :type 'number + :group 'gdb + :version "28.1") + (defvar gdbmi-debug-mode nil "When non-nil, print the messages sent/received from GDB/MI in *Messages*.") @@ -750,6 +820,12 @@ detailed description of this mode. (gdb-restore-windows) (error "Multiple debugging requires restarting in text command mode")) + + ;; Save window configuration before starting gdb so we can restore + ;; it after gdb quits. Save it regardless of the value of + ;; `gdb-restore-window-configuration-after-quit'. + (setq gdb--window-configuration-before (window-state-get)) + ;; (gud-common-init command-line nil 'gud-gdbmi-marker-filter) @@ -925,7 +1001,7 @@ detailed description of this mode. gdb-first-done-or-error t gdb-buffer-fringe-width (car (window-fringes)) gdb-debug-log nil - gdb-source-window nil + gdb-source-window-list nil gdb-inferior-status nil gdb-continuation nil gdb-buf-publisher '() @@ -1035,7 +1111,10 @@ no input, and GDB is waiting for input." (declare-function tooltip-show "tooltip" (text &optional use-echo-area)) -(defconst gdb--string-regexp "\"\\(?:[^\\\"]\\|\\\\.\\)*\"") +(defconst gdb--string-regexp (rx "\"" + (* (or (seq "\\" nonl) + (not (any "\"\\")))) + "\"")) (defun gdb-tooltip-print (expr) (with-current-buffer (gdb-get-buffer 'gdb-partial-output-buffer) @@ -1667,25 +1746,25 @@ this trigger is subscribed to `gdb-buf-publisher' and called with "Interrupt the program being debugged." (interactive) (interrupt-process - (get-buffer-process gud-comint-buffer) comint-ptyp)) + (get-buffer-process (gdb-get-buffer-create 'gdb-inferior-io)) comint-ptyp)) (defun gdb-io-quit () "Send quit signal to the program being debugged." (interactive) (quit-process - (get-buffer-process gud-comint-buffer) comint-ptyp)) + (get-buffer-process (gdb-get-buffer-create 'gdb-inferior-io)) comint-ptyp)) (defun gdb-io-stop () "Stop the program being debugged." (interactive) (stop-process - (get-buffer-process gud-comint-buffer) comint-ptyp)) + (get-buffer-process (gdb-get-buffer-create 'gdb-inferior-io)) comint-ptyp)) (defun gdb-io-eof () "Send end-of-file to the program being debugged." (interactive) (process-send-eof - (get-buffer-process gud-comint-buffer))) + (get-buffer-process (gdb-get-buffer-create 'gdb-inferior-io)))) (defun gdb-clear-inferior-io () (with-current-buffer (gdb-get-buffer-create 'gdb-inferior-io) @@ -1788,7 +1867,8 @@ static char *magick[] = { "\\|def\\(i\\(ne?\\)?\\)?\\|doc\\(u\\(m\\(e\\(nt?\\)?\\)?\\)?\\)?\\|" gdb-python-guile-commands-regexp "\\|while-stepping\\|stepp\\(i\\(ng?\\)?\\)?\\|ws\\|actions" - "\\)\\([[:blank:]]+\\([^[:blank:]]*\\)\\)?$") + "\\|expl\\(o\\(re?\\)?\\)?" + "\\)\\([[:blank:]]+\\([^[:blank:]]*\\)\\)*$") "Regexp matching GDB commands that enter a recursive reading loop. As long as GDB is in the recursive reading loop, it does not expect commands to be prefixed by \"-interpreter-exec console\".") @@ -2007,17 +2087,36 @@ is running." ;; GDB frame (after up, down etc). If no GDB frame is visible but the last ;; visited breakpoint is, use that window. (defun gdb-display-source-buffer (buffer) - (let* ((last-window (if gud-last-last-frame - (get-buffer-window - (gud-find-file (car gud-last-last-frame))))) - (source-window (or last-window - (if (and gdb-source-window - (window-live-p gdb-source-window)) - gdb-source-window)))) - (when source-window - (setq gdb-source-window source-window) - (set-window-buffer source-window buffer)) - source-window)) + "Find a window to display BUFFER. +Always find a window to display buffer, and return it." + ;; This function doesn't take care of setting up source window(s) at startup, + ;; that's handled by `gdb-setup-windows' (if `gdb-many-windows' is non-nil). + ;; If `buffer' is already shown in a window, use that window. + (or (get-buffer-window buffer) + (progn + ;; First, update the window list. + (setq gdb-source-window-list + (cl-remove-duplicates + (cl-remove-if-not + (lambda (win) + (and (window-live-p win) + (eq (window-frame win) + (selected-frame)))) + gdb-source-window-list))) + ;; Should we create a new window or reuse one? + (if (> gdb-max-source-window-count + (length gdb-source-window-list)) + ;; Create a new window, push it to window list and return it. + (car (push (display-buffer buffer gdb-display-source-buffer-action) + gdb-source-window-list)) + ;; Reuse a window, we use the oldest window and put that to + ;; the front of the window list. + (let ((last-win (car (last gdb-source-window-list))) + (rest (butlast gdb-source-window-list))) + (set-window-buffer last-win buffer) + (setq gdb-source-window-list + (cons last-win rest)) + last-win))))) (defun gdbmi-start-with (str offset match) @@ -2446,7 +2545,13 @@ file names include non-ASCII characters." gdb-filter-output) -(defun gdb-gdb (_output-field)) +(defun gdb-gdb (_output-field) + ;; This is needed because the "explore" command is not ended by the + ;; likes of "end" or "quit", but instead by a RET at the approriate + ;; place, and we know we have exited "explore" when we get the + ;; "(gdb)" prompt. + (and (> gdb-control-level 0) + (setq gdb-control-level (1- gdb-control-level)))) (defun gdb-shell (output-field) (setq gdb-filter-output @@ -3450,7 +3555,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 +3595,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 +3611,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 +3653,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 +3836,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 +3865,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 @@ -3986,9 +4107,7 @@ DOC is an optional documentation string." (let* ((buffer (find-file-noselect (if (file-exists-p file) file (cdr (assoc bptno gdb-location-alist))))) - (window (or (gdb-display-source-buffer buffer) - (display-buffer buffer)))) - (setq gdb-source-window window) + (window (gdb-display-source-buffer buffer))) (with-current-buffer buffer (goto-char (point-min)) (forward-line (1- (string-to-number line))) @@ -4464,6 +4583,26 @@ SPLIT-HORIZONTAL and show BUF in the new window." (define-key gud-menu-map [displays] `(menu-item "GDB-Windows" ,menu :visible (eq gud-minor-mode 'gdbmi))) + (define-key menu [gdb-restore-windows] + '(menu-item "Restore Initial Layout" gdb-restore-windows + :help "Restore the initial GDB window layout.")) + ;; Window layout vs window configuration: We use "window layout" in + ;; GDB UI. Internally we refer to "window configuration" because + ;; that's the data structure used to store window layouts. Though + ;; bare in mind that there is a small difference between what we + ;; store and what normal window configuration functions + ;; output. Because GDB buffers (source, local, breakpoint, etc) are + ;; different between each debugging sessions, simply save/load + ;; window configurations doesn't + ;; work. `gdb-save-window-configuration' and + ;; `gdb-load-window-configuration' do some tricks to store and + ;; recreate each buffer in the layout. + (define-key menu [load-layout] '("Load Layout" "Load GDB window configuration (layout) from a file" . gdb-load-window-configuration)) + (define-key menu [save-layout] '("Save Layout" "Save current GDB window configuration (layout) to a file" . gdb-save-window-configuration)) + (define-key menu [restore-layout-after-quit] + '(menu-item "Restore Layout After Quit" gdb-toggle-restore-window-configuration + :button (:toggle . gdb-restore-window-configuration-after-quit) + :help "Toggle between always restore the window configuration (layout) after GDB quits and never restore.\n You can also change this setting in Customize to conditionally restore.")) (define-key menu [gdb] '("Gdb" . gdb-display-gdb-buffer)) (define-key menu [threads] '("Threads" . gdb-display-threads-buffer)) (define-key menu [memory] '("Memory" . gdb-display-memory-buffer)) @@ -4502,9 +4641,6 @@ SPLIT-HORIZONTAL and show BUF in the new window." '(menu-item "Display Other Windows" gdb-many-windows :help "Toggle display of locals, stack and breakpoint information" :button (:toggle . gdb-many-windows))) - (define-key menu [gdb-restore-windows] - '(menu-item "Restore Window Layout" gdb-restore-windows - :help "Restore standard layout for debug session.")) (define-key menu [sep1] '(menu-item "--")) (define-key menu [all-threads] @@ -4579,41 +4715,173 @@ window is dedicated." (set-window-buffer window (get-buffer name)) (set-window-dedicated-p window t)) +(defun gdb-toggle-restore-window-configuration () + "Toggle whether to restore window configuration when GDB quits." + (interactive) + (setq gdb-restore-window-configuration-after-quit + (not gdb-restore-window-configuration-after-quit))) + +(defun gdb-get-source-buffer () + "Return a buffer displaying source file or nil if we can't find one. +The source file is the file that contains the source location +where GDB stops. There could be multiple source files during a +debugging session, we get the most recently showed one. If +program hasn't started running yet, the source file is the \"main +file\" where the GDB session starts (see `gdb-main-file')." + (if gud-last-last-frame + (gud-find-file (car gud-last-last-frame)) + (when gdb-main-file + (gud-find-file gdb-main-file)))) + (defun gdb-setup-windows () - "Layout the window pattern for option `gdb-many-windows'." - (gdb-get-buffer-create 'gdb-locals-buffer) - (gdb-get-buffer-create 'gdb-stack-buffer) - (gdb-get-buffer-create 'gdb-breakpoints-buffer) - (set-window-dedicated-p (selected-window) nil) - (switch-to-buffer gud-comint-buffer) - (delete-other-windows) - (let ((win0 (selected-window)) - (win1 (split-window nil ( / ( * (window-height) 3) 4))) - (win2 (split-window nil ( / (window-height) 3))) - (win3 (split-window-right))) - (gdb-set-window-buffer (gdb-locals-buffer-name) nil win3) - (select-window win2) - (set-window-buffer - win2 - (if gud-last-last-frame - (gud-find-file (car gud-last-last-frame)) - (if gdb-main-file - (gud-find-file gdb-main-file) - ;; Put buffer list in window if we - ;; can't find a source file. - (list-buffers-noselect)))) - (setq gdb-source-window (selected-window)) - (let ((win4 (split-window-right))) - (gdb-set-window-buffer - (gdb-get-buffer-create 'gdb-inferior-io) nil win4)) - (select-window win1) - (gdb-set-window-buffer (gdb-stack-buffer-name)) - (let ((win5 (split-window-right))) - (gdb-set-window-buffer (if gdb-show-threads-by-default - (gdb-threads-buffer-name) - (gdb-breakpoints-buffer-name)) - nil win5)) - (select-window win0))) + "Lay out the window pattern for option `gdb-many-windows'." + (if gdb-default-window-configuration-file + (gdb-load-window-configuration + (if (file-name-absolute-p gdb-default-window-configuration-file) + gdb-default-window-configuration-file + (expand-file-name gdb-default-window-configuration-file + gdb-window-configuration-directory))) + ;; Create default layout as before. + (gdb-get-buffer-create 'gdb-locals-buffer) + (gdb-get-buffer-create 'gdb-stack-buffer) + (gdb-get-buffer-create 'gdb-breakpoints-buffer) + (set-window-dedicated-p (selected-window) nil) + (switch-to-buffer gud-comint-buffer) + (delete-other-windows) + (let ((win0 (selected-window)) + (win1 (split-window nil ( / ( * (window-height) 3) 4))) + (win2 (split-window nil ( / (window-height) 3))) + (win3 (split-window-right))) + (gdb-set-window-buffer (gdb-locals-buffer-name) nil win3) + (select-window win2) + (set-window-buffer win2 (or (gdb-get-source-buffer) + (list-buffers-noselect))) + (setq gdb-source-window-list (list (selected-window))) + (let ((win4 (split-window-right))) + (gdb-set-window-buffer + (gdb-get-buffer-create 'gdb-inferior-io) nil win4)) + (select-window win1) + (gdb-set-window-buffer (gdb-stack-buffer-name)) + (let ((win5 (split-window-right))) + (gdb-set-window-buffer (if gdb-show-threads-by-default + (gdb-threads-buffer-name) + (gdb-breakpoints-buffer-name)) + nil win5)) + (select-window win0)))) + +(defun gdb-buffer-p (buffer) + "Return t if BUFFER is GDB-related." + (with-current-buffer buffer + (eq gud-minor-mode 'gdbmi))) + +(defun gdb-function-buffer-p (buffer) + "Return t if BUFFER is a GDB function buffer. + +Function buffers are locals buffer, registers buffer, etc, but +not including main command buffer (the one where you type GDB +commands) or source buffers (that display program source code)." + (with-current-buffer buffer + (derived-mode-p 'gdb-parent-mode 'gdb-inferior-io-mode))) + +(defun gdb--buffer-type (buffer) + "Return the type of BUFFER if it is a function buffer. +Buffer type is like `gdb-registers-type', `gdb-stack-buffer'. +These symbols are used by `gdb-get-buffer-create'. + +Return nil if BUFFER is not a GDB function buffer." + (with-current-buffer buffer + (cl-loop for rule in gdb-buffer-rules + for mode-name = (gdb-rules-buffer-mode rule) + for type = (car rule) + if (eq mode-name major-mode) + return type + finally return nil))) + +(defun gdb-save-window-configuration (file) + "Save current window configuration (layout) to FILE. +You can later restore this configuration from that file by +`gdb-load-window-configuration'." + (interactive (list (read-file-name + "Save window configuration to file: " + (or gdb-window-configuration-directory + default-directory)))) + ;; We replace the buffer in each window with a placeholder, store + ;; the buffer type (register, breakpoint, etc) in window parameters, + ;; and write the window configuration to the file. + (save-window-excursion + (let ((placeholder (get-buffer-create " *gdb-placeholder*")) + (window-persistent-parameters + (cons '(gdb-buffer-type . writable) window-persistent-parameters))) + (unwind-protect + (dolist (win (window-list nil 'no-minibuffer)) + (select-window win) + (when (gdb-buffer-p (current-buffer)) + (set-window-parameter + nil 'gdb-buffer-type + (cond ((gdb-function-buffer-p (current-buffer)) + ;; 1) If a user arranged the window + ;; configuration herself and saves it, windows + ;; are probably not dedicated. 2) We use the + ;; same dedication flag as in + ;; `gdb-display-buffer'. + (set-window-dedicated-p nil t) + ;; We save this gdb-buffer-type symbol so + ;; we can later pass it to `gdb-get-buffer-create'; + ;; one example: `gdb-registers-buffer'. + (or (gdb--buffer-type (current-buffer)) + (error "Unrecognized gdb buffer mode: %s" major-mode))) + ;; Command buffer. + ((derived-mode-p 'gud-mode) 'command) + ;; Consider everything else as source buffer. + (t 'source))) + (with-window-non-dedicated nil + (set-window-buffer nil placeholder) + (set-window-prev-buffers (selected-window) nil) + (set-window-next-buffers (selected-window) nil)))) + ;; Save the window configuration to FILE. + (let ((window-config (window-state-get nil t))) + (with-temp-buffer + (prin1 window-config (current-buffer)) + (write-file file t))) + (kill-buffer placeholder))))) + +(defun gdb-load-window-configuration (file) + "Restore window configuration (layout) from FILE. +FILE should be a window configuration file saved by +`gdb-save-window-configuration'." + (interactive (list (read-file-name + "Restore window configuration from file: " + (or gdb-window-configuration-directory + default-directory)))) + ;; Basically, we restore window configuration and go through each + ;; window and restore the function buffers. + (let* ((placeholder (get-buffer-create " *gdb-placeholder*"))) + (unwind-protect ; Don't leak buffer. + (let ((window-config (with-temp-buffer + (insert-file-contents file) + ;; We need to go to point-min because + ;; `read' reads from point + (goto-char (point-min)) + (read (current-buffer)))) + (source-buffer (or (gdb-get-source-buffer) + ;; Do the same thing as in + ;; `gdb-setup-windows' if no source + ;; buffer is found. + (list-buffers-noselect))) + buffer-type) + (window-state-put window-config (frame-root-window)) + (dolist (window (window-list nil 'no-minibuffer)) + (with-selected-window window + (setq buffer-type (window-parameter nil 'gdb-buffer-type)) + (pcase buffer-type + ('source (when source-buffer + (set-window-buffer nil source-buffer) + (push (selected-window) gdb-source-window-list))) + ('command (switch-to-buffer gud-comint-buffer)) + (_ (let ((buffer (gdb-get-buffer-create buffer-type))) + (with-window-non-dedicated nil + (set-window-buffer nil buffer)))))))) + (kill-buffer placeholder)))) (define-minor-mode gdb-many-windows "If nil just pop up the GUD buffer unless `gdb-show-main' is t. @@ -4631,7 +4899,12 @@ of the debugged program. Non-nil means display the layout shown for (defun gdb-restore-windows () "Restore the basic arrangement of windows used by gdb. -This arrangement depends on the value of option `gdb-many-windows'." +This arrangement depends on the values of variable +`gdb-many-windows' and `gdb-default-window-configuration-file'." + ;; This function is used when the user messed up window + ;; configuration and wants to "reset to default". The function that + ;; sets up window configuration on start up is + ;; `gdb-get-source-file'. (interactive) (switch-to-buffer gud-comint-buffer) ;Select the right window and frame. (delete-other-windows) @@ -4644,7 +4917,7 @@ This arrangement depends on the value of option `gdb-many-windows'." (if gud-last-last-frame (gud-find-file (car gud-last-last-frame)) (gud-find-file gdb-main-file))) - (setq gdb-source-window win))))) + (setq gdb-source-window-list (list win)))))) ;; Called from `gud-sentinel' in gud.el: (defun gdb-reset () @@ -4678,11 +4951,25 @@ Kills the gdb buffers, and resets variables and the source buffers." (if (boundp 'speedbar-frame) (speedbar-timer-fn)) (setq gud-running nil) (setq gdb-active-process nil) - (remove-hook 'after-save-hook 'gdb-create-define-alist t)) + (remove-hook 'after-save-hook 'gdb-create-define-alist t) + ;; Recover window configuration. + (when (or (eq gdb-restore-window-configuration-after-quit t) + (and (eq gdb-restore-window-configuration-after-quit + 'if-gdb-show-main) + gdb-show-main) + (and (eq gdb-restore-window-configuration-after-quit + 'if-gdb-many-windows) + gdb-many-windows)) + (when gdb--window-configuration-before + (window-state-put gdb--window-configuration-before) + ;; This way we don't accidentally restore an outdated window + ;; configuration. + (setq gdb--window-configuration-before nil)))) (defun gdb-get-source-file () "Find the source file where the program starts and display it with related buffers, if required." + ;; This function is called only once on startup. (goto-char (point-min)) (if (re-search-forward gdb-source-file-regexp nil t) (setq gdb-main-file (read (match-string 1)))) diff --git a/lisp/progmodes/glasses.el b/lisp/progmodes/glasses.el index cad74f9f63a..ab65a1590c0 100644 --- a/lisp/progmodes/glasses.el +++ b/lisp/progmodes/glasses.el @@ -1,4 +1,4 @@ -;;; glasses.el --- make cantReadThis readable +;;; glasses.el --- make cantReadThis readable -*- lexical-binding: t; -*- ;; Copyright (C) 1999-2020 Free Software Foundation, Inc. @@ -66,7 +66,6 @@ defined by `glasses-original-separator'. If you don't want to add missing separators, set `glasses-separator' to an empty string. If you don't want to replace existent separators, set `glasses-original-separator' to an empty string." - :group 'glasses :type 'string :set 'glasses-custom-set :initialize 'custom-initialize-default) @@ -78,7 +77,6 @@ For instance, if you set it to \"_\" and set `glasses-separator' to \"-\", underscore separators are displayed as hyphens. If `glasses-original-separator' is an empty string, no such display change is performed." - :group 'glasses :type 'string :set 'glasses-custom-set :initialize 'custom-initialize-default @@ -92,7 +90,6 @@ If it is nil, no face is placed at the capitalized letter. For example, you can set `glasses-separator' to an empty string and `glasses-face' to `bold'. Then unreadable identifiers will have no separators, but will have their capitals in bold." - :group 'glasses :type '(choice (const :tag "None" nil) face) :set 'glasses-custom-set :initialize 'custom-initialize-default) @@ -100,7 +97,6 @@ but will have their capitals in bold." (defcustom glasses-separate-parentheses-p t "If non-nil, ensure space between an identifier and an opening parenthesis." - :group 'glasses :type 'boolean) (defcustom glasses-separate-parentheses-exceptions @@ -108,7 +104,6 @@ but will have their capitals in bold." "List of regexp that are exceptions for `glasses-separate-parentheses-p'. They are matched to the current line truncated to the point where the parenthesis expression starts." - :group 'glasses :type '(repeat regexp)) (defcustom glasses-separate-capital-groups t @@ -116,7 +111,6 @@ parenthesis expression starts." When the value is non-nil, HTMLSomething and IPv6 are displayed as HTML_Something and I_Pv6 respectively. Set the value to nil if you prefer to display them unchanged." - :group 'glasses :type 'boolean :version "24.1") @@ -124,7 +118,6 @@ if you prefer to display them unchanged." "If non-nil, downcase embedded capital letters in identifiers. Only identifiers starting with lower case letters are affected, letters inside other identifiers are unchanged." - :group 'glasses :type 'boolean :set 'glasses-custom-set :initialize 'custom-initialize-default) @@ -135,7 +128,6 @@ other identifiers are unchanged." Only words starting with this regexp are uncapitalized. The regexp is case sensitive. It has any effect only when `glasses-uncapitalize-p' is non-nil." - :group 'glasses :type 'regexp :set 'glasses-custom-set :initialize 'custom-initialize-default) @@ -149,7 +141,6 @@ file write then. Note the removal action does not try to be much clever, so it can remove real separators too." - :group 'glasses :type 'boolean) 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 540bc9ce7f3..092d15983e5 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'. @@ -2827,9 +2826,13 @@ Obeying it means displaying in another window the specified file and line." (buffer (with-current-buffer gud-comint-buffer (gud-find-file true-file))) - (window (and buffer - (or (get-buffer-window buffer) - (display-buffer buffer '(nil (inhibit-same-window . t)))))) + (window + (when buffer + (if (eq gud-minor-mode 'gdbmi) + (gdb-display-source-buffer buffer) + ;; Gud still has the old behavior. + (or (get-buffer-window buffer) + (display-buffer buffer '(nil (inhibit-same-window . t))))))) (pos)) (when buffer (with-current-buffer buffer @@ -2859,9 +2862,7 @@ Obeying it means displaying in another window the specified file and line." (widen) (goto-char pos)))) (when window - (set-window-point window gud-overlay-arrow-position) - (if (eq gud-minor-mode 'gdbmi) - (setq gdb-source-window window)))))) + (set-window-point window gud-overlay-arrow-position))))) ;; The gud-call function must do the right thing whether its invoking ;; keystroke is from the GUD buffer itself (via major-mode binding) 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/idlw-shell.el b/lisp/progmodes/idlw-shell.el index dba70cb2821..f875915ca8e 100644 --- a/lisp/progmodes/idlw-shell.el +++ b/lisp/progmodes/idlw-shell.el @@ -1598,7 +1598,7 @@ number.") "A regular expression to match any IDL error.") (defvar idlwave-shell-halting-error - "^% .*\n\\([^%].*\n\\)*% Execution halted at:\\(\\s-*\\S-+\\s-*[0-9]+\\s-*.*\\)\n" + "^% .*\n\\([^%].*\n\\)*% Execution halted at:\\(\\s-*\\S-+\\s-*[0-9]+.*\\)\n" "A regular expression to match errors which halt execution.") (defvar idlwave-shell-cant-continue-error @@ -2745,7 +2745,7 @@ Runs to the last statement and then steps 1 statement. Use the .out command." ;; event. mouse-drag-track does so. (if drag-track 'mouse-drag-track 'mouse-drag-region))) (funcall tracker event) - (idlwave-shell-print (if (idlwave-region-active-p) '(4) nil) + (idlwave-shell-print (if (region-active-p) '(4) nil) ,help ,ev)))) ;; Begin terrible hack section -- XEmacs tests for button2 explicitly @@ -2830,7 +2830,7 @@ from `idlwave-shell-examine-alist' via mini-buffer shortcut key." (cond ((equal arg '(16)) (setq expr (read-string "Expression: "))) - ((and (or arg (idlwave-region-active-p)) + ((and (or arg (region-active-p)) (< (- (region-end) (region-beginning)) 2000)) (setq beg (region-beginning) end (region-end))) diff --git a/lisp/progmodes/idlwave.el b/lisp/progmodes/idlwave.el index 2601c2e1653..f7e53ec02d6 100644 --- a/lisp/progmodes/idlwave.el +++ b/lisp/progmodes/idlwave.el @@ -154,21 +154,6 @@ (eval-when-compile (require 'cl-lib)) (require 'idlw-help) -;; For XEmacs -(unless (fboundp 'line-beginning-position) - (defalias 'line-beginning-position 'point-at-bol)) -(unless (fboundp 'line-end-position) - (defalias 'line-end-position 'point-at-eol)) -(unless (fboundp 'char-valid-p) - (defalias 'char-valid-p 'characterp)) -(unless (fboundp 'match-string-no-properties) - (defalias 'match-string-no-properties 'match-string)) - -(if (not (fboundp 'cancel-timer)) - (condition-case nil - (require 'timer) - (error nil))) - (declare-function idlwave-shell-get-path-info "idlw-shell") (declare-function idlwave-shell-temp-file "idlw-shell") (declare-function idlwave-shell-is-running "idlw-shell") @@ -314,7 +299,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 +1081,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 +1857,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 @@ -2091,11 +2077,7 @@ Returns point if comment found and nil otherwise." (backward-char 1) (point))))) -(defun idlwave-region-active-p () - "Should we operate on an active region?" - (if (fboundp 'use-region-p) - (use-region-p) - (region-active-p))) +(define-obsolete-function-alias 'idlwave-region-active-p 'use-region-p "28.1") (defun idlwave-show-matching-quote () "Insert quote and show matching quote if this is end of a string." 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/js.el b/lisp/progmodes/js.el index 5ec3e942753..5c50e2accdf 100644 --- a/lisp/progmodes/js.el +++ b/lisp/progmodes/js.el @@ -4570,7 +4570,7 @@ This function is intended for use in `after-change-functions'." ;; Comments (setq-local comment-start "// ") - (setq-local comment-start-skip "\\(//+\\|/\\*+\\)\\s *") + (setq-local comment-start-skip "\\(?://+\\|/\\*+\\)\\s *") (setq-local comment-end "") (setq-local fill-paragraph-function #'js-fill-paragraph) (setq-local normal-auto-fill-function #'js-do-auto-fill) @@ -4591,7 +4591,8 @@ This function is intended for use in `after-change-functions'." (setq imenu-create-index-function #'js--imenu-create-index) ;; for filling, pretend we're cc-mode - (c-init-language-vars js-mode) + (c-foreign-init-lit-pos-cache) + (add-hook 'before-change-functions #'c-foreign-truncate-lit-pos-cache nil t) (setq-local comment-line-break-function #'c-indent-new-comment-line) (setq-local comment-multi-line t) (setq-local electric-indent-chars 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/octave.el b/lisp/progmodes/octave.el index 9e039562549..e07f818a68a 100644 --- a/lisp/progmodes/octave.el +++ b/lisp/progmodes/octave.el @@ -619,8 +619,7 @@ Key bindings: (add-hook 'before-save-hook 'octave-sync-function-file-names nil t) (setq-local beginning-of-defun-function 'octave-beginning-of-defun) (and octave-font-lock-texinfo-comment (octave-font-lock-texinfo-comment)) - (add-function :before-until (local 'eldoc-documentation-function) - 'octave-eldoc-function) + (add-hook 'eldoc-documentation-functions 'octave-eldoc-function nil t) (easy-menu-add octave-mode-menu)) @@ -756,7 +755,7 @@ Key bindings: (setq font-lock-defaults '(inferior-octave-font-lock-keywords nil nil)) (setq-local info-lookup-mode 'octave-mode) - (setq-local eldoc-documentation-function 'octave-eldoc-function) + (add-hook 'eldoc-documentation-functions 'octave-eldoc-function nil t) (setq-local comint-input-ring-file-name (or (getenv "OCTAVE_HISTFILE") "~/.octave_hist")) @@ -1640,8 +1639,8 @@ code line." (nreverse result))))) (cdr octave-eldoc-cache)) -(defun octave-eldoc-function () - "A function for `eldoc-documentation-function' (which see)." +(defun octave-eldoc-function (&rest _ignored) + "A function for `eldoc-documentation-functions' (which see)." (when (inferior-octave-process-live-p) (let* ((ppss (syntax-ppss)) (paren-pos (cadr ppss)) diff --git a/lisp/progmodes/opascal.el b/lisp/progmodes/opascal.el index fcd9294f660..8c060991f42 100644 --- a/lisp/progmodes/opascal.el +++ b/lisp/progmodes/opascal.el @@ -1688,7 +1688,7 @@ comment block. If not in a // comment, just does a normal newline." ;; as comment starters. Fix it here by removing the "2" from the syntax ;; of the second char of such sequences. ("/\\(\\*\\)" (1 ". 3b")) - ("(\\(\\/\\)" (1 (prog1 ". 1c" (forward-char -1) nil))) + ("(\\(/\\)" (1 (prog1 ". 1c" (forward-char -1) nil))) ;; Pascal uses '' and "" rather than \' and \" to escape quotes. ("''\\|\"\"" (0 (if (save-excursion (nth 3 (syntax-ppss (match-beginning 0)))) diff --git a/lisp/progmodes/pascal.el b/lisp/progmodes/pascal.el index 13505d04a2d..fce059bafc7 100644 --- a/lisp/progmodes/pascal.el +++ b/lisp/progmodes/pascal.el @@ -187,7 +187,7 @@ ;; as comment starters. Fix it here by removing the "2" from the syntax ;; of the second char of such sequences. ("/\\(\\*\\)" (1 ". 3b")) - ("(\\(\\/\\)" (1 (prog1 ". 1c" (forward-char -1) nil))) + ("(\\(/\\)" (1 (prog1 ". 1c" (forward-char -1) nil))) ;; Pascal uses '' and "" rather than \' and \" to escape quotes. ("''\\|\"\"" (0 (if (save-excursion (nth 3 (syntax-ppss (match-beginning 0)))) @@ -589,7 +589,7 @@ See also `pascal-comment-area'." (interactive) (catch 'found (if (not (looking-at (concat "\\s \\|\\s)\\|" pascal-defun-re))) - (forward-sexp 1)) + (ignore-errors (forward-sexp 1))) (let ((nest 0) (max -1) (func 0) (reg (concat pascal-beg-block-re "\\|" pascal-end-block-re "\\|" @@ -1170,26 +1170,27 @@ indent of the current line in parameterlist." (defun pascal-type-completion (pascal-str) "Calculate all possible completions for types." - (let ((start (point)) - (pascal-all ()) - goon) - ;; Search for all reachable type declarations - (while (or (pascal-beg-of-defun) - (setq goon (not goon))) - (save-excursion - (if (and (< start (prog1 (save-excursion (pascal-end-of-defun) - (point)) - (forward-char 1))) - (re-search-forward - "\\<type\\>\\|\\<\\(begin\\|function\\|procedure\\)\\>" - start t) - (not (match-end 1))) - ;; Check current type declaration - (setq pascal-all - (nconc (pascal-get-completion-decl pascal-str) - pascal-all))))) + (save-excursion + (let ((start (point)) + (pascal-all ()) + goon) + ;; Search for all reachable type declarations + (while (or (pascal-beg-of-defun) + (setq goon (not goon))) + (save-excursion + (if (and (< start (prog1 (save-excursion (pascal-end-of-defun) + (point)) + (forward-char 1))) + (re-search-forward + "\\<type\\>\\|\\<\\(begin\\|function\\|procedure\\)\\>" + start t) + (not (match-end 1))) + ;; Check current type declaration + (setq pascal-all + (nconc (pascal-get-completion-decl pascal-str) + pascal-all))))) - pascal-all)) + pascal-all))) (defun pascal-var-completion (prefix) "Calculate all possible completions for variables (or constants)." @@ -1263,11 +1264,13 @@ indent of the current line in parameterlist." (and (eq state 'defun) (save-excursion (re-search-backward ")[ \t]*:" (point-at-bol) t)))) - (if (or (eq state 'paramlist) (eq state 'defun)) - (pascal-beg-of-defun)) - (nconc - (pascal-type-completion pascal-str) - (pascal-keyword-completion pascal-type-keywords pascal-str))) + (save-excursion + (if (or (eq state 'paramlist) (eq state 'defun)) + (pascal-beg-of-defun)) + (nconc + (pascal-type-completion pascal-str) + (pascal-keyword-completion pascal-type-keywords + pascal-str)))) ( ;--Starting a new statement (and (not (eq state 'contexp)) (save-excursion @@ -1392,7 +1395,7 @@ The default is a name found in the buffer around point." (defvar pascal-outline-map (let ((map (make-sparse-keymap))) (if (fboundp 'set-keymap-name) - (set-keymap-name pascal-outline-map 'pascal-outline-map)) + (set-keymap-name map 'pascal-outline-map)) (define-key map "\M-\C-a" 'pascal-outline-prev-defun) (define-key map "\M-\C-e" 'pascal-outline-next-defun) (define-key map "\C-c\C-d" 'pascal-outline-goto-defun) diff --git a/lisp/progmodes/perl-mode.el b/lisp/progmodes/perl-mode.el index f864f6a34cd..ff0b6a331bc 100644 --- a/lisp/progmodes/perl-mode.el +++ b/lisp/progmodes/perl-mode.el @@ -235,7 +235,7 @@ (match-beginning 0)))))) (string-to-syntax ". p")))) ;; Handle funny names like $DB'stop. - ("\\$ ?{?^?[_[:alpha:]][_[:alnum:]]*\\('\\)[_[:alpha:]]" (1 "_")) + ("\\$ ?{?\\^?[_[:alpha:]][_[:alnum:]]*\\('\\)[_[:alpha:]]" (1 "_")) ;; format statements ("^[ \t]*format.*=[ \t]*\\(\n\\)" (1 (prog1 "\"" (perl-syntax-propertize-special-constructs end)))) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index f5f4092babf..b6161351f0b 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -1,6 +1,11 @@ ;;; project.el --- Operations on the current project -*- lexical-binding: t; -*- ;; Copyright (C) 2015-2020 Free Software Foundation, Inc. +;; Version: 0.5.0 +;; Package-Requires: ((emacs "26.3")) + +;; This is a GNU ELPA :core package. Avoid using functionality that +;; not compatible with the version of Emacs recorded above. ;; This file is part of GNU Emacs. @@ -19,6 +24,11 @@ ;;; Commentary: +;; NOTE: The project API is still experimental and can change in major, +;; backward-incompatible ways. Everyone is encouraged to try it, and +;; report to us any problems or use cases we hadn't anticipated, by +;; sending an email to emacs-devel, or `M-x report-emacs-bug'. +;; ;; This file contains generic infrastructure for dealing with ;; projects, some utility functions, and commands using that ;; infrastructure. @@ -27,16 +37,29 @@ ;; current project, without having to know which package handles ;; detection of that project type, parsing its config files, etc. ;; -;; NOTE: The project API is still experimental and can change in major, -;; backward-incompatible ways. Everyone is encouraged to try it, and -;; report to us any problems or use cases we hadn't anticipated, by -;; sending an email to emacs-devel, or `M-x report-emacs-bug'. +;; This file consists of following parts: +;; +;; Infrastructure (the public API): +;; +;; Function `project-current' that returns the current project +;; instance based on the value of the hook `project-find-functions', +;; and several generic functions that act on it. ;; -;; Infrastructure: +;; `project-root' must be defined for every project. +;; `project-files' can be overridden for performance purposes. +;; `project-ignores' and `project-external-roots' describe the project +;; files and its relations to external directories. `project-files' +;; should be consistent with `project-ignores'. ;; -;; Function `project-current', to determine the current project -;; instance, and 5 (at the moment) generic functions that act on it. -;; This list is to be extended in future versions. +;; This list can change in future versions. +;; +;; VC project: +;; +;; Originally conceived as an example implementation, now it's a +;; relatively fast backend that delegates to 'git ls-files' or 'hg +;; status' to list the project's files. It honors the VC ignore +;; files, but supports additions to the list using the user option +;; `project-vc-ignores' (usually through .dir-locals.el). ;; ;; Utils: ;; @@ -45,9 +68,49 @@ ;; ;; Commands: ;; -;; `project-find-file', `project-find-regexp' and -;; `project-or-external-find-regexp' use the current API, and thus -;; will work in any project that has an adapter. +;; `project-prefix-map' contains the full list of commands defined in +;; this package. This map uses the prefix `C-x p' by default. +;; Type `C-x p f' to find file in the current project. +;; Type `C-x p C-h' to see all available commands and bindings. +;; +;; All commands defined in this package are implemented using the +;; public API only. As a result, they will work with any project +;; backend that follows the protocol. +;; +;; Any third-party code that wants to use this package should likewise +;; target the public API. Use any of the built-in commands as the +;; example. +;; +;; How to create a new backend: +;; +;; - Consider whether you really should, or whether there are other +;; ways to reach your goals. If the backend's performance is +;; significantly lower than that of the built-in one, and it's first +;; in the list, it will affect all commands that use it. Unless you +;; are going to be using it only yourself or in special circumstances, +;; you will probably want it to be fast, and it's unlikely to be a +;; trivial endeavor. `project-files' is the method to optimize (the +;; default implementation gets slower the more files the directory +;; has, and the longer the list of ignores is). +;; +;; - Choose the format of the value that represents a project for your +;; backend (we call it project instance). Don't use any of the +;; formats from other backends. The format can be arbitrary, as long +;; as the datatype is something `cl-defmethod' can dispatch on. The +;; value should be stable (when compared with `equal') across +;; invocations, meaning calls to that function from buffers belonging +;; to the same project should return equal values. +;; +;; - Write a new function that will determine the current project +;; based on the directory and add it to `project-find-functions' +;; (which see) using `add-hook'. It is a good idea to depend on the +;; directory only, and not on the current major mode, for example. +;; Because the usual expectation is that all files in the directory +;; belong to the same project (even if some/most of them are ignored). +;; +;; - Define new methods for some or all generic functions for this +;; backend using `cl-defmethod'. A `project-root' method is +;; mandatory, `project-files' is recommended, the rest are optional. ;;; TODO: @@ -72,9 +135,7 @@ ;; whole Emacs session, independent of the current directory. Or, ;; in the more advanced case, open a set of projects, and have some ;; project-related commands to use them all. E.g., have a command -;; to search for a regexp across all open projects. Provide a -;; history of projects that were opened in the past (storing it as a -;; list of directories should suffice). +;; to search for a regexp across all open projects. ;; ;; * Support for project-local variables: a UI to edit them, and a ;; utility function to retrieve a value. Probably useless without @@ -88,43 +149,81 @@ ;;; Code: (require 'cl-generic) +(require 'seq) +(eval-when-compile (require 'subr-x)) + +(defgroup project nil + "Operations on the current project." + :version "28.1" + :group 'tools) (defvar project-find-functions (list #'project-try-vc) "Special hook to find the project containing a given directory. Each functions on this hook is called in turn with one -argument (the directory) and should return either nil to mean -that it is not applicable, or a project instance.") +argument, the directory in which to look, and should return +either nil to mean that it is not applicable, or a project instance. +The exact form of the project instance is up to each respective +function; the only practical limitation is to use values that +`cl-defmethod' can dispatch on, like a cons cell, or a list, or a +CL struct.") + +(defvar project-current-inhibit-prompt nil + "Non-nil to skip prompting the user in `project-current'.") ;;;###autoload -(defun project-current (&optional maybe-prompt dir) - "Return the project instance in DIR or `default-directory'. -When no project found in DIR, and MAYBE-PROMPT is non-nil, ask -the user for a different directory to look in. If that directory -is not a part of a detectable project either, return a -`transient' project instance rooted in it." - (unless dir (setq dir default-directory)) - (let ((pr (project--find-in-directory dir))) +(defun project-current (&optional maybe-prompt directory) + "Return the project instance in DIRECTORY, defaulting to `default-directory'. + +When no project is found in that directory, the result depends on +the value of MAYBE-PROMPT: if it is nil or omitted, return nil, +else ask the user for a directory in which to look for the +project, and if no project is found there, return a \"transient\" +project instance. + +The \"transient\" project instance is a special kind of value +which denotes a project rooted in that directory and includes all +the files under the directory except for those that should be +ignored (per `project-ignores'). + +See the doc string of `project-find-functions' for the general form +of the project instance object." + (unless directory (setq directory default-directory)) + (let ((pr (project--find-in-directory directory))) (cond (pr) - (maybe-prompt - (setq dir (read-directory-name "Choose the project directory: " dir nil t) - pr (project--find-in-directory dir)) - (unless pr - (message "Using `%s' as a transient project root" dir) - (setq pr (cons 'transient dir))))) + ((unless project-current-inhibit-prompt + maybe-prompt) + (setq directory (project-prompt-project-dir) + pr (project--find-in-directory directory)))) + (when maybe-prompt + (if pr + (project-remember-project pr) + (project--remove-from-project-list directory) + (setq pr (cons 'transient directory)))) pr)) (defun project--find-in-directory (dir) (run-hook-with-args-until-success 'project-find-functions dir)) -(cl-defgeneric project-roots (project) - "Return the list of directory roots of the current project. +(cl-defgeneric project-root (project) + "Return root directory of the current project. -Most often it's just one directory which contains the project -build file and everything else in the project. But in more -advanced configurations, a project can span multiple directories. +It usually contains the main build file, dependencies +configuration file, etc. Though neither is mandatory. -The directory names should be absolute.") +The directory name must be absolute." + (car (project-roots project))) + +(cl-defgeneric project-roots (project) + "Return the list containing the current project root. + +The function is obsolete, all projects have one main root anyway, +and the rest should be possible to express through +`project-external-roots'." + ;; FIXME: Can we specify project's version here? + ;; FIXME: Could we make this affect cl-defmethod calls too? + (declare (obsolete project-root "0.3.0")) + (list (project-root project))) ;; FIXME: Add MODE argument, like in `ede-source-paths'? (cl-defgeneric project-external-roots (_project) @@ -133,18 +232,14 @@ The directory names should be absolute.") It's the list of directories outside of the project that are still related to it. If the project deals with source code then, depending on the languages used, this list should include the -headers search path, load path, class path, and so on. - -The rule of thumb for whether to include a directory here, and -not in `project-roots', is whether its contents are meant to be -edited together with the rest of the project." +headers search path, load path, class path, and so on." nil) (cl-defgeneric project-ignores (_project _dir) "Return the list of glob patterns to ignore inside DIR. Patterns can match both regular files and directories. To root an entry, start it with `./'. To match directories only, -end it with `/'. DIR must be one of `project-roots' or +end it with `/'. DIR must be either `project-root' or one of `project-external-roots'." ;; TODO: Document and support regexp ignores as used by Hg. ;; TODO: Support whitelist entries. @@ -165,21 +260,22 @@ end it with `/'. DIR must be one of `project-roots' or (t (complete-with-action action all-files string pred))))) -(cl-defmethod project-roots ((project (head transient))) - (list (cdr project))) +(cl-defmethod project-root ((project (head transient))) + (cdr project)) (cl-defgeneric project-files (project &optional dirs) "Return a list of files in directories DIRS in PROJECT. DIRS is a list of absolute directories; it should be some -subset of the project roots and external roots. +subset of the project root and external roots. The default implementation uses `find-program'. PROJECT is used to find the list of ignores for each directory." - (cl-mapcan + (mapcan (lambda (dir) (project--files-in-directory dir (project--dir-ignores project dir))) - (or dirs (project-roots project)))) + (or dirs + (list (project-root project))))) (defun project--files-in-directory (dir ignores &optional files) (require 'find-dired) @@ -218,14 +314,24 @@ to find the list of ignores for each directory." local-files)))) (defgroup project-vc nil - "Project implementation using the VC package." + "Project implementation based on the VC package." :version "25.1" - :group 'tools) + :group 'project) (defcustom project-vc-ignores nil "List of patterns to include in `project-ignores'." :type '(repeat string) - :safe 'listp) + :safe #'listp) + +(defcustom project-vc-merge-submodules t + "Non-nil to consider submodules part of the parent project. + +After changing this variable (using Customize or .dir-locals.el) +you might have to restart Emacs to see the effect." + :type 'boolean + :version "28.1" + :package-version '(project . "0.2.0") + :safe #'booleanp) ;; FIXME: Using the current approach, major modes are supposed to set ;; this variable to a buffer-local value. So we don't have access to @@ -263,20 +369,56 @@ The directory names should be absolute. Used in the VC project backend implementation of `project-external-roots'.") (defun project-try-vc (dir) - (let* ((backend (ignore-errors (vc-responsible-backend dir))) + (let* ((backend + ;; FIXME: This is slow. Cache it. + (ignore-errors (vc-responsible-backend dir))) (root (pcase backend ('Git ;; Don't stop at submodule boundary. + ;; FIXME: Cache for a shorter time. (or (vc-file-getprop dir 'project-git-root) - (vc-file-setprop dir 'project-git-root - (vc-find-root dir ".git/")))) + (let ((root (vc-call-backend backend 'root dir))) + (vc-file-setprop + dir 'project-git-root + (if (and + ;; FIXME: Invalidate the cache when the value + ;; of this variable changes. + (project--vc-merge-submodules-p root) + (project--submodule-p root)) + (let* ((parent (file-name-directory + (directory-file-name root)))) + (vc-call-backend backend 'root parent)) + root))))) ('nil nil) (_ (ignore-errors (vc-call-backend backend 'root dir)))))) (and root (cons 'vc root)))) -(cl-defmethod project-roots ((project (head vc))) - (list (cdr project))) +(defun project--submodule-p (root) + ;; XXX: We only support Git submodules for now. + ;; + ;; For submodules, at least, we expect the users to prefer them to + ;; be considered part of the parent project. For those who don't, + ;; there is the custom var now. + ;; + ;; Some users may also set up things equivalent to Git submodules + ;; using "git worktree" (for example). However, we expect that most + ;; of them would prefer to treat those as separate projects anyway. + (let* ((gitfile (expand-file-name ".git" root))) + (cond + ((file-directory-p gitfile) + nil) + ((with-temp-buffer + (insert-file-contents gitfile) + (goto-char (point-min)) + ;; Kind of a hack to distinguish a submodule from + ;; other cases of .git files pointing elsewhere. + (looking-at "gitdir: [./]+/\\.git/modules/")) + t) + (t nil)))) + +(cl-defmethod project-root ((project (head vc))) + (cdr project)) (cl-defmethod project-external-roots ((project (head vc))) (project-subtract-directories @@ -284,10 +426,10 @@ backend implementation of `project-external-roots'.") (mapcar #'file-name-as-directory (funcall project-vc-external-roots-function))) - (project-roots project))) + (list (project-root project)))) (cl-defmethod project-files ((project (head vc)) &optional dirs) - (cl-mapcan + (mapcan (lambda (dir) (let (backend) (if (and (file-equal-p dir (cdr project)) @@ -302,7 +444,8 @@ backend implementation of `project-external-roots'.") (project--files-in-directory dir (project--dir-ignores project dir))))) - (or dirs (project-roots project)))) + (or dirs + (list (project-root project))))) (declare-function vc-git--program-version "vc-git") (declare-function vc-git--run-command-string "vc-git") @@ -331,20 +474,23 @@ backend implementation of `project-external-roots'.") (split-string (apply #'vc-git--run-command-string nil "ls-files" args) "\0" t))) - ;; Unfortunately, 'ls-files --recurse-submodules' conflicts with '-o'. - (let* ((submodules (project--git-submodules)) - (sub-files - (mapcar - (lambda (module) - (when (file-directory-p module) - (project--vc-list-files - (concat default-directory module) - backend - extra-ignores))) - submodules))) - (setq files - (apply #'nconc files sub-files))) - files)) + (when (project--vc-merge-submodules-p default-directory) + ;; Unfortunately, 'ls-files --recurse-submodules' conflicts with '-o'. + (let* ((submodules (project--git-submodules)) + (sub-files + (mapcar + (lambda (module) + (when (file-directory-p module) + (project--vc-list-files + (concat default-directory module) + backend + extra-ignores))) + submodules))) + (setq files + (apply #'nconc files sub-files)))) + ;; 'git ls-files' returns duplicate entries for merge conflicts. + ;; XXX: Better solutions welcome, but this seems cheap enough. + (delete-consecutive-dups files))) (`Hg (let ((default-directory (expand-file-name (file-name-as-directory dir))) args) @@ -362,6 +508,11 @@ backend implementation of `project-external-roots'.") (lambda (s) (concat default-directory s)) (split-string (buffer-string) "\0" t))))))) +(defun project--vc-merge-submodules-p (dir) + (project--value-in-dir + 'project-vc-merge-submodules + dir)) + (defun project--git-submodules () ;; 'git submodule foreach' is much slower. (condition-case nil @@ -376,7 +527,7 @@ backend implementation of `project-external-roots'.") (cl-defmethod project-ignores ((project (head vc)) dir) (let* ((root (cdr project)) - backend) + backend) (append (when (file-equal-p dir root) (setq backend (vc-responsible-backend root)) @@ -424,6 +575,98 @@ DIRS must contain directory names." (hack-dir-local-variables-non-file-buffer)) (symbol-value var))) + +;;; Project commands + +;;;###autoload +(defvar project-prefix-map + (let ((map (make-sparse-keymap))) + (define-key map "f" 'project-find-file) + (define-key map "F" 'project-or-external-find-file) + (define-key map "b" 'project-switch-to-buffer) + (define-key map "s" 'project-shell) + (define-key map "d" 'project-dired) + (define-key map "v" 'project-vc-dir) + (define-key map "c" 'project-compile) + (define-key map "e" 'project-eshell) + (define-key map "k" 'project-kill-buffers) + (define-key map "p" 'project-switch-project) + (define-key map "g" 'project-find-regexp) + (define-key map "G" 'project-or-external-find-regexp) + (define-key map "r" 'project-query-replace-regexp) + map) + "Keymap for project commands.") + +;;;###autoload (define-key ctl-x-map "p" project-prefix-map) + +;; We can't have these place-specific maps inherit from +;; project-prefix-map because project--other-place-command needs to +;; know which map the key binding came from, as if it came from one of +;; these maps, we don't want to set display-buffer-overriding-action + +(defvar project-other-window-map + (let ((map (make-sparse-keymap))) + (define-key map "\C-o" #'project-display-buffer) + map) + "Keymap for project commands that display buffers in other windows.") + +(defvar project-other-frame-map + (let ((map (make-sparse-keymap))) + (define-key map "\C-o" #'project-display-buffer-other-frame) + map) + "Keymap for project commands that display buffers in other frames.") + +(defun project--other-place-command (action &optional map) + (let* ((key (read-key-sequence-vector nil t)) + (place-cmd (lookup-key map key)) + (generic-cmd (lookup-key project-prefix-map key)) + (switch-to-buffer-obey-display-actions t) + (display-buffer-overriding-action (unless place-cmd action))) + (if-let ((cmd (or place-cmd generic-cmd))) + (call-interactively cmd) + (user-error "%s is undefined" (key-description key))))) + +;;;###autoload +(defun project-other-window-command () + "Run project command, displaying resultant buffer in another window. + +The following commands are available: + +\\{project-prefix-map} +\\{project-other-window-map}" + (interactive) + (project--other-place-command '((display-buffer-pop-up-window) + (inhibit-same-window . t)) + project-other-window-map)) + +;;;###autoload (define-key ctl-x-4-map "p" #'project-other-window-command) + +;;;###autoload +(defun project-other-frame-command () + "Run project command, displaying resultant buffer in another frame. + +The following commands are available: + +\\{project-prefix-map} +\\{project-other-frame-map}" + (interactive) + (project--other-place-command '((display-buffer-pop-up-frame)) + project-other-frame-map)) + +;;;###autoload (define-key ctl-x-5-map "p" #'project-other-frame-command) + +;;;###autoload +(defun project-other-tab-command () + "Run project command, displaying resultant buffer in a new tab. + +The following commands are available: + +\\{project-prefix-map}" + (interactive) + (project--other-place-command '((display-buffer-in-new-tab)))) + +;;;###autoload (define-key tab-prefix-map "p" #'project-other-tab-command) + (declare-function grep-read-files "grep") (declare-function xref--show-xrefs "xref") (declare-function xref--find-ignores-arguments "xref") @@ -443,7 +686,7 @@ requires quoting, e.g. `\\[quoted-insert]<space>'." (let* ((pr (project-current t)) (files (if (not current-prefix-arg) - (project-files pr (project-roots pr)) + (project-files pr) (let ((dir (read-directory-name "Base directory: " nil default-directory t))) (project--files-in-directory dir @@ -454,9 +697,8 @@ requires quoting, e.g. `\\[quoted-insert]<space>'." nil))) (defun project--dir-ignores (project dir) - (let* ((roots (project-roots project)) - (root (cl-find dir roots :test #'file-in-directory-p))) - (if (not root) + (let ((root (project-root project))) + (if (not (file-in-directory-p dir root)) (project-ignores nil nil) ;The defaults. (let ((ignores (project-ignores project root))) (if (file-equal-p root dir) @@ -474,8 +716,8 @@ pattern to search for." (require 'xref) (let* ((pr (project-current t)) (files - (project-files pr (append - (project-roots pr) + (project-files pr (cons + (project-root pr) (project-external-roots pr))))) (xref--show-xrefs (apply-partially #'project--find-regexp-in-files regexp files) @@ -513,23 +755,23 @@ pattern to search for." ;;;###autoload (defun project-find-file () - "Visit a file (with completion) in the current project's roots. + "Visit a file (with completion) in the current project. The completion default is the filename at point, if one is recognized." (interactive) (let* ((pr (project-current t)) - (dirs (project-roots pr))) + (dirs (list (project-root pr)))) (project-find-file-in (thing-at-point 'filename) dirs pr))) ;;;###autoload (defun project-or-external-find-file () - "Visit a file (with completion) in the current project's roots or external roots. + "Visit a file (with completion) in the current project or external roots. The completion default is the filename at point, if one is recognized." (interactive) (let* ((pr (project-current t)) - (dirs (append - (project-roots pr) + (dirs (cons + (project-root pr) (project-external-roots pr)))) (project-find-file-in (thing-at-point 'filename) dirs pr))) @@ -541,6 +783,7 @@ For the arguments list, see `project--read-file-cpd-relative'." (const :tag "Read with completion from absolute names" project--read-file-absolute) (function :tag "Custom function" nil)) + :group 'project :version "27.1") (defun project--read-file-cpd-relative (prompt @@ -577,9 +820,10 @@ PREDICATE, HIST, and DEFAULT have the same meaning as in (defun project-find-file-in (filename dirs project) "Complete FILENAME in DIRS in PROJECT and visit the result." (let* ((all-files (project-files project dirs)) + (completion-ignore-case read-file-name-completion-ignore-case) (file (funcall project-read-file-name-function - "Find file" all-files nil nil - filename))) + "Find file" all-files nil nil + filename))) (if (string= file "") (user-error "You didn't specify the file") (find-file file)))) @@ -605,6 +849,57 @@ PREDICATE, HIST, and DEFAULT have the same meaning as in collection predicate t res hist nil))) res)) +;;;###autoload +(defun project-dired () + "Start Dired in the current project's root." + (interactive) + (dired (project-root (project-current t)))) + +;;;###autoload +(defun project-vc-dir () + "Run VC-Dir in the current project's root." + (interactive) + (vc-dir (project-root (project-current t)))) + +;;;###autoload +(defun project-shell () + "Start an inferior shell in the current project's root directory. +If a buffer already exists for running a shell in the project's root, +switch to it. Otherwise, create a new shell buffer. +With \\[universal-argument] prefix arg, create a new inferior shell buffer even +if one already exists." + (interactive) + (let* ((default-directory (project-root (project-current t))) + (default-project-shell-name + (concat "*" (file-name-nondirectory + (directory-file-name + (file-name-directory default-directory))) + "-shell*")) + (shell-buffer (get-buffer default-project-shell-name))) + (if (and shell-buffer (not current-prefix-arg)) + (pop-to-buffer shell-buffer) + (shell (generate-new-buffer-name default-project-shell-name))))) + +;;;###autoload +(defun project-eshell () + "Start Eshell in the current project's root directory. +If a buffer already exists for running Eshell in the project's root, +switch to it. Otherwise, create a new Eshell buffer. +With \\[universal-argument] prefix arg, create a new Eshell buffer even +if one already exists." + (interactive) + (defvar eshell-buffer-name) + (let* ((default-directory (project-root (project-current t))) + (eshell-buffer-name + (concat "*" (file-name-nondirectory + (directory-file-name + (file-name-directory default-directory))) + "-eshell*")) + (eshell-buffer (get-buffer eshell-buffer-name))) + (if (and eshell-buffer (not current-prefix-arg)) + (pop-to-buffer eshell-buffer) + (eshell t)))) + (declare-function fileloop-continue "fileloop" ()) ;;;###autoload @@ -632,5 +927,327 @@ loop using the command \\[fileloop-continue]." from to (project-files (project-current t)) 'default) (fileloop-continue)) +(defvar compilation-read-command) +(declare-function compilation-read-command "compile") + +;;;###autoload +(defun project-compile (command &optional comint) + "Run `compile' in the project root. +Arguments the same as in `compile'." + (interactive + (list + (let ((command (eval compile-command))) + (if (or compilation-read-command current-prefix-arg) + (compilation-read-command command) + command)) + (consp current-prefix-arg))) + (let* ((pr (project-current t)) + (default-directory (project-root pr))) + (compile command comint))) + +(defun project--read-project-buffer () + (let* ((pr (project-current t)) + (current-buffer (current-buffer)) + (other-buffer (other-buffer current-buffer)) + (other-name (buffer-name other-buffer)) + (predicate + (lambda (buffer) + ;; BUFFER is an entry (BUF-NAME . BUF-OBJ) of Vbuffer_alist. + (and (cdr buffer) + (equal pr + (with-current-buffer (cdr buffer) + (project-current))))))) + (read-buffer + "Switch to buffer: " + (when (funcall predicate (cons other-name other-buffer)) + other-name) + nil + predicate))) + +;;;###autoload +(defun project-switch-to-buffer (buffer-or-name) + "Display buffer BUFFER-OR-NAME in the selected window. +When called interactively, prompts for a buffer belonging to the +current project. Two buffers belong to the same project if their +project instances, as reported by `project-current' in each +buffer, are identical." + (interactive (list (project--read-project-buffer))) + (switch-to-buffer buffer-or-name)) + +;;;###autoload +(defun project-display-buffer (buffer-or-name) + "Display BUFFER-OR-NAME in some window, without selecting it. +When called interactively, prompts for a buffer belonging to the +current project. Two buffers belong to the same project if their +project instances, as reported by `project-current' in each +buffer, are identical. + +This function uses `display-buffer' as a subroutine, which see +for how it is determined where the buffer will be displayed." + (interactive (list (project--read-project-buffer))) + (display-buffer buffer-or-name)) + +;;;###autoload +(defun project-display-buffer-other-frame (buffer-or-name) + "Display BUFFER-OR-NAME preferably in another frame. +When called interactively, prompts for a buffer belonging to the +current project. Two buffers belong to the same project if their +project instances, as reported by `project-current' in each +buffer, are identical. + +This function uses `display-buffer-other-frame' as a subroutine, +which see for how it is determined where the buffer will be +displayed." + (interactive (list (project--read-project-buffer))) + (display-buffer-other-frame buffer-or-name)) + +(defcustom project-kill-buffer-conditions + '(buffer-file-name ; All file-visiting buffers are included. + ;; Most of the temp buffers in the background: + (major-mode . fundamental-mode) + ;; non-text buffer such as xref, occur, vc, log, ... + (and (derived-mode . special-mode) + (not (major-mode . help-mode))) + (derived-mode . compilation-mode) + (derived-mode . dired-mode) + (derived-mode . diff-mode)) + "List of conditions to kill buffers related to a project. +This list is used by `project-kill-buffers'. +Each condition is either: +- a regular expression, to match a buffer name, +- a predicate function that takes a buffer object as argument + and returns non-nil if the buffer should be killed, +- a cons-cell, where the car describes how to interpret the cdr. + The car can be one of the following: + * `major-mode': the buffer is killed if the buffer's major + mode is eq to the cons-cell's cdr + * `defived-mode': the buffer is killed if the buffer's major + mode is derived from the major mode denoted by the cons-cell's + cdr + * `not': the cdr is interpreted as a negation of a condition. + * `and': the cdr is a list of recursive conditions, that all have + to be met. + * `or': the cdr is a list of recursive conditions, of which at + least one has to be met. + +If any of these conditions are satified for a buffer in the +current project, it will be killed." + :type '(repeat (choice regexp function symbol + (cons :tag "Major mode" + (const major-mode) symbol) + (cons :tag "Derived mode" + (const derived-mode) symbol) + (cons :tag "Negation" + (const not) sexp) + (cons :tag "Conjunction" + (const and) sexp) + (cons :tag "Disjunction" + (const or) sexp))) + :version "28.1" + :group 'project + :package-version '(project . "0.6.0")) + +(defun project--buffer-list (pr) + "Return the list of all buffers in project PR." + (let (bufs) + (dolist (buf (buffer-list)) + (when (equal pr + (with-current-buffer buf + (project-current))) + (push buf bufs))) + (nreverse bufs))) + +(defun project--kill-buffer-check (buf conditions) + "Check if buffer BUF matches any element of the list CONDITIONS. +See `project-kill-buffer-conditions' for more details on the form +of CONDITIONS." + (catch 'kill + (dolist (c conditions) + (when (cond + ((stringp c) + (string-match-p c (buffer-name buf))) + ((symbolp c) + (funcall c buf)) + ((eq (car-safe c) 'major-mode) + (eq (buffer-local-value 'major-mode buf) + (cdr c))) + ((eq (car-safe c) 'derived-mode) + (provided-mode-derived-p + (buffer-local-value 'major-mode buf) + (cdr c))) + ((eq (car-safe c) 'not) + (not (project--kill-buffer-check buf (cdr c)))) + ((eq (car-safe c) 'or) + (project--kill-buffer-check buf (cdr c))) + ((eq (car-safe c) 'and) + (seq-every-p + (apply-partially #'project--kill-buffer-check + buf) + (mapcar #'list (cdr c))))) + (throw 'kill t))))) + +(defun project--buffers-to-kill (pr) + "Return list of buffers in project PR to kill. +What buffers should or should not be killed is described +in `project-kill-buffer-conditions'." + (let (bufs) + (dolist (buf (project--buffer-list pr)) + (when (project--kill-buffer-check buf project-kill-buffer-conditions) + (push buf bufs))) + bufs)) + +;;;###autoload +(defun project-kill-buffers (&optional no-confirm) + "Kill the buffers belonging to the current project. +Two buffers belong to the same project if their project +instances, as reported by `project-current' in each buffer, are +identical. Only the buffers that match a condition in +`project-kill-buffer-conditions' will be killed. If NO-CONFIRM +is non-nil, the command will not ask the user for confirmation. +NO-CONFIRM is always nil when the command is invoked +interactivly." + (interactive) + (let* ((pr (project-current t)) + (bufs (project--buffers-to-kill pr))) + (cond (no-confirm + (mapc #'kill-buffer bufs)) + ((null bufs) + (message "No buffers to kill")) + ((yes-or-no-p (format "Kill %d buffers in %s? " + (length bufs) + (project-root pr))) + (mapc #'kill-buffer bufs))))) + + +;;; Project list + +(defcustom project-list-file (locate-user-emacs-file "projects") + "File in which to save the list of known projects." + :type 'file + :version "28.1" + :group 'project) + +(defvar project--list 'unset + "List structure containing root directories of known projects. +With some possible metadata (to be decided).") + +(defun project--read-project-list () + "Initialize `project--list' using contents of `project-list-file'." + (let ((filename project-list-file)) + (setq project--list + (when (file-exists-p filename) + (with-temp-buffer + (insert-file-contents filename) + (read (current-buffer))))) + (unless (seq-every-p + (lambda (elt) (stringp (car-safe elt))) + project--list) + (warn "Contents of %s are in wrong format, resetting" + project-list-file) + (setq project--list nil)))) + +(defun project--ensure-read-project-list () + "Initialize `project--list' if it isn't already initialized." + (when (eq project--list 'unset) + (project--read-project-list))) + +(defun project--write-project-list () + "Save `project--list' in `project-list-file'." + (let ((filename project-list-file)) + (with-temp-buffer + (insert ";;; -*- lisp-data -*-\n") + (pp project--list (current-buffer)) + (write-region nil nil filename nil 'silent)))) + +;;;###autoload +(defun project-remember-project (pr) + "Add project PR to the front of the project list. +Save the result in `project-list-file' if the list of projects has changed." + (project--ensure-read-project-list) + (let ((dir (project-root pr))) + (unless (equal (caar project--list) dir) + (dolist (ent project--list) + (when (equal dir (car ent)) + (setq project--list (delq ent project--list)))) + (push (list dir) project--list) + (project--write-project-list)))) + +(defun project--remove-from-project-list (pr-dir) + "Remove directory PR-DIR of a missing project from the project list. +If the directory was in the list before the removal, save the +result in `project-list-file'. Announce the project's removal +from the list." + (project--ensure-read-project-list) + (when-let ((ent (assoc pr-dir project--list))) + (setq project--list (delq ent project--list)) + (message "Project `%s' not found; removed from list" pr-dir) + (project--write-project-list))) + +(defun project-prompt-project-dir () + "Prompt the user for a directory that is one of the known project roots. +The project is chosen among projects known from the project list, +see `project-list-file'. +It's also possible to enter an arbitrary directory not in the list." + (project--ensure-read-project-list) + (let* ((dir-choice "... (choose a dir)") + (choices + ;; XXX: Just using this for the category (for the substring + ;; completion style). + (project--file-completion-table + (append project--list `(,dir-choice)))) + (pr-dir (completing-read "Select project: " choices nil t))) + (if (equal pr-dir dir-choice) + (read-directory-name "Select directory: " default-directory nil t) + pr-dir))) + +;;;###autoload +(defun project-known-project-roots () + "Return the list of root directories of all known projects." + (project--ensure-read-project-list) + (mapcar #'car project--list)) + + +;;; Project switching + +;;;###autoload +(defvar project-switch-commands + '((?f "Find file" project-find-file) + (?g "Find regexp" project-find-regexp) + (?d "Dired" project-dired) + (?v "VC-Dir" project-vc-dir) + (?e "Eshell" project-eshell)) + "Alist mapping keys to project switching menu entries. +Used by `project-switch-project' to construct a dispatch menu of +commands available upon \"switching\" to another project. + +Each element is of the form (KEY LABEL COMMAND), where COMMAND is the +command to run when KEY is pressed. LABEL is used to distinguish +the menu entries in the dispatch menu.") + +(defun project--keymap-prompt () + "Return a prompt for the project swithing dispatch menu." + (mapconcat + (pcase-lambda (`(,key ,label)) + (format "[%s] %s" + (propertize (key-description `(,key)) 'face 'bold) + label)) + project-switch-commands + " ")) + +;;;###autoload +(defun project-switch-project () + "\"Switch\" to another project by running an Emacs command. +The available commands are presented as a dispatch menu +made from `project-switch-commands'." + (interactive) + (let ((dir (project-prompt-project-dir)) + (choice nil)) + (while (not choice) + (setq choice (assq (read-event (project--keymap-prompt)) + project-switch-commands))) + (let ((default-directory dir) + (project-current-inhibit-prompt t)) + (call-interactively (nth 2 choice))))) + (provide 'project) ;;; project.el ends here diff --git a/lisp/progmodes/prolog.el b/lisp/progmodes/prolog.el index 99b57354e25..a209d21807f 100644 --- a/lisp/progmodes/prolog.el +++ b/lisp/progmodes/prolog.el @@ -271,10 +271,6 @@ (require 'easymenu) (require 'align) -(eval-when-compile - (or (fboundp 'use-region-p) - (defsubst use-region-p () (region-exists-p)))) - (defgroup prolog nil "Editing and running Prolog and Mercury files." :group 'languages) @@ -2752,20 +2748,6 @@ When called with prefix argument ARG, disable zipping instead." (nth 1 state))) )))) -;; For backward compatibility. Stolen from custom.el. -(or (fboundp 'match-string) - ;; Introduced in Emacs 19.29. - (defun match-string (num &optional string) - "Return string of text matched by last search. -NUM specifies which parenthesized expression in the last regexp. - Value is nil if NUMth pair didn't match, or there were less than NUM pairs. -Zero means the entire text matched by the whole regexp or whole string. -STRING should be given if the last search was by `string-match' on STRING." - (if (match-beginning num) - (if string - (substring string (match-beginning num) (match-end num)) - (buffer-substring (match-beginning num) (match-end num)))))) - (defun prolog-pred-start () "Return the starting point of the first clause of the current predicate." ;; FIXME: Use SMIE. diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index 785b941402a..3af55be4a19 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -261,7 +261,6 @@ (require 'ansi-color) (require 'cl-lib) (require 'comint) -(require 'json) (require 'tramp-sh) ;; Avoid compiler warnings @@ -634,6 +633,8 @@ builtins.") (,(lambda (limit) (let ((re (python-rx (group (+ (any word ?. ?_))) (? ?\[ (+ (not (any ?\]))) ?\]) (* space) + ;; A type, like " : int ". + (? ?: (* space) (+ (any word ?. ?_)) (* space)) assignment-operator)) (res nil)) (while (and (setq res (re-search-forward re limit t)) @@ -1993,7 +1994,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 +2002,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") @@ -2091,7 +2092,7 @@ executed through tramp connections." This variable, when set to a string, makes the environment to be modified such that shells are started within the specified virtualenv." - :type '(choice (const nil) string) + :type '(choice (const nil) directory) :group 'python) (defcustom python-shell-setup-codes nil @@ -2111,7 +2112,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) @@ -2276,6 +2277,18 @@ Do not set this variable directly, instead use Do not set this variable directly, instead use `python-shell-prompt-set-calculated-regexps'.") +(defalias 'python--parse-json-array + (if (fboundp 'json-parse-string) + (lambda (string) + (json-parse-string string :array-type 'list)) + (require 'json) + (defvar json-array-type) + (declare-function json-read-from-string "json" (string)) + (lambda (string) + (let ((json-array-type 'list)) + (json-read-from-string string)))) + "Parse the JSON array in STRING into a Lisp list.") + (defun python-shell-prompt-detect () "Detect prompts for the current `python-shell-interpreter'. When prompts can be retrieved successfully from the @@ -2324,11 +2337,11 @@ detection and just returns nil." (catch 'prompts (dolist (line (split-string output "\n" t)) (let ((res - ;; Check if current line is a valid JSON array - (and (string= (substring line 0 2) "[\"") + ;; Check if current line is a valid JSON array. + (and (string-prefix-p "[\"" line) (ignore-errors - ;; Return prompts as a list, not vector - (append (json-read-from-string line) nil))))) + ;; Return prompts as a list. + (python--parse-json-array line))))) ;; The list must contain 3 strings, where the first ;; is the input prompt, the second is the block ;; prompt and the last one is the output prompt. The @@ -3785,7 +3798,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) @@ -4560,7 +4573,7 @@ returns will be used. If not FORCE-PROCESS is passed what :type 'boolean :version "25.1") -(defun python-eldoc-function () +(defun python-eldoc-function (&rest _ignored) "`eldoc-documentation-function' for Python. For this to work as best as possible you should call `python-shell-send-buffer' from time to time so context in @@ -5540,12 +5553,16 @@ REPORT-FN is Flymake's callback function." (current-column)))) (^ '(- (1+ (current-indentation)))))) - (if (null eldoc-documentation-function) - ;; Emacs<25 - (set (make-local-variable 'eldoc-documentation-function) - #'python-eldoc-function) - (add-function :before-until (local 'eldoc-documentation-function) - #'python-eldoc-function)) + (with-no-warnings + ;; supress warnings about eldoc-documentation-function being obsolete + (if (null eldoc-documentation-function) + ;; Emacs<25 + (set (make-local-variable 'eldoc-documentation-function) + #'python-eldoc-function) + (if (boundp 'eldoc-documentation-functions) + (add-hook 'eldoc-documentation-functions #'python-eldoc-function nil t) + (add-function :before-until (local 'eldoc-documentation-function) + #'python-eldoc-function)))) (add-to-list 'hs-special-modes-alist diff --git a/lisp/progmodes/ruby-mode.el b/lisp/progmodes/ruby-mode.el index 5da5577c108..e16225c7fa9 100644 --- a/lisp/progmodes/ruby-mode.el +++ b/lisp/progmodes/ruby-mode.el @@ -801,7 +801,7 @@ The style of the comment is controlled by `ruby-encoding-magic-comment-style'." (let ((coding-system (ruby--detect-encoding))) (when coding-system (if (looking-at "^#!") (beginning-of-line 2)) - (cond ((looking-at "\\s *#\\s *.*\\(en\\)?coding\\s *:\\s *\\([-a-z0-9_]*\\)") + (cond ((looking-at "\\s *#.*\\(en\\)?coding\\s *:\\s *\\([-a-z0-9_]*\\)") ;; update existing encoding comment if necessary (unless (string= (match-string 2) coding-system) (goto-char (match-beginning 2)) diff --git a/lisp/progmodes/scheme.el b/lisp/progmodes/scheme.el index 751d7da5427..33ba0d11d80 100644 --- a/lisp/progmodes/scheme.el +++ b/lisp/progmodes/scheme.el @@ -116,7 +116,7 @@ (defvar scheme-imenu-generic-expression '((nil - "^(define\\(\\|-\\(generic\\(\\|-procedure\\)\\|method\\)\\)*\\s-+(?\\(\\sw+\\)" 4) + "^(define\\(?:-\\(?:generic\\(?:-procedure\\)?\\|method\\)\\)?\\s-+(?\\(\\sw+\\)" 1) ("Types" "^(define-class\\s-+(?\\(\\sw+\\)" 1) ("Macros" diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el index cc6d5b46ed2..5a47594878e 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] @@ -900,7 +838,7 @@ See `sh-feature'.") font-lock-variable-name-face)) (rc sh-append es) - (bash sh-append sh ("\\$(\\(\\sw+\\)" (1 'sh-quoted-exec t) )) + (bash sh-append sh ("\\$(\\([^)\n]+\\)" (1 'sh-quoted-exec t) )) (sh sh-append shell ;; Variable names. ("\\$\\({#?\\)?\\([[:alpha:]_][[:alnum:]_]*\\|[-#?@!]\\)" 2 @@ -1158,7 +1096,7 @@ subshells can nest." (")" (0 (sh-font-lock-paren (match-beginning 0)))) ;; Highlight (possibly nested) subshells inside "" quoted ;; regions correctly. - ("\"\\(?:\\(?:[^\\\"]\\|\\\\.\\)*?\\)??\\(\\$(\\|`\\)" + ("\"\\(?:[^\\\"]\\|\\\\.\\)*?\\(\\$(\\|`\\)" (1 (ignore (if (nth 8 (save-excursion (syntax-ppss (match-beginning 0)))) (goto-char (1+ (match-beginning 0))) @@ -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..e554b2b8b0b 100644 --- a/lisp/progmodes/sql.el +++ b/lisp/progmodes/sql.el @@ -257,7 +257,6 @@ (defcustom sql-user "" "Default username." :type 'string - :group 'SQL :safe 'stringp) (defcustom sql-password "" @@ -265,33 +264,28 @@ If you customize this, the value will be stored in your init file. Since that is a plaintext file, this could be dangerous." :type 'string - :group 'SQL :risky t) (defcustom sql-database "" "Default database." :type 'string - :group 'SQL :safe 'stringp) (defcustom sql-server "" "Default server or host." :type 'string - :group 'SQL :safe 'stringp) (defcustom sql-port 0 "Default port for connecting to a MySQL or Postgres server." :version "24.1" :type 'number - :group 'SQL :safe 'numberp) (defcustom sql-default-directory nil "Default directory for SQL processes." :version "25.1" :type '(choice (const nil) string) - :group 'SQL :safe 'stringp) ;; Login parameter type @@ -461,7 +455,7 @@ file. Since that is a plaintext file, this could be dangerous." :prompt-regexp "^mysql> " :prompt-length 6 :prompt-cont-regexp "^ -> " - :syntax-alist ((?# . "< b")) + :syntax-alist ((?# . "< b") (?\\ . "\\")) :input-filter sql-remove-tabs-filter) (oracle @@ -707,9 +701,9 @@ making new SQLi sessions." (repeat :inline t (list :tab "Other" (symbol :tag " Variable Symbol") + ;; FIXME: Why "Value *Expression*"? (sexp :tag "Value Expression"))))) - :version "24.1" - :group 'SQL) + :version "24.1") (defvaralias 'sql-dialect 'sql-product) @@ -723,7 +717,6 @@ This allows highlighting buffers properly when you open them." (capitalize (symbol-name (car prod-info)))) ,(car prod-info))) sql-product-alist)) - :group 'SQL :safe 'symbolp) ;; SQL indent support @@ -735,7 +728,6 @@ SQL statements with easy customizations to support varied layout requirements. The package must be available to be loaded and activated." - :group 'SQL :link '(url-link "https://elpa.gnu.org/packages/sql-indent.html") :type 'boolean :version "27.1") @@ -851,7 +843,6 @@ host key." See `sql-password-search-wallet-function' to understand how this value is used to locate the password wallet." :type `(plist-get (symbol-plist 'auth-sources) 'custom-type) - :group 'SQL :version "27.1") (defvar sql-password-search-wallet-function #'sql-auth-source-search-wallet @@ -878,8 +869,7 @@ current input in the SQLi buffer to the process." :type '(choice (const :tag "Nothing" nil) (const :tag "The semicolon `;'" semicolon) (const :tag "The string `go' by itself" go)) - :version "20.8" - :group 'SQL) + :version "20.8") (defcustom sql-send-terminator nil "When non-nil, add a terminator to text sent to the SQL interpreter. @@ -905,10 +895,9 @@ 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) + :version "22.2") (defvar sql-contains-names nil "When non-nil, the current buffer contains database names. @@ -932,8 +921,7 @@ buffer." :type '(choice (const :tag "Default" t) (const :tag "No display" nil) (function :tag "Display Buffer function")) - :version "27.1" - :group 'SQL) + :version "27.1") ;; imenu support for sql-mode. @@ -971,8 +959,7 @@ This is used to initialize `comint-input-ring-file-name'. Note that the size of the input history is determined by the variable `comint-input-ring-size'." :type '(choice (const :tag "none" nil) - (file)) - :group 'SQL) + (file))) (defcustom sql-input-ring-separator "\n--\n" "Separator between commands in the history file. @@ -987,21 +974,18 @@ does not have it, setting `sql-input-ring-separator' will have no effect. In that case multiline commands will be split into several commands when the input history is read, as if you had set `sql-input-ring-separator' to \"\\n\"." - :type 'string - :group 'SQL) + :type 'string) ;; The usual hooks (defcustom sql-interactive-mode-hook '(sql-indent-enable) "Hook for customizing `sql-interactive-mode'." :type 'hook - :group 'SQL :version "27.1") (defcustom sql-mode-hook '(sql-indent-enable) "Hook for customizing `sql-mode'." :type 'hook - :group 'SQL :version "27.1") (defcustom sql-set-sqli-hook '() @@ -1009,8 +993,7 @@ commands when the input history is read, as if you had set This is called by `sql-set-sqli-buffer' when the value of `sql-buffer' is changed." - :type 'hook - :group 'SQL) + :type 'hook) (defcustom sql-login-hook '() "Hook for interacting with a buffer in `sql-interactive-mode'. @@ -1018,8 +1001,7 @@ is changed." This hook is invoked in a buffer once it is ready to accept input for the first time." :version "24.1" - :type 'hook - :group 'SQL) + :type 'hook) ;; Customization for ANSI @@ -1033,8 +1015,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 - :group 'SQL) + :type 'regexp) ;; Customization for Oracle @@ -1046,27 +1027,23 @@ Starts `sql-interactive-mode' after doing some setup. On Windows, \"sqlplus\" usually starts the sqlplus \"GUI\". In order to start the sqlplus console, use \"plus33\" or something similar. You will find the file in your Orant\\bin directory." - :type 'file - :group 'SQL) + :type 'file) (defcustom sql-oracle-options '("-L") "List of additional options for `sql-oracle-program'." :type '(repeat string) - :version "24.4" - :group 'SQL) + :version "24.4") (defcustom sql-oracle-login-params '(user password database) "List of login parameters needed to connect to Oracle." :type 'sql-login-params - :version "24.1" - :group 'SQL) + :version "24.1") (defcustom sql-oracle-statement-starters (regexp-opt '("declare" "begin" "with")) "Additional statement starting keywords in Oracle." :version "24.1" - :type 'string - :group 'SQL) + :type 'string) (defcustom sql-oracle-scan-on t "Non-nil if placeholders should be replaced in Oracle SQLi. @@ -1082,8 +1059,7 @@ You need to issue the following command in SQL*Plus to be safe: In older versions of SQL*Plus, this was the SET SCAN OFF command." :version "24.1" - :type 'boolean - :group 'SQL) + :type 'boolean) (defcustom sql-db2-escape-newlines nil "Non-nil if newlines should be escaped by a backslash in DB2 SQLi. @@ -1092,8 +1068,7 @@ When non-nil, Emacs will automatically insert a space and backslash prior to every newline in multi-line SQL statements as they are submitted to an interactive DB2 session." :version "24.3" - :type 'boolean - :group 'SQL) + :type 'boolean) ;; Customization for SQLite @@ -1103,21 +1078,18 @@ they are submitted to an interactive DB2 session." "Command to start SQLite. Starts `sql-interactive-mode' after doing some setup." - :type 'file - :group 'SQL) + :type 'file) (defcustom sql-sqlite-options nil "List of additional options for `sql-sqlite-program'." :type '(repeat string) - :version "20.8" - :group 'SQL) + :version "20.8") (defcustom sql-sqlite-login-params '((database :file nil :must-match confirm)) "List of login parameters needed to connect to SQLite." :type 'sql-login-params - :version "26.1" - :group 'SQL) + :version "26.1") ;; Customization for MariaDB @@ -1134,22 +1106,19 @@ Starts `sql-interactive-mode' after doing some setup." "Command to start mysql by Oracle. Starts `sql-interactive-mode' after doing some setup." - :type 'file - :group 'SQL) + :type 'file) (defcustom sql-mysql-options nil "List of additional options for `sql-mysql-program'. The following list of options is reported to make things work on Windows: \"-C\" \"-t\" \"-f\" \"-n\"." :type '(repeat string) - :version "20.8" - :group 'SQL) + :version "20.8") (defcustom sql-mysql-login-params '(user password database server) "List of login parameters needed to connect to MySQL." :type 'sql-login-params - :version "24.1" - :group 'SQL) + :version "24.1") ;; Customization for Solid @@ -1157,14 +1126,12 @@ on Windows: \"-C\" \"-t\" \"-f\" \"-n\"." "Command to start SOLID SQL Editor. Starts `sql-interactive-mode' after doing some setup." - :type 'file - :group 'SQL) + :type 'file) (defcustom sql-solid-login-params '(user password server) "List of login parameters needed to connect to Solid." :type 'sql-login-params - :version "24.1" - :group 'SQL) + :version "24.1") ;; Customization for Sybase @@ -1172,21 +1139,18 @@ Starts `sql-interactive-mode' after doing some setup." "Command to start isql by Sybase. Starts `sql-interactive-mode' after doing some setup." - :type 'file - :group 'SQL) + :type 'file) (defcustom sql-sybase-options nil "List of additional options for `sql-sybase-program'. Some versions of isql might require the -n option in order to work." :type '(repeat string) - :version "20.8" - :group 'SQL) + :version "20.8") (defcustom sql-sybase-login-params '(server user password database) "List of login parameters needed to connect to Sybase." :type 'sql-login-params - :version "24.1" - :group 'SQL) + :version "24.1") ;; Customization for Informix @@ -1194,14 +1158,12 @@ Some versions of isql might require the -n option in order to work." "Command to start dbaccess by Informix. Starts `sql-interactive-mode' after doing some setup." - :type 'file - :group 'SQL) + :type 'file) (defcustom sql-informix-login-params '(database) "List of login parameters needed to connect to Informix." :type 'sql-login-params - :version "24.1" - :group 'SQL) + :version "24.1") ;; Customization for Ingres @@ -1209,14 +1171,12 @@ Starts `sql-interactive-mode' after doing some setup." "Command to start sql by Ingres. Starts `sql-interactive-mode' after doing some setup." - :type 'file - :group 'SQL) + :type 'file) (defcustom sql-ingres-login-params '(database) "List of login parameters needed to connect to Ingres." :type 'sql-login-params - :version "24.1" - :group 'SQL) + :version "24.1") ;; Customization for Microsoft @@ -1229,21 +1189,18 @@ Starts `sql-interactive-mode' after doing some setup." "Command to start osql by Microsoft. Starts `sql-interactive-mode' after doing some setup." - :type 'file - :group 'SQL) + :type 'file) (defcustom sql-ms-options '("-w" "300" "-n") ;; -w is the linesize "List of additional options for `sql-ms-program'." :type '(repeat string) - :version "22.1" - :group 'SQL) + :version "22.1") (defcustom sql-ms-login-params '(user password server database) "List of login parameters needed to connect to Microsoft." :type 'sql-login-params - :version "24.1" - :group 'SQL) + :version "24.1") ;; Customization for Postgres @@ -1251,8 +1208,7 @@ Starts `sql-interactive-mode' after doing some setup." "Command to start psql by Postgres. Starts `sql-interactive-mode' after doing some setup." - :type 'file - :group 'SQL) + :type 'file) (defcustom sql-postgres-options '("-P" "pager=off") "List of additional options for `sql-postgres-program'. @@ -1263,8 +1219,7 @@ name, add the string \"-u\" to the list of options. If you want to provide a user name on the command line (newer versions such as 7.1), add your name with a \"-U\" prefix (such as \"-Umark\") to the list." :type '(repeat string) - :version "20.8" - :group 'SQL) + :version "20.8") (defcustom sql-postgres-login-params `((user :default ,(user-login-name)) @@ -1275,8 +1230,7 @@ add your name with a \"-U\" prefix (such as \"-Umark\") to the list." server) "List of login parameters needed to connect to Postgres." :type 'sql-login-params - :version "26.1" - :group 'SQL) + :version "26.1") (defun sql-postgres-list-databases () "Return a list of available PostgreSQL databases." @@ -1297,20 +1251,17 @@ add your name with a \"-U\" prefix (such as \"-Umark\") to the list." "Command to start isql by Interbase. Starts `sql-interactive-mode' after doing some setup." - :type 'file - :group 'SQL) + :type 'file) (defcustom sql-interbase-options nil "List of additional options for `sql-interbase-program'." :type '(repeat string) - :version "20.8" - :group 'SQL) + :version "20.8") (defcustom sql-interbase-login-params '(user password database) "List of login parameters needed to connect to Interbase." :type 'sql-login-params - :version "24.1" - :group 'SQL) + :version "24.1") ;; Customization for DB2 @@ -1318,20 +1269,17 @@ Starts `sql-interactive-mode' after doing some setup." "Command to start db2 by IBM. Starts `sql-interactive-mode' after doing some setup." - :type 'file - :group 'SQL) + :type 'file) (defcustom sql-db2-options nil "List of additional options for `sql-db2-program'." :type '(repeat string) - :version "20.8" - :group 'SQL) + :version "20.8") (defcustom sql-db2-login-params nil "List of login parameters needed to connect to DB2." :type 'sql-login-params - :version "24.1" - :group 'SQL) + :version "24.1") ;; Customization for Linter @@ -1339,20 +1287,17 @@ Starts `sql-interactive-mode' after doing some setup." "Command to start inl by RELEX. Starts `sql-interactive-mode' after doing some setup." - :type 'file - :group 'SQL) + :type 'file) (defcustom sql-linter-options nil "List of additional options for `sql-linter-program'." :type '(repeat string) - :version "21.3" - :group 'SQL) + :version "21.3") (defcustom sql-linter-login-params '(user password database server) "Login parameters to needed to connect to Linter." :type 'sql-login-params - :version "24.1" - :group 'SQL) + :version "24.1") @@ -1436,10 +1381,7 @@ specified, it's `sql-product' or `sql-connection' must match." (defvar sql-interactive-mode-map (let ((map (make-sparse-keymap))) - (if (fboundp 'set-keymap-parent) - (set-keymap-parent map comint-mode-map); Emacs - (if (fboundp 'set-keymap-parents) - (set-keymap-parents map (list comint-mode-map)))); XEmacs + (set-keymap-parent map comint-mode-map) (if (fboundp 'set-keymap-name) (set-keymap-name map 'sql-interactive-mode-map)); XEmacs (define-key map (kbd "C-j") 'sql-accumulate-and-indent) @@ -2374,7 +2316,8 @@ function `regexp-opt'.") "ansi_warnings" "forceplan" "showplan_all" "showplan_text" "statistics" "implicit_transactions" "remote_proc_transactions" "transaction" "xact_abort" -) t) +) + t) "\\)\\)\\|go\\s-*\\|use\\s-+\\|setuser\\s-+\\|dbcc\\s-+\\).*$") 'font-lock-doc-face) @@ -2740,7 +2683,7 @@ highlighting rules in SQL mode.") nil 'require-match init 'sql-product-history init)))) -(defun sql-add-product (product display &optional plist) +(defun sql-add-product (product display &rest plist) "Add support for a database product in `sql-mode'. Add PRODUCT to `sql-product-alist' which enables `sql-mode' to @@ -2856,7 +2799,7 @@ See `sql-product-alist' for a list of products and supported features." (member feature sql-indirect-features) (not not-indirect) (symbolp v)) - (eval v) + (symbol-value v) v)) (error "`%s' is not a known product; use `sql-add-product' to add it first." product) nil))) @@ -4244,8 +4187,7 @@ must tell Emacs. Here's how to do that in your init file: \(add-hook \\='sql-mode-hook (lambda () - (modify-syntax-entry ?\\\\ \".\" sql-mode-syntax-table)))" - :group 'SQL + (modify-syntax-entry ?\\\\ \"\\\\\" sql-mode-syntax-table)))" :abbrev-table sql-mode-abbrev-table (if sql-mode-menu @@ -4268,6 +4210,18 @@ must tell Emacs. Here's how to do that in your init file: (setq-local abbrev-all-caps 1) ;; Contains the name of database objects (set (make-local-variable 'sql-contains-names) t) + (setq-local syntax-propertize-function + (syntax-propertize-rules + ;; Handle escaped apostrophes within strings. + ("''" + (0 + (if (save-excursion (nth 3 (syntax-ppss (match-beginning 0)))) + (string-to-syntax ".") + (forward-char -1) + nil))) + ;; Propertize rules to not have /- and -* start comments. + ("\\(/-\\)" (1 ".")) + ("\\(-\\*\\)" (1 ".")))) ;; Set syntax and font-face highlighting ;; Catch changes to sql-product and highlight accordingly (sql-set-product (or sql-product 'ansi)) ; Fixes bug#13591 @@ -4280,7 +4234,7 @@ must tell Emacs. Here's how to do that in your init file: (put 'sql-interactive-mode 'mode-class 'special) (put 'sql-interactive-mode 'custom-mode-group 'SQL) ;; FIXME: Why not use `define-derived-mode'? -(defun sql-interactive-mode () +(define-derived-mode sql-interactive-mode comint-mode "SQLi[?]" "Major mode to use a SQL interpreter interactively. Do not call this function by yourself. The environment must be @@ -4348,9 +4302,10 @@ you entered, right above the output it created. \(setq comint-output-filter-functions (function (lambda (STR) (comint-show-output))))" + :syntax-table sql-mode-syntax-table ;; FIXME: The doc above uses `setq' on `comint-output-filter-functions', ;; whereas hooks should be manipulated with things like `add/remove-hook'. - (delay-mode-hooks (comint-mode)) + :after-hook (sql--adjust-interactive-setup) ;; Get the `sql-product' for this interactive session. (set (make-local-variable 'sql-product) @@ -4358,14 +4313,11 @@ you entered, right above the output it created. sql-product)) ;; Setup the mode. - (setq major-mode 'sql-interactive-mode) (setq mode-name (concat "SQLi[" (or (sql-get-product-feature sql-product :name) (symbol-name sql-product)) "]")) - (use-local-map sql-interactive-mode-map) (if sql-interactive-mode-menu (easy-menu-add sql-interactive-mode-menu)) ; XEmacs - (set-syntax-table sql-mode-syntax-table) ;; Note that making KEYWORDS-ONLY nil will cause havoc if you try ;; SELECT 'x' FROM DUAL with SQL*Plus, because the title of the column @@ -4409,9 +4361,10 @@ you entered, right above the output it created. (add-hook 'comint-preoutput-filter-functions #'sql-interactive-remove-continuation-prompt nil t) (make-local-variable 'sql-input-ring-separator) - (make-local-variable 'sql-input-ring-file-name) - ;; Run the mode hook (along with comint's hooks). - (run-mode-hooks 'sql-interactive-mode-hook) + (make-local-variable 'sql-input-ring-file-name)) + +(defun sql--adjust-interactive-setup () + "Finish the mode's setup after running the mode hook." ;; Set comint based on user overrides. (setq comint-prompt-regexp (if sql-prompt-cont-regexp @@ -4490,7 +4443,7 @@ is specified in the connection settings." (dolist (vv connect-set) (let ((var (car vv)) (val (cadr vv))) - (set-default var (eval val)))) + (set-default var (eval val)))) ;FIXME: Why `eval'? (setq-default sql-connection connection) ;; :sqli-login params variable @@ -4521,10 +4474,10 @@ is specified in the connection settings." (if vals (cons var vals) var))))) ;; Start the SQLi session with revised list of login parameters - (eval `(let ((,param-var ',rem-vars)) - (sql-product-interactive - ',sql-product - ',(or buf-name (format "<%s>" connection)))))) + (cl-progv (list param-var) (list rem-vars) + (sql-product-interactive + sql-product + (or buf-name (format "<%s>" connection))))) (user-error "SQL Connection <%s> does not exist" connection) nil))) @@ -4595,7 +4548,10 @@ optionally is saved to the user's init file." (format "Connection <%s>\t%s" (car conn) (let ((sql-user "") (sql-database "") (sql-server "") (sql-port 0)) - (eval `(let ,(cdr conn) (sql-make-alternate-buffer-name))))) + (cl-progv + (mapcar #'car (cdr conn)) + (mapcar #'cadr (cdr conn)) + (sql-make-alternate-buffer-name)))) (list 'sql-connect (car conn)) t)) sql-connection-alist) @@ -4977,8 +4933,7 @@ The default comes from `process-coding-system-alist' and See the distinct values in ALL_OBJECTS.OBJECT_TYPE for possible values." :version "24.1" - :type '(repeat string) - :group 'SQL) + :type '(repeat string)) (defun sql-oracle-completion-object (sqlbuf schema) (sql-redirect-value @@ -5624,21 +5579,18 @@ buffer. (defcustom sql-vertica-program "vsql" "Command to start the Vertica client." :version "25.1" - :type 'file - :group 'SQL) + :type 'file) (defcustom sql-vertica-options '("-P" "pager=off") "List of additional options for `sql-vertica-program'. The default value disables the internal pager." :version "25.1" - :type '(repeat string) - :group 'SQL) + :type '(repeat string)) (defcustom sql-vertica-login-params '(user password database server) "List of login parameters needed to connect to Vertica." :version "25.1" - :type 'sql-login-params - :group 'SQL) + :type 'sql-login-params) (defun sql-comint-vertica (product options &optional buf-name) "Create comint buffer and connect to Vertica." diff --git a/lisp/progmodes/verilog-mode.el b/lisp/progmodes/verilog-mode.el index 460957b7161..5a469bb9677 100644 --- a/lisp/progmodes/verilog-mode.el +++ b/lisp/progmodes/verilog-mode.el @@ -9,7 +9,7 @@ ;; Keywords: languages ;; The "Version" is the date followed by the decimal rendition of the Git ;; commit hex. -;; Version: 2019.12.17.268053413 +;; Version: 2020.06.27.014326051 ;; Yoni Rabkin <yoni@rabkins.net> contacted the maintainer of this ;; file on 19/3/2008, and the maintainer agreed that when a bug is @@ -124,7 +124,7 @@ ;; ;; This variable will always hold the version number of the mode -(defconst verilog-mode-version "2019-12-17-ffa2ba5-vpo-GNU" +(defconst verilog-mode-version "2020-06-27-0da9923-vpo-GNU" "Version of this Verilog mode.") (defconst verilog-mode-release-emacs t "If non-nil, this version of Verilog mode was released with Emacs itself.") @@ -605,7 +605,7 @@ are lineup only when \\[verilog-pretty-declarations] is typed." (function :tag "Other")) :group 'verilog-mode-indent ) (put 'verilog-auto-lineup 'safe-local-variable - '(lambda (x) (memq x '(nil all assignments declarations)))) + (lambda (x) (memq x '(nil all assignments declarations)))) (defcustom verilog-indent-level 3 "Indentation of Verilog statements with respect to containing block." @@ -958,8 +958,8 @@ See `compilation-error-regexp-alist-alist' for the formatting. For XEmacs.") ("syntax error:.*\n\\([^ \t]+\\) *\\([0-9]+\\):" 1 bold t) ("syntax error:.*\n\\([^ \t]+\\) *\\([0-9]+\\):" 2 bold t) ;; verilog-verilator - (".*%?\\(Error\\|Warning\\)\\(-[^:]+\\|\\):[\n ]*\\([^ \t:]+\\):\\([0-9]+\\):" 3 bold t) - (".*%?\\(Error\\|Warning\\)\\(-[^:]+\\|\\):[\n ]*\\([^ \t:]+\\):\\([0-9]+\\):" 4 bold t) + (".*\\(Error\\|Warning\\)\\(-[^:]+\\|\\):[\n ]*\\([^ \t:]+\\):\\([0-9]+\\):" 3 bold t) + (".*\\(Error\\|Warning\\)\\(-[^:]+\\|\\):[\n ]*\\([^ \t:]+\\):\\([0-9]+\\):" 4 bold t) ;; verilog-leda ("^In file \\([^ \t]+\\)[ \t]+line[ \t]+\\([0-9]+\\):\n[^\n]*\n[^\n]*\n\\(Warning\\|Error\\|Failure\\)[^\n]*" 1 bold t) ("^In file \\([^ \t]+\\)[ \t]+line[ \t]+\\([0-9]+\\):\n[^\n]*\n[^\n]*\n\\(Warning\\|Error\\|Failure\\)[^\n]*" 2 bold t) @@ -1118,7 +1118,7 @@ SystemVerilog designs." :type 'boolean :group 'verilog-mode-auto) (put 'verilog-auto-reset-widths 'safe-local-variable - '(lambda (x) (memq x '(nil t unbased)))) + (lambda (x) (memq x '(nil t unbased)))) (defcustom verilog-assignment-delay "" "Text used for delays in delayed assignments. Add a trailing space if set." @@ -1138,7 +1138,7 @@ line." (const :tag "Line up Assignment statements" single)) :group 'verilog-mode-auto) (put 'verilog-auto-arg-format 'safe-local-variable - '(lambda (x) (memq x '(packed single)))) + (lambda (x) (memq x '(packed single)))) (defcustom verilog-auto-arg-sort nil "Non-nil means AUTOARG signal names will be sorted, not in declaration order. @@ -1263,7 +1263,7 @@ otherwise no vectors if sizes match (like using nil)." :group 'verilog-mode-auto :type '(choice (const nil) (const t) (const unsigned))) (put 'verilog-auto-inst-vector 'safe-local-variable - '(lambda (x) (memq x '(nil t unsigned)))) + (lambda (x) (memq x '(nil t unsigned)))) (defcustom verilog-auto-inst-template-numbers nil "If true, when creating templated ports with AUTOINST, add a comment. @@ -1280,7 +1280,19 @@ won't merge conflict." :group 'verilog-mode-auto :type '(choice (const nil) (const t) (const lhs))) (put 'verilog-auto-inst-template-numbers 'safe-local-variable - '(lambda (x) (memq x '(nil t lhs)))) + (lambda (x) (memq x '(nil t lhs)))) + +(defcustom verilog-auto-inst-template-required nil + "If non-nil, when creating a port with AUTOINST, require a template. +Any port which does not have a template will be ommitted from the +instantiation. + +If nil, if a port is not templated it will be inserted to connect +to a net with the same name as the port." + :version "28.0" + :group 'verilog-mode-auto + :type 'boolean) +(put 'verilog-auto-inst-template-required 'safe-local-variable 'verilog-booleanp) (defcustom verilog-auto-inst-column 40 "Indent-to column number for net name part of AUTOINST created pin." @@ -1418,7 +1430,7 @@ See also `verilog-case-fold'." :type 'hook) (defvar verilog-imenu-generic-expression - '((nil "^\\s-*\\(?:m\\(?:odule\\|acromodule\\)\\|p\\(?:rimitive\\|rogram\\|ackage\\)\\)\\s-+\\([a-zA-Z0-9_.:]+\\)" 1) + '((nil "^\\s-*\\(?:connectmodule\\|m\\(?:odule\\|acromodule\\)\\|p\\(?:rimitive\\|rogram\\|ackage\\)\\)\\s-+\\([a-zA-Z0-9_.:]+\\)" 1) ("*Variables*" "^\\s-*\\(reg\\|wire\\|logic\\)\\s-+\\(\\|\\[[^]]+\\]\\s-+\\)\\([A-Za-z0-9_]+\\)" 3) ("*Classes*" "^\\s-*\\(?:\\(?:virtual\\|interface\\)\\s-+\\)?class\\s-+\\([A-Za-z_][A-Za-z0-9_]+\\)" 1) ("*Tasks*" "^\\s-*\\(?:\\(?:static\\|pure\\|virtual\\|local\\|protected\\)\\s-+\\)*task\\s-+\\(?:\\(?:static\\|automatic\\)\\s-+\\)?\\([A-Za-z_][A-Za-z0-9_:]+\\)" 1) @@ -2503,11 +2515,13 @@ find the errors." (eval-when-compile (verilog-regexp-words '( "begin" + "connectmodule" "else" "end" "endcase" "endclass" "endclocking" + "endconnectmodule" "endgroup" "endfunction" "endmodule" @@ -2550,6 +2564,7 @@ find the errors." "\\(sequence\\)\\|" ; 14 "\\(clocking\\)\\|" ; 15 "\\(property\\)\\|" ; 16 + "\\(connectmodule\\)\\|" ; 17 "\\)\\>\\)")) (defconst verilog-end-block-re (eval-when-compile @@ -2710,6 +2725,7 @@ find the errors." "endclass" "endclocking" "endconfig" + "endconnectmodule" "endfunction" "endgenerate" "endgroup" @@ -2728,7 +2744,7 @@ find the errors." (defconst verilog-declaration-opener (eval-when-compile (verilog-regexp-words - '("module" "begin" "task" "function")))) + '("connectmodule" "module" "begin" "task" "function")))) (defconst verilog-declaration-prefix-re (eval-when-compile @@ -2790,9 +2806,9 @@ find the errors." (defconst verilog-declaration-re-1-no-macro (concat "^" verilog-declaration-re-2-no-macro)) (defconst verilog-defun-re - (eval-when-compile (verilog-regexp-words '("macromodule" "module" "class" "program" "interface" "package" "primitive" "config")))) + (eval-when-compile (verilog-regexp-words '("macromodule" "connectmodule" "module" "class" "program" "interface" "package" "primitive" "config")))) (defconst verilog-end-defun-re - (eval-when-compile (verilog-regexp-words '("endmodule" "endclass" "endprogram" "endinterface" "endpackage" "endprimitive" "endconfig")))) + (eval-when-compile (verilog-regexp-words '("endconnectmodule" "endmodule" "endclass" "endprogram" "endinterface" "endpackage" "endprimitive" "endconfig")))) (defconst verilog-zero-indent-re (concat verilog-defun-re "\\|" verilog-end-defun-re)) (defconst verilog-inst-comment-re @@ -2824,7 +2840,7 @@ find the errors." "generate" "endgenerate" "initial" "interface" "endinterface" - "module" "macromodule" "endmodule" + "connectmodule" "module" "macromodule" "endconnectmodule" "endmodule" "package" "endpackage" "primitive" "endprimitive" "program" "endprogram" @@ -2892,14 +2908,14 @@ find the errors." (defconst verilog-defun-level-not-generate-re (eval-when-compile (verilog-regexp-words - '( "module" "macromodule" "primitive" "class" "program" + '( "connectmodule" "module" "macromodule" "primitive" "class" "program" "interface" "package" "config")))) (defconst verilog-defun-level-re (eval-when-compile (verilog-regexp-words (append - '( "module" "macromodule" "primitive" "class" "program" + '( "connectmodule" "module" "macromodule" "primitive" "class" "program" "interface" "package" "config") '( "initial" "final" "always" "always_comb" "always_ff" "always_latch" "endtask" "endfunction" ))))) @@ -2914,7 +2930,7 @@ find the errors." (eval-when-compile (verilog-regexp-words '( - "endmodule" "endprimitive" "endinterface" "endpackage" "endprogram" "endclass" + "endconnectmodule" "endmodule" "endprimitive" "endinterface" "endpackage" "endprogram" "endclass" )))) (defconst verilog-dpi-import-export-re @@ -2935,7 +2951,7 @@ find the errors." (eval-when-compile (verilog-regexp-words '( - "always" "assign" "always_latch" "always_ff" "always_comb" "constraint" + "always" "assign" "always_latch" "always_ff" "always_comb" "connectmodule" "constraint" "import" "initial" "final" "module" "macromodule" "repeat" "randcase" "while" "if" "for" "forever" "foreach" "else" "parameter" "do" "localparam" "assert" )))) @@ -3053,6 +3069,8 @@ find the errors." "sync_reject_on" "unique0" "until" "until_with" "untyped" "weak" ;; 1800-2012 "implements" "interconnect" "nettype" "soft" + ;; AMS + "connectmodule" "endconnectmodule" )) "List of Verilog keywords.") @@ -3117,7 +3135,7 @@ See also `verilog-font-lock-extra-types'.") (:foreground "DimGray" :italic t)) (((class grayscale) (background dark)) (:foreground "LightGray" :italic t)) - (t (:italis t))) + (t (:italic t))) "Font lock mode face used to background highlight translate-off regions." :group 'font-lock-highlighting-faces) @@ -3199,7 +3217,7 @@ See also `verilog-font-lock-extra-types'.") "atan2" "atanh" "branch" "ceil" "connect" "connectmodule" "connectrules" "continuous" "cos" "cosh" "ddt" "ddt_nature" "ddx" "discipline" "discrete" "domain" "driver_update" - "endconnectrules" "enddiscipline" "endnature" "endparamset" + "endconnectmodule" "endconnectrules" "enddiscipline" "endnature" "endparamset" "exclude" "exp" "final_step" "flicker_noise" "floor" "flow" "from" "ground" "hypot" "idt" "idt_nature" "idtmod" "inf" "initial_step" "laplace_nd" "laplace_np" "laplace_zd" @@ -3278,9 +3296,9 @@ See also `verilog-font-lock-extra-types'.") (list ;; Fontify module definitions (list - "\\<\\(\\(macro\\)?module\\|primitive\\|class\\|program\\|interface\\|package\\|task\\)\\>\\s-*\\(\\sw+\\)" + "\\<\\(\\(macro\\|connect\\)?module\\|primitive\\|class\\|program\\|interface\\|package\\|task\\)\\>\\s-*\\(\\sw+\\)" '(1 font-lock-keyword-face) - '(3 font-lock-function-name-face 'prepend)) + '(3 font-lock-function-name-face prepend)) ;; Fontify function definitions (list (concat "\\<function\\>\\s-+\\(integer\\|real\\(time\\)?\\|time\\)\\s-+\\(\\sw+\\)" ) @@ -3290,7 +3308,16 @@ See also `verilog-font-lock-extra-types'.") (1 font-lock-keyword-face) (2 font-lock-constant-face append)) '("\\<function\\>\\s-+\\(\\sw+\\)" - 1 'font-lock-constant-face append)))) + 1 'font-lock-constant-face append) + ;; Fontify variable names in declarations + (list ;; Implemented as an anchored-matcher + (concat verilog-declaration-re + " *\\(" verilog-range-re "\\)?") + (list ;; anchored-highlighter + (concat "\\_<\\(" verilog-symbol-re "\\)" + " *\\(" verilog-range-re "\\)?*") + nil nil '(1 font-lock-variable-name-face)))))) + (setq verilog-font-lock-keywords-2 (append verilog-font-lock-keywords-1 @@ -3596,7 +3623,7 @@ Use filename, if current buffer being edited shorten to just buffer name." (setq found 't)))))) ((looking-at verilog-end-block-re) (verilog-leap-to-head)) - ((looking-at "\\(endmodule\\>\\)\\|\\(\\<endprimitive\\>\\)\\|\\(\\<endclass\\>\\)\\|\\(\\<endprogram\\>\\)\\|\\(\\<endinterface\\>\\)\\|\\(\\<endpackage\\>\\)") + ((looking-at "\\(endmodule\\>\\)\\|\\(\\<endprimitive\\>\\)\\|\\(\\<endclass\\>\\)\\|\\(\\<endprogram\\>\\)\\|\\(\\<endinterface\\>\\)\\|\\(\\<endpackage\\>\\)\\|\\(\\<endconnectmodule\\>\\)") (cond ((match-end 1) (verilog-re-search-backward "\\<\\(macro\\)?module\\>" nil 'move)) @@ -3610,6 +3637,8 @@ Use filename, if current buffer being edited shorten to just buffer name." (verilog-re-search-backward "\\<interface\\>" nil 'move)) ((match-end 6) (verilog-re-search-backward "\\<package\\>" nil 'move)) + ((match-end 7) + (verilog-re-search-backward "\\<connectmodule\\>" nil 'move)) (t (goto-char st) (backward-sexp 1)))) @@ -3735,7 +3764,8 @@ Use filename, if current buffer being edited shorten to just buffer name." "\\(\\<class\\>\\)\\|" "\\(\\<program\\>\\)\\|" "\\(\\<interface\\>\\)\\|" - "\\(\\<package\\>\\)")) + "\\(\\<package\\>\\)\\|" + "\\(\\<connectmodule\\>\\)")) (cond ((match-end 1) (verilog-re-search-forward "\\<endmodule\\>" nil 'move)) @@ -3749,6 +3779,8 @@ Use filename, if current buffer being edited shorten to just buffer name." (verilog-re-search-forward "\\<endinterface\\>" nil 'move)) ((match-end 6) (verilog-re-search-forward "\\<endpackage\\>" nil 'move)) + ((match-end 7) + (verilog-re-search-forward "\\<endconnectmodule\\>" nil 'move)) (t (goto-char st) (if (= (following-char) ?\) ) @@ -4556,13 +4588,13 @@ More specifically, point @ in the line foo : @ begin" (let ((nest 1)) (while t (verilog-re-search-backward - (concat "\\(\\<module\\>\\)\\|\\(\\<randcase\\>\\|\\<case[xz]?\\>[^:]\\)\\|" + (concat "\\(\\<module\\>\\)\\|\\(\\<connectmodule\\>\\)\\|\\(\\<randcase\\>\\|\\<case[xz]?\\>[^:]\\)\\|" "\\(\\<endcase\\>\\)\\>") nil 'move) (cond - ((match-end 3) + ((match-end 4) (setq nest (1+ nest))) - ((match-end 2) + ((match-end 3) (if (= nest 1) (throw 'found 1)) (setq nest (1- nest))) @@ -4571,9 +4603,11 @@ More specifically, point @ in the line foo : @ begin" nil))) (defun verilog-backward-up-list (arg) - "Call `backward-up-list' ARG, ignoring comments." + "Call `backward-up-list' ARG, ignoring comments and errors." (let ((parse-sexp-ignore-comments t)) - (backward-up-list arg))) + (condition-case nil + (backward-up-list arg) ;; May throw Unbalanced parenthesis + (error nil)))) (defun verilog-forward-sexp-cmt (arg) "Call `forward-sexp' ARG, inside comments." @@ -4595,13 +4629,15 @@ More specifically, after a generate and before an endgenerate." (while (and (/= nest 0) (verilog-re-search-backward - "\\<\\(module\\)\\|\\(generate\\)\\|\\(endgenerate\\)\\>" nil 'move) + "\\<\\(module\\)\\|\\(connectmodule\\)\\|\\(generate\\)\\|\\(endgenerate\\)\\>" nil 'move) (cond ((match-end 1) ; module - we have crawled out (throw 'done 1)) - ((match-end 2) ; generate + ((match-end 2) ; connectmodule - we have crawled out + (throw 'done 1)) + ((match-end 3) ; generate (setq nest (1- nest))) - ((match-end 3) ; endgenerate + ((match-end 4) ; endgenerate (setq nest (1+ nest)))))))) (= nest 0) )) ; return nest @@ -5064,6 +5100,8 @@ primitive or interface named NAME." (setq reg "\\(\\<clocking\\>\\)\\|\\<endclocking\\>")) ((match-end 16) ; of verilog-end-block-ordered-re (setq reg "\\(\\<property\\>\\)\\|\\<endproperty\\>")) + ((match-end 17) ; of verilog-end-block-ordered-re + (setq reg "\\(\\<connectmodule\\>\\)\\|\\<endconnectmodule\\>")) (t (error "Problem in verilog-set-auto-endcomments"))) (let (b e) @@ -5089,7 +5127,7 @@ primitive or interface named NAME." (setq string (buffer-substring b e))) (t (ding 't) - (setq string "unmatched end(function|task|module|primitive|interface|package|class|clocking)"))))) + (setq string "unmatched end(function|task|module|connectmodule|primitive|interface|package|class|clocking)"))))) (end-of-line) (insert (concat " // " string ))) )))))))))) @@ -5345,7 +5383,7 @@ becomes: (interactive) (save-excursion (beginning-of-line) - (when (looking-at "\\(.*\\)([WE]\\([0-9A-Z]+\\)).*,\\s +line\\s +[0-9]+:\\s +\\([^:\n]+\\):?.*$") + (when (looking-at "\\(.*\\)([WE]\\([0-9A-Z]+\\)).*,\\s +line\\s +[0-9]+:\\s +\\([^:\n]+\\).*$") (replace-match (format ;; %3s makes numbers 1-999 line up nicely "\\1//Verilint %3s off // WARNING: \\3" @@ -5560,7 +5598,7 @@ Return a list of two elements: (INDENT-TYPE INDENT-LEVEL)." (case-fold-search nil) (par 0) (begin (looking-at "[ \t]*begin\\>")) - (lim (save-excursion (verilog-re-search-backward "\\(\\<begin\\>\\)\\|\\(\\<module\\>\\)" nil t))) + (lim (save-excursion (verilog-re-search-backward "\\(\\<begin\\>\\)\\|\\(\\<\\(connect\\)?module\\>\\)" nil t))) (structres nil) (type (catch 'nesting ;; Keep working backwards until we can figure out @@ -6788,7 +6826,7 @@ Do not count named blocks or case-statements." ((looking-at verilog-named-block-re) (current-column)) ((and (not (looking-at verilog-extended-case-re)) - (looking-at "^[^:;]+[ \t]*:")) + (looking-at "^[^:;]+:")) (verilog-re-search-forward ":" nil t) (skip-chars-forward " \t") (current-column)) @@ -7113,7 +7151,7 @@ BASEIND is the base indent to offset everything." (let ((pos (point-marker)) (lim (save-excursion ;; (verilog-re-search-backward verilog-declaration-opener nil 'move) - (verilog-re-search-backward "\\(\\<begin\\>\\)\\|\\(\\<module\\>\\)\\|\\(\\<task\\>\\)" nil 'move) + (verilog-re-search-backward "\\(\\<begin\\>\\)\\|\\(\\<\\(connect\\)?module\\>\\)\\|\\(\\<task\\>\\)" nil 'move) (point))) (ind) (val) @@ -7272,7 +7310,7 @@ it displays a list of all possible completions.") \(integer, real, reg...)") (defvar verilog-cpp-keywords - '("module" "macromodule" "primitive" "timescale" "define" "ifdef" "ifndef" "else" + '("connectmodule" "module" "macromodule" "primitive" "timescale" "define" "ifdef" "ifndef" "else" "endif") "Keywords to complete when at first word of a line in declarative scope. \(initial, always, begin, assign...) @@ -7283,7 +7321,7 @@ will be completed at runtime and should not be added to this list.") (append '( "always" "always_comb" "always_ff" "always_latch" "assign" - "begin" "end" "generate" "endgenerate" "module" "endmodule" + "begin" "end" "connectmodule" "endconnectmodule" "generate" "endgenerate" "module" "endmodule" "specify" "endspecify" "function" "endfunction" "initial" "final" "task" "endtask" "primitive" "endprimitive" ) @@ -7380,9 +7418,9 @@ TYPE is `module', `tf' for task or function, or t if unknown." (if (string= verilog-str "") (setq verilog-str "[a-zA-Z_]")) (let ((verilog-str (concat (cond - ((eq type 'module) "\\<\\(module\\)\\s +") + ((eq type 'module) "\\<\\(module\\|connectmodule\\)\\s +") ((eq type 'tf) "\\<\\(task\\|function\\)\\s +") - (t "\\<\\(task\\|function\\|module\\)\\s +")) + (t "\\<\\(task\\|function\\|module\\|connectmodule\\)\\s +")) "\\<\\(" verilog-str "[a-zA-Z0-9_.]*\\)\\>")) match) @@ -7724,7 +7762,7 @@ If search fails, other files are checked based on (first 1) (prevpos (point-min)) (final-context-start (make-marker)) - (regexp "\\(module\\s-+\\w+\\s-*(\\)\\|\\(\\w+\\s-+\\w+\\s-*(\\)")) + (regexp "\\(\\(connect\\)?module\\s-+\\w+\\s-*(\\)\\|\\(\\w+\\s-+\\w+\\s-*(\\)")) (with-output-to-temp-buffer "*Occur*" (save-excursion (message "Searching for %s ..." regexp) @@ -7782,7 +7820,7 @@ If search fails, other files are checked based on "Return point if within translate-off region, else nil." (and (save-excursion (re-search-backward - (concat "//\\s-*.*\\s-*" verilog-directive-regexp "\\(on\\|off\\)\\>") + (concat "//.*" verilog-directive-regexp "\\(on\\|off\\)\\>") nil t)) (equal "off" (match-string 2)) (point))) @@ -7790,14 +7828,14 @@ If search fails, other files are checked based on (defun verilog-start-translate-off (limit) "Return point before translate-off directive if before LIMIT, else nil." (when (re-search-forward - (concat "//\\s-*.*\\s-*" verilog-directive-regexp "off\\>") + (concat "//.*" verilog-directive-regexp "off\\>") limit t) (match-beginning 0))) (defun verilog-back-to-start-translate-off (limit) "Return point before translate-off directive if before LIMIT, else nil." (when (re-search-backward - (concat "//\\s-*.*\\s-*" verilog-directive-regexp "off\\>") + (concat "//.*" verilog-directive-regexp "off\\>") limit t) (match-beginning 0))) @@ -7805,7 +7843,7 @@ If search fails, other files are checked based on "Return point after translate-on directive if before LIMIT, else nil." (re-search-forward (concat - "//\\s-*.*\\s-*" verilog-directive-regexp "on\\>") limit t)) + "//.*" verilog-directive-regexp "on\\>") limit t)) (defun verilog-match-translate-off (limit) "Match a translate-off block, setting `match-data' and returning t, else nil. @@ -8445,7 +8483,8 @@ Optional NUM-PARAM and MAX-PARAM check for a specific number of parameters." (let ((olist)) (save-excursion ;; /*AUTOPUNT("parameter", "parameter")*/ - (backward-sexp 1) + (when (not (eq (char-before) ?\*)) ; Not .* + (backward-sexp 1)) (while (looking-at "(?\\s *\"\\([^\"]*\\)\"\\s *,?") (setq olist (cons (match-string-no-properties 1) olist)) (goto-char (match-end 0)))) @@ -9895,7 +9934,7 @@ Allows version control to check out the file if need be." (while (and ;; It may be tempting to look for verilog-defun-re, ;; don't, it slows things down a lot! - (verilog-re-search-forward-quick "\\<\\(module\\|interface\\|program\\)\\>" nil t) + (verilog-re-search-forward-quick "\\<\\(connectmodule\\|module\\|interface\\|program\\)\\>" nil t) (setq type (match-string-no-properties 0)) (verilog-re-search-forward-quick "[(;]" nil t)) (if (equal module (verilog-read-module-name)) @@ -9982,7 +10021,7 @@ Or, just the existing dirnames themselves if there are no wildcards." (while dirnames (setq dirname (car dirnames) dirnames (cdr dirnames)) - (cond ((string-match (concat "^\\(\\|[/\\]*[^*?]*[/\\]\\)" ; root + (cond ((string-match (concat "^\\(\\|[^*?]*[/\\]\\)" ; root "\\([^/\\]*[*?][^/\\]*\\)" ; filename with *? "\\(.*\\)") ; rest dirname) @@ -10923,9 +10962,9 @@ shown) will make this into: ;; Presume one module per file. (save-excursion (goto-char (point-min)) - (while (verilog-re-search-forward-quick "\\<module\\>" nil t) + (while (verilog-re-search-forward-quick "\\<\\(connect\\)?module\\>" nil t) (let ((endmodp (save-excursion - (verilog-re-search-forward-quick "\\<endmodule\\>" nil t) + (verilog-re-search-forward-quick "\\<end\\(connect\\)?module\\>" nil t) (point)))) ;; See if there's already a comment .. inside a comment so not verilog-re-search (when (not (re-search-forward "/\\*AUTOARG\\*/" endmodp t)) @@ -11370,9 +11409,10 @@ See the example in `verilog-auto-inout-modport'." (defvar vl-bits nil "See `verilog-auto-inst'.") ; Prevent compile warning (defvar vl-mbits nil "See `verilog-auto-inst'.") ; Prevent compile warning -(defun verilog-auto-inst-port (port-st indent-pt moddecls tpl-list tpl-num for-star par-values) +(defun verilog-auto-inst-port (section port-st indent-pt moddecls tpl-list tpl-num + for-star par-values) "Print out an instantiation connection for this PORT-ST. -Insert to INDENT-PT, use template TPL-LIST. +Inside SECTION, insert to INDENT-PT, use template TPL-LIST. @ are instantiation numbers, replaced with TPL-NUM. @\"(expression @)\" are evaluated, with @ as a variable. If FOR-STAR add comment it is a .* expansion. @@ -11474,60 +11514,74 @@ If PAR-VALUES replace final strings with these parameter values." (setq tpl-net (verilog-string-replace-matches "\\[\\]\\[\\]" dflt-bits nil nil tpl-net)) (setq tpl-net (verilog-string-replace-matches "\\[\\]" vl-bits nil nil tpl-net))) ;; Insert it - (indent-to indent-pt) - (insert "." port) - (unless (and verilog-auto-inst-dot-name - (equal port tpl-net)) - (indent-to verilog-auto-inst-column) - (insert "(" tpl-net ")")) - (insert ",") - (cond (tpl-ass - (verilog-read-auto-template-hit tpl-ass) - (indent-to (+ (if (< verilog-auto-inst-column 48) 24 16) - verilog-auto-inst-column)) - ;; verilog-insert requires the complete comment in one call - including the newline - (cond ((equal verilog-auto-inst-template-numbers 'lhs) - (verilog-insert " // Templated" - " LHS: " (nth 0 tpl-ass) - "\n")) - (verilog-auto-inst-template-numbers - (verilog-insert " // Templated" - " T" (int-to-string (nth 2 tpl-ass)) - " L" (int-to-string (nth 3 tpl-ass)) - "\n")) - (t - (verilog-insert " // Templated\n")))) - (for-star - (indent-to (+ (if (< verilog-auto-inst-column 48) 24 16) - verilog-auto-inst-column)) - (verilog-insert " // Implicit .*\n")) - (t - (insert "\n"))))) -;;(verilog-auto-inst-port (list "foo" "[5:0]") 10 (list (list "foo" "a@\"(% (+ @ 1) 4)\"a")) "3") + (when (or tpl-ass (not verilog-auto-inst-template-required)) + (verilog-auto-inst-first section) + (indent-to indent-pt) + (insert "." port) + (unless (and verilog-auto-inst-dot-name + (equal port tpl-net)) + (indent-to verilog-auto-inst-column) + (insert "(" tpl-net ")")) + (insert ",") + (cond (tpl-ass + (verilog-read-auto-template-hit tpl-ass) + (indent-to (+ (if (< verilog-auto-inst-column 48) 24 16) + verilog-auto-inst-column)) + ;; verilog-insert requires the complete comment in one call - including the newline + (cond ((equal verilog-auto-inst-template-numbers 'lhs) + (verilog-insert " // Templated" + " LHS: " (nth 0 tpl-ass) + "\n")) + (verilog-auto-inst-template-numbers + (verilog-insert " // Templated" + " T" (int-to-string (nth 2 tpl-ass)) + " L" (int-to-string (nth 3 tpl-ass)) + "\n")) + (t + (verilog-insert " // Templated\n")))) + (for-star + (indent-to (+ (if (< verilog-auto-inst-column 48) 24 16) + verilog-auto-inst-column)) + (verilog-insert " // Implicit .*\n")) + (t + (insert "\n")))))) +;;(verilog-auto-inst-port "" (list "foo" "[5:0]") 10 (list (list "foo" "a@\"(% (+ @ 1) 4)\"a")) "3") ;;(x "incom[@\"(+ (* 8 @) 7)\":@\"(* 8 @)\"]") ;;(x ".out (outgo[@\"(concat (+ (* 8 @) 7) \\\":\\\" ( * 8 @))\"]));") -(defun verilog-auto-inst-port-list (sig-list indent-pt moddecls tpl-list tpl-num for-star par-values) - "For `verilog-auto-inst' print a list of ports using `verilog-auto-inst-port'." - (when verilog-auto-inst-sort - (setq sig-list (sort (copy-alist sig-list) #'verilog-signals-sort-compare))) - (mapc (lambda (port) - (verilog-auto-inst-port port indent-pt moddecls - tpl-list tpl-num for-star par-values)) - sig-list)) +(defvar verilog-auto-inst-first-section nil + "Local first-in-section for `verilog-auto-inst-first'.") +(defvar verilog-auto-inst-first-any nil + "Local first-in-any-section for `verilog-auto-inst-first'.") -(defun verilog-auto-inst-first () - "Insert , etc before first ever port in this instant, as part of \\[verilog-auto-inst]." +(defun verilog-auto-inst-first (section) + "Insert , and SECTION before port, as part of \\[verilog-auto-inst]." ;; Do we need a trailing comma? ;; There maybe an ifdef or something similar before us. What a mess. Thus ;; to avoid trouble we only insert on preceding ) or *. ;; Insert first port on new line - (insert "\n") ; Must insert before search, so point will move forward if insert comma - (save-excursion - (verilog-re-search-backward-quick "[^ \t\n\f]" nil nil) - (when (looking-at ")\\|\\*") ; Generally don't insert, unless we are fairly sure - (forward-char 1) - (insert ",")))) + (when verilog-auto-inst-first-any + (setq verilog-auto-inst-first-any nil) + (insert "\n") ; Must insert before search, so point will move forward if insert comma + (save-excursion + (verilog-re-search-backward-quick "[^ \t\n\f]" nil nil) + (when (looking-at ")\\|\\*") ; Generally don't insert, unless we are fairly sure + (forward-char 1) + (insert ",")))) + (when verilog-auto-inst-first-section + (setq verilog-auto-inst-first-section nil) + (verilog-insert-indent section))) + +(defun verilog-auto-inst-port-list (section sig-list indent-pt moddecls + tpl-list tpl-num for-star par-values) + "For `verilog-auto-inst' print a list of ports using `verilog-auto-inst-port'." + (when verilog-auto-inst-sort + (setq sig-list (sort (copy-alist sig-list) #'verilog-signals-sort-compare))) + (let ((verilog-auto-inst-first-section t)) + (mapc (lambda (port) + (verilog-auto-inst-port section port indent-pt moddecls + tpl-list tpl-num for-star par-values)) + sig-list))) (defun verilog-auto-star () "Expand SystemVerilog .* pins, as part of \\[verilog-auto]. @@ -11554,6 +11608,9 @@ Replace the pin connections to an instantiation or interface declaration with ones automatically derived from the module or interface header of the instantiated item. +You may also provide an optional regular expression, in which +case only I/O matching the regular expression will be included. + If `verilog-auto-star-expand' is set, also expand SystemVerilog .* ports, and delete them before saving unless `verilog-auto-star-save' is set. See `verilog-auto-star' for more information. @@ -11697,6 +11754,10 @@ Templates: debugging is completed though, it will result in lots of extra differences and merge conflicts. + If a connection name does not match any template, it is + connected to a net by the same name as the port (unless + `verilog-auto-inst-template-required' is true). + Setting `verilog-auto-template-warn-unused' will report errors if any template lines are unused. @@ -11868,16 +11929,19 @@ For more information see the \\[verilog-faq] and forums at URL `https://www.veripool.org'." (save-excursion ;; Find beginning - (let* ((pt (point)) + (let* ((params (verilog-read-auto-params 0 1)) + (regexp (nth 0 params)) + (pt (point)) (for-star (save-excursion (backward-char 2) (looking-at "\\.\\*"))) (indent-pt (save-excursion (verilog-backward-open-paren) (1+ (current-column)))) (verilog-auto-inst-column (max verilog-auto-inst-column (+ 16 (* 8 (/ (+ indent-pt 7) 8))))) + (verilog-auto-inst-first-any t) (modi (verilog-modi-current)) (moddecls (verilog-modi-get-decls modi)) submod submodi submoddecls - inst skip-pins tpl-list tpl-num did-first par-values) + inst skip-pins tpl-list tpl-num par-values) ;; Find module name that is instantiated (setq submod (verilog-read-inst-module) @@ -11912,53 +11976,58 @@ For more information see the \\[verilog-faq] and forums at URL (verilog-decls-get-vars submoddecls) skip-pins))) (vl-dir "interfaced")) + (when regexp + (setq sig-list (verilog-signals-matching-regexp sig-list regexp))) (when (and sig-list verilog-auto-inst-interfaced-ports) - (when (not did-first) (verilog-auto-inst-first) (setq did-first t)) ;; Note these are searched for in verilog-read-sub-decls. - (verilog-insert-indent "// Interfaced\n") - (verilog-auto-inst-port-list sig-list indent-pt moddecls + (verilog-auto-inst-port-list "// Interfaced\n" + sig-list indent-pt moddecls tpl-list tpl-num for-star par-values))) (let ((sig-list (verilog-signals-not-in (verilog-decls-get-interfaces submoddecls) skip-pins)) (vl-dir "interface")) + (when regexp + (setq sig-list (verilog-signals-matching-regexp sig-list regexp))) (when sig-list - (when (not did-first) (verilog-auto-inst-first) (setq did-first t)) ;; Note these are searched for in verilog-read-sub-decls. - (verilog-insert-indent "// Interfaces\n") - (verilog-auto-inst-port-list sig-list indent-pt moddecls - tpl-list tpl-num for-star par-values))) + (verilog-auto-inst-port-list "// Interfaces\n" + sig-list indent-pt moddecls + tpl-list tpl-num for-star par-values))) (let ((sig-list (verilog-signals-not-in (verilog-decls-get-outputs submoddecls) skip-pins)) (vl-dir "output")) + (when regexp + (setq sig-list (verilog-signals-matching-regexp sig-list regexp))) (when sig-list - (when (not did-first) (verilog-auto-inst-first) (setq did-first t)) - (verilog-insert-indent "// Outputs\n") - (verilog-auto-inst-port-list sig-list indent-pt moddecls + (verilog-auto-inst-port-list "// Outputs\n" + sig-list indent-pt moddecls tpl-list tpl-num for-star par-values))) (let ((sig-list (verilog-signals-not-in (verilog-decls-get-inouts submoddecls) skip-pins)) (vl-dir "inout")) + (when regexp + (setq sig-list (verilog-signals-matching-regexp sig-list regexp))) (when sig-list - (when (not did-first) (verilog-auto-inst-first) (setq did-first t)) - (verilog-insert-indent "// Inouts\n") - (verilog-auto-inst-port-list sig-list indent-pt moddecls + (verilog-auto-inst-port-list "// Inouts\n" + sig-list indent-pt moddecls tpl-list tpl-num for-star par-values))) (let ((sig-list (verilog-signals-not-in (verilog-decls-get-inputs submoddecls) skip-pins)) (vl-dir "input")) + (when regexp + (setq sig-list (verilog-signals-matching-regexp sig-list regexp))) (when sig-list - (when (not did-first) (verilog-auto-inst-first) (setq did-first t)) - (verilog-insert-indent "// Inputs\n") - (verilog-auto-inst-port-list sig-list indent-pt moddecls + (verilog-auto-inst-port-list "// Inputs\n" + sig-list indent-pt moddecls tpl-list tpl-num for-star par-values))) ;; Kill extra semi (save-excursion - (cond (did-first + (cond ((not verilog-auto-inst-first-any) (re-search-backward "," pt t) (delete-char 1) (insert ");") @@ -12020,10 +12089,11 @@ Templates: (1+ (current-column)))) (verilog-auto-inst-column (max verilog-auto-inst-column (+ 16 (* 8 (/ (+ indent-pt 7) 8))))) + (verilog-auto-inst-first-any t) (modi (verilog-modi-current)) (moddecls (verilog-modi-get-decls modi)) submod submodi submoddecls - inst skip-pins tpl-list tpl-num did-first) + inst skip-pins tpl-list tpl-num) ;; Find module name that is instantiated (setq submod (save-excursion ;; Get to the point where AUTOINST normally is to read the module @@ -12060,14 +12130,13 @@ Templates: (when regexp (setq sig-list (verilog-signals-matching-regexp sig-list regexp))) (when sig-list - (when (not did-first) (verilog-auto-inst-first) (setq did-first t)) ;; Note these are searched for in verilog-read-sub-decls. - (verilog-insert-indent "// Parameters\n") - (verilog-auto-inst-port-list sig-list indent-pt moddecls + (verilog-auto-inst-port-list "// Parameters\n" + sig-list indent-pt moddecls tpl-list tpl-num nil nil))) ;; Kill extra semi (save-excursion - (cond (did-first + (cond ((not verilog-auto-inst-first-any) (re-search-backward "," pt t) (delete-char 1) (insert ")") diff --git a/lisp/progmodes/vhdl-mode.el b/lisp/progmodes/vhdl-mode.el index 39819131010..9cd84cf713b 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/progmodes/which-func.el b/lisp/progmodes/which-func.el index 1cee552b0c0..266f40abbae 100644 --- a/lisp/progmodes/which-func.el +++ b/lisp/progmodes/which-func.el @@ -186,7 +186,7 @@ and you want to simplify them for the mode line "Non-nil means display current function name in mode line. This makes a difference only if `which-function-mode' is non-nil.") -(add-hook 'find-file-hook 'which-func-ff-hook t) +(add-hook 'after-change-major-mode-hook 'which-func-ff-hook t) (defun which-func-try-to-enable () (unless (or (not which-function-mode) @@ -195,7 +195,7 @@ This makes a difference only if `which-function-mode' is non-nil.") (member major-mode which-func-modes))))) (defun which-func-ff-hook () - "File find hook for Which Function mode. + "`after-change-major-mode-hook' for Which Function mode. It creates the Imenu index for the buffer, if necessary." (which-func-try-to-enable) @@ -282,52 +282,55 @@ If no function name is found, return nil." (when (null name) (setq name (add-log-current-defun))) ;; If Imenu is loaded, try to make an index alist with it. + ;; If `add-log-current-defun' ran and gave nil, accept that. (when (and (null name) - (boundp 'imenu--index-alist) - (or (null imenu--index-alist) - ;; Update if outdated - (/= (buffer-chars-modified-tick) imenu-menubar-modified-tick)) - (null which-function-imenu-failed)) - (ignore-errors (imenu--make-index-alist t)) - (unless imenu--index-alist - (set (make-local-variable 'which-function-imenu-failed) t))) - ;; If we have an index alist, use it. - (when (and (null name) - (boundp 'imenu--index-alist) imenu--index-alist) - (let ((alist imenu--index-alist) - (minoffset (point-max)) - offset pair mark imstack namestack) - ;; Elements of alist are either ("name" . marker), or - ;; ("submenu" ("name" . marker) ... ). The list can be - ;; arbitrarily nested. - (while (or alist imstack) - (if (null alist) - (setq alist (car imstack) - namestack (cdr namestack) - imstack (cdr imstack)) - - (setq pair (car-safe alist) - alist (cdr-safe alist)) - - (cond - ((atom pair)) ; Skip anything not a cons. - - ((imenu--subalist-p pair) - (setq imstack (cons alist imstack) - namestack (cons (car pair) namestack) - alist (cdr pair))) - - ((or (number-or-marker-p (setq mark (cdr pair))) - (and (overlayp mark) - (setq mark (overlay-start mark)))) - (when (and (>= (setq offset (- (point) mark)) 0) - (< offset minoffset)) ; Find the closest item. - (setq minoffset offset - name (if (null which-func-imenu-joiner-function) - (car pair) - (funcall - which-func-imenu-joiner-function - (reverse (cons (car pair) namestack)))))))))))) + (null add-log-current-defun-function)) + (when (and (null name) + (boundp 'imenu--index-alist) + (or (null imenu--index-alist) + ;; Update if outdated + (/= (buffer-chars-modified-tick) imenu-menubar-modified-tick)) + (null which-function-imenu-failed)) + (ignore-errors (imenu--make-index-alist t)) + (unless imenu--index-alist + (set (make-local-variable 'which-function-imenu-failed) t))) + ;; If we have an index alist, use it. + (when (and (null name) + (boundp 'imenu--index-alist) imenu--index-alist) + (let ((alist imenu--index-alist) + (minoffset (point-max)) + offset pair mark imstack namestack) + ;; Elements of alist are either ("name" . marker), or + ;; ("submenu" ("name" . marker) ... ). The list can be + ;; arbitrarily nested. + (while (or alist imstack) + (if (null alist) + (setq alist (car imstack) + namestack (cdr namestack) + imstack (cdr imstack)) + + (setq pair (car-safe alist) + alist (cdr-safe alist)) + + (cond + ((atom pair)) ; Skip anything not a cons. + + ((imenu--subalist-p pair) + (setq imstack (cons alist imstack) + namestack (cons (car pair) namestack) + alist (cdr pair))) + + ((or (number-or-marker-p (setq mark (cdr pair))) + (and (overlayp mark) + (setq mark (overlay-start mark)))) + (when (and (>= (setq offset (- (point) mark)) 0) + (< offset minoffset)) ; Find the closest item. + (setq minoffset offset + name (if (null which-func-imenu-joiner-function) + (car pair) + (funcall + which-func-imenu-joiner-function + (reverse (cons (car pair) namestack))))))))))))) ;; Filter the name if requested. (when name (if which-func-cleanup-function diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index c36a9bd9940..3e3a37f6da5 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -1,6 +1,11 @@ -;; xref.el --- Cross-referencing commands -*-lexical-binding:t-*- +;;; xref.el --- Cross-referencing commands -*-lexical-binding:t-*- ;; Copyright (C) 2014-2020 Free Software Foundation, Inc. +;; Version: 1.0.1 +;; Package-Requires: ((emacs "26.3") (project "0.1.1")) + +;; This is a GNU ELPA :core package. Avoid functionality that is not +;; compatible with the version of Emacs recorded above. ;; This file is part of GNU Emacs. @@ -259,16 +264,20 @@ be found, return nil. The default implementation uses `semantic-symref-tool-alist' to find a search tool; by default, this uses \"find | grep\" in the `project-current' roots." - (cl-mapcan + (mapcan (lambda (dir) (xref-references-in-directory identifier dir)) (let ((pr (project-current t))) - (append - (project-roots pr) + (cons + (project-root pr) (project-external-roots pr))))) (cl-defgeneric xref-backend-apropos (backend pattern) - "Find all symbols that match regexp PATTERN.") + "Find all symbols that match PATTERN string. +The second argument has the same meaning as in `apropos'. + +If BACKEND is implemented in Lisp, it can use +`xref-apropos-regexp' to convert the pattern to regexp.") (cl-defgeneric xref-backend-identifier-at-point (_backend) "Return the relevant identifier at point. @@ -1093,14 +1102,24 @@ The argument has the same meaning as in `apropos'." "Search for pattern (word list or regexp): " nil 'xref--read-pattern-history))) (require 'apropos) - (xref--find-xrefs pattern 'apropos - (apropos-parse-pattern - (if (string-equal (regexp-quote pattern) pattern) - ;; Split into words - (or (split-string pattern "[ \t]+" t) - (user-error "No word list given")) - pattern)) - nil)) + (let* ((newpat + (if (and (version< emacs-version "28.0.50") + (memq (xref-find-backend) '(elisp etags))) + ;; Handle backends in older Emacs. + (xref-apropos-regexp pattern) + ;; Delegate pattern handling to the backend fully. + ;; The old way didn't work for "external" backends. + pattern))) + (xref--find-xrefs pattern 'apropos newpat nil))) + +(defun xref-apropos-regexp (pattern) + "Return an Emacs regexp from PATTERN similar to `apropos'." + (apropos-parse-pattern + (if (string-equal (regexp-quote pattern) pattern) + ;; Split into words + (or (split-string pattern "[ \t]+" t) + (user-error "No word list given")) + pattern))) ;;; Key bindings @@ -1317,11 +1336,11 @@ directory, used as the root of the ignore globs." (lambda (ignore) (when (string-match-p "/\\'" ignore) (setq ignore (concat ignore "*"))) - (if (string-match "\\`\\./" ignore) - (setq ignore (replace-match dir t t ignore)) - (unless (string-prefix-p "*" ignore) - (setq ignore (concat "*/" ignore)))) - (shell-quote-argument ignore)) + (shell-quote-argument (if (string-match "\\`\\./" ignore) + (replace-match dir t t ignore) + (if (string-prefix-p "*" ignore) + ignore + (concat "*/" ignore))))) ignores " -o -path ") " " @@ -1364,8 +1383,8 @@ Such as the current syntax table and the applied syntax properties." (let (xref--last-file-buffer (tmp-buffer (generate-new-buffer " *xref-temp*"))) (unwind-protect - (cl-mapcan (lambda (hit) (xref--collect-matches hit regexp tmp-buffer)) - hits) + (mapcan (lambda (hit) (xref--collect-matches hit regexp tmp-buffer)) + hits) (kill-buffer tmp-buffer)))) (defun xref--collect-matches (hit regexp tmp-buffer) diff --git a/lisp/ps-def.el b/lisp/ps-def.el index 49d72d3be50..f532511b977 100644 --- a/lisp/ps-def.el +++ b/lisp/ps-def.el @@ -55,7 +55,7 @@ (face-background face nil t)) -(defalias 'ps-frame-parameter 'frame-parameter) +(define-obsolete-function-alias 'ps-frame-parameter #'frame-parameter "28.1") ;; Return t if the device (which can be changed during an emacs session) can ;; handle colors. This function is not yet implemented for GNU emacs. diff --git a/lisp/ps-print.el b/lisp/ps-print.el index ace30017814..17b486bca11 100644 --- a/lisp/ps-print.el +++ b/lisp/ps-print.el @@ -5761,7 +5761,7 @@ XSTART YSTART are the relative position for the first page in a sheet.") (eq genfunc 'ps-generate-postscript)) nil) ((eq ps-default-bg 'frame-parameter) - (ps-frame-parameter nil 'background-color)) + (frame-parameter nil 'background-color)) ((eq ps-default-bg t) (ps-face-background-name 'default)) (t @@ -5775,7 +5775,7 @@ XSTART YSTART are the relative position for the first page in a sheet.") (eq genfunc 'ps-generate-postscript)) nil) ((eq ps-default-fg 'frame-parameter) - (ps-frame-parameter nil 'foreground-color)) + (frame-parameter nil 'foreground-color)) ((eq ps-default-fg t) (ps-face-foreground-name 'default)) (t diff --git a/lisp/recentf.el b/lisp/recentf.el index b636e594864..877edd4be1f 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. @@ -1287,7 +1289,8 @@ Write data into the file specified by `recentf-save-file'." (insert "\n \n;; Local Variables:\n" (format ";; coding: %s\n" recentf-save-file-coding-system) ";; End:\n") - (write-file (expand-file-name recentf-save-file)) + (write-region (point-min) (point-max) + (expand-file-name recentf-save-file)) (when recentf-save-file-modes (set-file-modes recentf-save-file recentf-save-file-modes)) nil) 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/repeat.el b/lisp/repeat.el index db33b083386..f275db6fddf 100644 --- a/lisp/repeat.el +++ b/lisp/repeat.el @@ -4,7 +4,7 @@ ;; Author: Will Mengarini <seldon@eskimo.com> ;; Created: Mo 02 Mar 98 -;; Version: 0.51 +;; Old-Version: 0.51 ;; Keywords: convenience, vi, repeat ;; This file is part of GNU Emacs. diff --git a/lisp/replace.el b/lisp/replace.el index 0880cbdb1ea..69092c16f96 100644 --- a/lisp/replace.el +++ b/lisp/replace.el @@ -757,6 +757,13 @@ which will run faster and will not set the mark or print anything." Maximum length of the history list is determined by the value of `history-length', which see.") +(defvar occur-highlight-regexp t + "Regexp matching part of visited source lines to highlight temporarily. +Highlight entire line if t; don't highlight source lines if nil.") + +(defvar occur-highlight-overlay nil + "Overlay used to temporarily highlight occur matches.") + (defvar occur-collect-regexp-history '("\\1") "History of regexp for occur's collect operation") @@ -1113,6 +1120,8 @@ a previously found match." (define-key map "\C-m" 'occur-mode-goto-occurrence) (define-key map "o" 'occur-mode-goto-occurrence-other-window) (define-key map "\C-o" 'occur-mode-display-occurrence) + (define-key map "n" 'next-error-no-select) + (define-key map "p" 'previous-error-no-select) (define-key map "\M-n" 'occur-next) (define-key map "\M-p" 'occur-prev) (define-key map "r" 'occur-rename-buffer) @@ -1261,9 +1270,12 @@ If not invoked by a mouse click, go to occurrence on the current line." (with-current-buffer (window-buffer (posn-window (event-end event))) (save-excursion (goto-char (posn-point (event-end event))) - (occur-mode-find-occurrence)))))) + (occur-mode-find-occurrence))))) + (regexp occur-highlight-regexp)) (pop-to-buffer (marker-buffer pos)) (goto-char pos) + (let ((end-mk (save-excursion (re-search-forward regexp nil t)))) + (occur--highlight-occurrence pos end-mk)) (when buffer (next-error-found buffer (current-buffer))) (run-hooks 'occur-mode-find-occurrence-hook))) @@ -1277,17 +1289,74 @@ If not invoked by a mouse click, go to occurrence on the current line." (next-error-found buffer (current-buffer)) (run-hooks 'occur-mode-find-occurrence-hook))) +;; Stolen from compile.el +(defun occur-goto-locus-delete-o () + (delete-overlay occur-highlight-overlay) + ;; Get rid of timer and hook that would try to do this again. + (if (timerp next-error-highlight-timer) + (cancel-timer next-error-highlight-timer)) + (remove-hook 'pre-command-hook + #'occur-goto-locus-delete-o)) + +;; Highlight the current visited occurrence. +;; Adapted from `compilation-goto-locus'. +(defun occur--highlight-occurrence (mk end-mk) + (let ((highlight-regexp occur-highlight-regexp)) + (if (timerp next-error-highlight-timer) + (cancel-timer next-error-highlight-timer)) + (unless occur-highlight-overlay + (setq occur-highlight-overlay + (make-overlay (point-min) (point-min))) + (overlay-put occur-highlight-overlay 'face 'next-error)) + (with-current-buffer (marker-buffer mk) + (save-excursion + (if end-mk (goto-char end-mk) (end-of-line)) + (let ((end (point))) + (if mk (goto-char mk) (beginning-of-line)) + (if (and (stringp highlight-regexp) + (re-search-forward highlight-regexp end t)) + (progn + (goto-char (match-beginning 0)) + (move-overlay occur-highlight-overlay + (match-beginning 0) (match-end 0) + (current-buffer))) + (move-overlay occur-highlight-overlay + (point) end (current-buffer))) + (if (or (eq next-error-highlight t) + (numberp next-error-highlight)) + ;; We want highlighting: delete overlay on next input. + (add-hook 'pre-command-hook + #'occur-goto-locus-delete-o) + ;; We don't want highlighting: delete overlay now. + (delete-overlay occur-highlight-overlay)) + ;; We want highlighting for a limited time: + ;; set up a timer to delete it. + (when (numberp next-error-highlight) + (setq next-error-highlight-timer + (run-at-time next-error-highlight nil + 'occur-goto-locus-delete-o)))))) + (when (eq next-error-highlight 'fringe-arrow) + ;; We want a fringe arrow (instead of highlighting). + (setq next-error-overlay-arrow-position + (copy-marker (line-beginning-position)))))) + (defun occur-mode-display-occurrence () "Display in another window the occurrence the current line describes." (interactive) (let ((buffer (current-buffer)) (pos (occur-mode-find-occurrence)) + (regexp occur-highlight-regexp) + (next-error-highlight next-error-highlight-no-select) + (display-buffer-overriding-action + '(nil (inhibit-same-window . t))) window) (setq window (display-buffer (marker-buffer pos) t)) ;; This is the way to set point in the proper window. (save-selected-window (select-window window) (goto-char pos) + (let ((end-mk (save-excursion (re-search-forward regexp nil t)))) + (occur--highlight-occurrence pos end-mk)) (next-error-found buffer (current-buffer)) (run-hooks 'occur-mode-find-occurrence-hook)))) @@ -1583,7 +1652,8 @@ See also `multi-occur'." (and (overlayp boo) (overlay-buffer boo))) boo)) - bufs)))) + bufs))) + (source-buffer-default-directory default-directory)) ;; Handle the case where one of the buffers we're searching is the ;; output buffer. Just rename it. (when (member buf-name @@ -1600,6 +1670,9 @@ See also `multi-occur'." (setq occur-buf (get-buffer-create buf-name)) (with-current-buffer occur-buf + ;; Make the default-directory of the *Occur* buffer match that of + ;; the buffer where the occurences come from + (setq default-directory source-buffer-default-directory) (if (stringp nlines) (fundamental-mode) ;; This is for collect operation. (occur-mode)) @@ -1608,6 +1681,7 @@ See also `multi-occur'." (buffer-undo-list t) (occur--final-pos nil)) (erase-buffer) + (set (make-local-variable 'occur-highlight-regexp) regexp) (let ((count (if (stringp nlines) ;; Treat nlines as a regexp to collect. @@ -1944,10 +2018,8 @@ See also `multi-occur'." global-matches))) (defun occur-engine-line (beg end &optional keep-props) - (if (and keep-props (if (boundp 'jit-lock-mode) jit-lock-mode) - (text-property-not-all beg end 'fontified t)) - (if (fboundp 'jit-lock-fontify-now) - (jit-lock-fontify-now beg end))) + (if (and keep-props font-lock-mode) + (font-lock-ensure beg end)) (if (and keep-props (not (eq occur-excluded-properties t))) (let ((str (buffer-substring beg end))) (remove-list-of-text-properties diff --git a/lisp/ruler-mode.el b/lisp/ruler-mode.el index f6b49b46e3f..82e6178da14 100644 --- a/lisp/ruler-mode.el +++ b/lisp/ruler-mode.el @@ -4,7 +4,7 @@ ;; Author: David Ponce <david@dponce.com> ;; Created: 24 Mar 2001 -;; Version: 1.6 +;; Old-Version: 1.6 ;; Keywords: convenience ;; This file is part of GNU Emacs. diff --git a/lisp/saveplace.el b/lisp/saveplace.el index fa0e181bb10..d420bfb4e9f 100644 --- a/lisp/saveplace.el +++ b/lisp/saveplace.el @@ -1,4 +1,4 @@ -;;; saveplace.el --- automatically save place in files +;;; saveplace.el --- automatically save place in files -*- lexical-binding:t -*- ;; Copyright (C) 1993-1994, 2001-2020 Free Software Foundation, Inc. @@ -42,7 +42,6 @@ "Automatically save place in files." :group 'data) - (defvar save-place-alist nil "Alist of saved places to go back to when revisiting files. Each element looks like (FILENAME . POSITION); @@ -175,10 +174,11 @@ file: (declare-function dired-get-filename "dired" (&optional localp no-error-if-not-filep)) (defun save-place-to-alist () - ;; put filename and point in a cons box and then cons that onto the - ;; front of the save-place-alist, if save-place-mode is non-nil. - ;; Otherwise, just delete that file from the alist. - ;; first check to make sure alist has been loaded in from the master + "Add current buffer filename and position to `save-place-alist'. +Put filename and point in a cons box and then cons that onto the +front of the `save-place-alist', if `save-place-mode' is non-nil. +Otherwise, just delete that file from the alist." + ;; First check to make sure alist has been loaded in from the master ;; file. If not, do so, then feel free to modify the alist. It ;; will be saved again when Emacs is killed. (or save-place-loaded (load-save-place-alist-from-file)) @@ -248,8 +248,8 @@ may have changed) back to `save-place-alist'." (delete-region (point-min) (point-max)) (when save-place-forget-unreadable-files (save-place-forget-unreadable-files)) - (insert (format ";;; -*- coding: %s -*-\n" - (symbol-name coding-system-for-write))) + (insert (format ";;; -*- coding: %s; mode: lisp-data -*-\n" + coding-system-for-write)) (let ((print-length nil) (print-level nil)) (pp save-place-alist (current-buffer))) 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/scroll-lock.el b/lisp/scroll-lock.el index 3a6d9d36429..f20ea1bcc87 100644 --- a/lisp/scroll-lock.el +++ b/lisp/scroll-lock.el @@ -1,4 +1,4 @@ -;;; scroll-lock.el --- Scroll lock scrolling. +;;; scroll-lock.el --- Scroll lock scrolling. -*- lexical-binding:t -*- ;; Copyright (C) 2005-2020 Free Software Foundation, Inc. diff --git a/lisp/server.el b/lisp/server.el index e6d8b1783c9..9934e1c1be9 100644 --- a/lisp/server.el +++ b/lisp/server.el @@ -274,10 +274,11 @@ the \"-f\" switch otherwise." (if internal--daemon-sockname (file-name-directory internal--daemon-sockname) (and (featurep 'make-network-process '(:family local)) - (let ((xdg_runtime_dir (getenv "XDG_RUNTIME_DIR"))) - (if xdg_runtime_dir - (format "%s/emacs" xdg_runtime_dir) - (format "%s/emacs%d" (or (getenv "TMPDIR") "/tmp") (user-uid)))))) + (let ((runtime-dir (getenv "XDG_RUNTIME_DIR"))) + (if runtime-dir + (expand-file-name "emacs" runtime-dir) + (expand-file-name (format "emacs%d" (user-uid)) + (or (getenv "TMPDIR") "/tmp")))))) "The directory in which to place the server socket. If local sockets are not supported, this is nil.") @@ -563,7 +564,7 @@ See variable `server-auth-dir' for details." (format "it is not owned by you (owner = %s (%d))" (user-full-name uid) uid)) (w32 nil) ; on NTFS? - ((let ((modes (file-modes dir))) + ((let ((modes (file-modes dir 'nofollow))) (unless (zerop (logand (or modes 0) #o077)) (format "it is accessible by others (%03o)" modes)))) (t nil)))) diff --git a/lisp/shell.el b/lisp/shell.el index dc1198b7bac..f5e18bbc728 100644 --- a/lisp/shell.el +++ b/lisp/shell.el @@ -249,7 +249,7 @@ This mirrors the optional behavior of tcsh." (defcustom shell-chdrive-regexp (if (memq system-type '(ms-dos windows-nt)) ; NetWare allows the five chars between upper and lower alphabetics. - "[]a-zA-Z^_`\\[\\\\]:" + "[]a-zA-Z^_`[\\]:" nil) "If non-nil, is regexp used to track drive changes." :type '(choice regexp @@ -374,7 +374,7 @@ Thus, this does not include the shell's current directory.") "\\|\\$\\(?:\\([[:alpha:]][[:alnum:]]*\\)" "\\|{\\(?1:[^{}]+\\)}\\)" (when (memq system-type '(ms-dos windows-nt)) - "\\|%\\(?1:[^\\\\/]*\\)%") + "\\|%\\(?1:[^\\/]*\\)%") (when comint-file-name-quote-list "\\|\\\\\\(.\\)"))) (qupos nil) @@ -619,7 +619,12 @@ buffer." ;; Bypass a bug in certain versions of bash. (when (string-equal shell "bash") (add-hook 'comint-preoutput-filter-functions - #'shell-filter-ctrl-a-ctrl-b nil t))) + #'shell-filter-ctrl-a-ctrl-b nil t)) + + ;; Skip extended history for zsh. + (when (string-equal shell "zsh") + (setq-local comint-input-ring-file-prefix + ": [[:digit:]]+:[[:digit:]]+;"))) (comint-read-input-ring t))) (defun shell-apply-ansi-color (beg end face) diff --git a/lisp/simple.el b/lisp/simple.el index e4958de113e..6f72c3b81b9 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -199,7 +199,7 @@ rejected, and the function returns nil." (and extra-test-inclusive (funcall extra-test-inclusive)))))) -(defcustom next-error-find-buffer-function #'next-error-buffer-unnavigated-current +(defcustom next-error-find-buffer-function #'ignore "Function called to find a `next-error' capable buffer. This functions takes the same three arguments as the function `next-error-find-buffer', and should return the buffer to be @@ -215,7 +215,7 @@ all other buffers." next-error-buffer-unnavigated-current) (function :tag "Other function")) :group 'next-error - :version "27.1") + :version "28.1") (defcustom next-error-found-function #'ignore "Function called when a next locus is found and displayed. @@ -1227,6 +1227,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 @@ -1271,7 +1275,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 @@ -1361,28 +1366,47 @@ END, without printing any message." (message "line %d (narrowed line %d)" (+ n (line-number-at-pos start) -1) n)))))) -(defun count-lines (start end) +(defun count-lines (start end &optional ignore-invisible-lines) "Return number of lines between START and END. -This is usually the number of newlines between them, -but can be one more if START is not equal to END -and the greater of them is not at the start of a line." +This is usually the number of newlines between them, but can be +one more if START is not equal to END and the greater of them is +not at the start of a line. + +When IGNORE-INVISIBLE-LINES is non-nil, invisible lines are not +included in the count." (save-excursion (save-restriction (narrow-to-region start end) (goto-char (point-min)) - (if (eq selective-display t) - (save-match-data - (let ((done 0)) - (while (re-search-forward "[\n\C-m]" nil t 40) - (setq done (+ 40 done))) - (while (re-search-forward "[\n\C-m]" nil t 1) - (setq done (+ 1 done))) - (goto-char (point-max)) - (if (and (/= start end) - (not (bolp))) - (1+ done) - done))) - (- (buffer-size) (forward-line (buffer-size))))))) + (cond ((and (not ignore-invisible-lines) + (eq selective-display t)) + (save-match-data + (let ((done 0)) + (while (re-search-forward "\n\\|\r[^\n]" nil t 40) + (setq done (+ 40 done))) + (while (re-search-forward "\n\\|\r[^\n]" nil t 1) + (setq done (+ 1 done))) + (goto-char (point-max)) + (if (and (/= start end) + (not (bolp))) + (1+ done) + done)))) + (ignore-invisible-lines + (save-match-data + (- (buffer-size) + (forward-line (buffer-size)) + (let ((invisible-count 0) + prop) + (goto-char (point-min)) + (while (re-search-forward "\n\\|\r[^\n]" nil t) + (setq prop (get-char-property (1- (point)) 'invisible)) + (if (if (eq buffer-invisibility-spec t) + prop + (or (memq prop buffer-invisibility-spec) + (assq prop buffer-invisibility-spec))) + (setq invisible-count (1+ invisible-count)))) + invisible-count)))) + (t (- (buffer-size) (forward-line (buffer-size)))))))) (defun line-number-at-pos (&optional pos absolute) "Return buffer line number at position POS. @@ -1614,18 +1638,66 @@ display the result of expression evaluation." "Hook run by `eval-expression' when entering the minibuffer.") (defun read--expression (prompt &optional initial-contents) + "Read an Emacs Lisp expression from the minibuffer. + +PROMPT and optional argument INITIAL-CONTENTS do the same as in +function `read-from-minibuffer'." (let ((minibuffer-completing-symbol t)) (minibuffer-with-setup-hook (lambda () - ;; FIXME: call emacs-lisp-mode (see also - ;; `eldoc--eval-expression-setup')? + ;; FIXME: instead of just applying the syntax table, maybe + ;; use a special major mode tailored to reading Lisp + ;; expressions from the minibuffer? (`emacs-lisp-mode' + ;; doesn't preserve the necessary keybindings.) + (set-syntax-table emacs-lisp-mode-syntax-table) (add-hook 'completion-at-point-functions #'elisp-completion-at-point nil t) + (local-set-key "\r" 'read--expression-try-read) + (local-set-key "\n" 'read--expression-try-read) (run-hooks 'eval-expression-minibuffer-setup-hook)) (read-from-minibuffer prompt initial-contents read-expression-map t 'read-expression-history)))) +(defun read--expression-try-read () + "Try to read an Emacs Lisp expression in the minibuffer. + +Exit the minibuffer if successful, else report the error to the +user and move point to the location of the error. If point is +not already at the location of the error, push a mark before +moving point." + (interactive) + (unless (> (minibuffer-depth) 0) + (error "Minibuffer must be active")) + (if (let* ((contents (minibuffer-contents)) + (error-point nil)) + (with-temp-buffer + (condition-case err + (progn + (insert contents) + (goto-char (point-min)) + ;; `read' will signal errors like "End of file during + ;; parsing" and "Invalid read syntax". + (read (current-buffer)) + ;; Since `read' does not signal the "Trailing garbage + ;; following expression" error, we check for trailing + ;; garbage ourselves. + (or (progn + ;; This check is similar to what `string_to_object' + ;; does in minibuf.c. + (skip-chars-forward " \t\n") + (= (point) (point-max))) + (error "Trailing garbage following expression"))) + (error + (setq error-point (+ (length (minibuffer-prompt)) (point))) + (with-current-buffer (window-buffer (minibuffer-window)) + (unless (= (point) error-point) + (push-mark)) + (goto-char error-point) + (minibuffer-message (error-message-string err))) + nil)))) + (exit-minibuffer))) + (defun eval-expression-get-print-arguments (prefix-argument) "Get arguments for commands that print an expression result. Returns a list (INSERT-VALUE NO-TRUNCATE CHAR-PRINT-LIMIT) @@ -1797,23 +1869,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) @@ -2528,6 +2613,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. @@ -2563,12 +2653,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))) @@ -2658,6 +2743,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.") @@ -3329,6 +3433,14 @@ which is defined in the `warnings' library.\n") (setq buffer-undo-list nil) t)) +;;;; Shell commands + +(defconst shell-command-buffer-name "*Shell Command Output*" + "Name of the output buffer for shell commands.") + +(defconst shell-command-buffer-name-async "*Async Shell Command*" + "Name of the output buffer for asynchronous shell commands.") + (defvar shell-command-history nil "History list for some commands that read shell commands. @@ -3393,8 +3505,9 @@ to `shell-command-history'." (defcustom async-shell-command-buffer 'confirm-new-buffer "What to do when the output buffer is used by another shell command. This option specifies how to resolve the conflict where a new command -wants to direct its output to the buffer `*Async Shell Command*', -but this buffer is already taken by another running shell command. +wants to direct its output to the buffer whose name is stored +in `shell-command-buffer-name-async', but that buffer is already +taken by another running shell command. The value `confirm-kill-process' is used to ask for confirmation before killing the already running process and running a new process @@ -3545,14 +3658,18 @@ whose `car' is BUFFER." Like `shell-command', but adds `&' at the end of COMMAND to execute it asynchronously. -The output appears in the buffer `*Async Shell Command*'. -That buffer is in shell mode. +The output appears in the buffer whose name is stored in the +variable `shell-command-buffer-name-async'. That buffer is in +shell mode. You can configure `async-shell-command-buffer' to specify what to do -when the `*Async Shell Command*' buffer is already taken by another -running shell command. To run COMMAND without displaying the output -in a window you can configure `display-buffer-alist' to use the action -`display-buffer-no-window' for the buffer `*Async Shell Command*'. +when the buffer specified by `shell-command-buffer-name-async' is +already taken by another running shell command. + +To run COMMAND without displaying the output in a window you can +configure `display-buffer-alist' to use the action +`display-buffer-no-window' for the buffer given by +`shell-command-buffer-name-async'. In Elisp, you will often be better served by calling `start-process' directly, since it offers more control and does not impose the use of @@ -3588,16 +3705,18 @@ If `shell-command-prompt-show-cwd' is non-nil, show the current directory in the prompt. If COMMAND ends in `&', execute it asynchronously. -The output appears in the buffer `*Async Shell Command*'. -That buffer is in shell mode. You can also use -`async-shell-command' that automatically adds `&'. +The output appears in the buffer whose name is specified +by `shell-command-buffer-name-async'. That buffer is in shell +mode. You can also use `async-shell-command' that automatically +adds `&'. Otherwise, COMMAND is executed synchronously. The output appears in -the buffer `*Shell Command Output*'. If the output is short enough to -display in the echo area (which is determined by the variables -`resize-mini-windows' and `max-mini-window-height'), it is shown -there, but it is nonetheless available in buffer `*Shell Command -Output*' even though that buffer is not automatically displayed. +the buffer named by `shell-command-buffer-name'. If the output is +short enough to display in the echo area (which is determined by the +variables `resize-mini-windows' and `max-mini-window-height'), it is +shown there, but it is nonetheless available in buffer named by +`shell-command-buffer-name' even though that buffer is not +automatically displayed. To specify a coding system for converting non-ASCII characters in the shell command output, use \\[universal-coding-system-argument] \ @@ -3716,7 +3835,7 @@ impose the use of a shell (with its need to quote arguments)." (if (string-match "[ \t]*&[ \t]*\\'" command) ;; Command ending with ampersand means asynchronous. (let* ((buffer (get-buffer-create - (or output-buffer "*Async Shell Command*"))) + (or output-buffer shell-command-buffer-name-async))) (bname (buffer-name buffer)) (proc (get-buffer-process buffer)) (directory default-directory)) @@ -3868,9 +3987,9 @@ and are used only if a pop-up buffer is displayed." error-buffer display-error-buffer region-noncontiguous-p) "Execute string COMMAND in inferior shell with region as input. -Normally display output (if any) in temp buffer `*Shell Command Output*'; -Prefix arg means replace the region with it. Return the exit code of -COMMAND. +Normally display output (if any) in temp buffer specified +by `shell-command-buffer-name'; prefix arg means replace the region +with it. Return the exit code of COMMAND. To specify a coding system for converting non-ASCII characters in the input and output to the shell command, use \\[universal-coding-system-argument] @@ -3887,7 +4006,7 @@ in the echo area or in a buffer. If the output is short enough to display in the echo area \(determined by the variable `max-mini-window-height' if `resize-mini-windows' is non-nil), it is shown there. -Otherwise it is displayed in the buffer `*Shell Command Output*'. +Otherwise it is displayed in the buffer named by `shell-command-buffer-name'. The output is available in that buffer in both cases. If there is output and an error, a message about the error @@ -3897,7 +4016,7 @@ Optional fourth arg OUTPUT-BUFFER specifies where to put the command's output. If the value is a buffer or buffer name, erase that buffer and insert the output there; a non-nil value of `shell-command-dont-erase-buffer' prevent to erase the buffer. -If the value is nil, use the buffer `*Shell Command Output*'. +If the value is nil, use the buffer specified by `shell-command-buffer-name'. Any other non-nil value means to insert the output in the current buffer after START. @@ -3945,7 +4064,7 @@ characters." exit-status) ;; Unless a single contiguous chunk is selected, operate on multiple chunks. (if region-noncontiguous-p - (let ((input (concat (funcall region-extract-function 'delete) "\n")) + (let ((input (concat (funcall region-extract-function (when replace 'delete)) "\n")) output) (with-temp-buffer (insert input) @@ -3953,9 +4072,24 @@ characters." shell-file-name t t nil shell-command-switch command) - (setq output (split-string (buffer-string) "\n"))) - (goto-char start) - (funcall region-insert-function output)) + (setq output (split-string (buffer-substring + (point-min) + ;; Trim the trailing newline. + (if (eq (char-before (point-max)) ?\n) + (1- (point-max)) + (point-max))) + "\n"))) + (cond + (replace + (goto-char start) + (funcall region-insert-function output)) + (t + (let ((buffer (get-buffer-create + (or output-buffer shell-command-buffer-name)))) + (with-current-buffer buffer + (erase-buffer) + (funcall region-insert-function output)) + (display-message-or-buffer buffer))))) (if (or replace (and output-buffer (not (or (bufferp output-buffer) (stringp output-buffer))))) @@ -3970,7 +4104,7 @@ characters." (list t error-file) t))) ;; It is rude to delete a buffer that the command is not using. - ;; (let ((shell-buffer (get-buffer "*Shell Command Output*"))) + ;; (let ((shell-buffer (get-buffer shell-command-buffer-name))) ;; (and shell-buffer (not (eq shell-buffer (current-buffer))) ;; (kill-buffer shell-buffer))) ;; Don't muck with mark unless REPLACE says we should. @@ -3978,12 +4112,13 @@ characters." ;; No prefix argument: put the output in a temp buffer, ;; replacing its entire contents. (let ((buffer (get-buffer-create - (or output-buffer "*Shell Command Output*")))) + (or output-buffer shell-command-buffer-name)))) (set-buffer-major-mode buffer) ; Enable globalized modes (bug#38111) (unwind-protect (if (and (eq buffer (current-buffer)) (or (memq shell-command-dont-erase-buffer '(nil erase)) - (and (not (eq buffer (get-buffer "*Shell Command Output*"))) + (and (not (eq buffer (get-buffer + shell-command-buffer-name))) (not (region-active-p))))) ;; If the input is the same buffer as the output, ;; delete everything but the specified region, @@ -4118,6 +4253,20 @@ its behavior with respect to remote file attribute caching. You should only ever change this variable with a let-binding; never with `setq'.") +(defcustom process-file-return-signal-string nil + "Whether to return a string describing the signal interrupting a process. +When a process returns an exit code greater than 128, it is +interpreted as a signal. `process-file' requires to return a +string describing this signal. +Since there are processes violating this rule, returning exit +codes greater than 128 which are not bound to a signal, +`process-file' returns the exit code as natural number also in +this case. Setting this user option to non-nil forces +`process-file' to interpret such exit codes as signals, and to +return a corresponding string." + :version "28.1" + :type 'boolean) + (defun start-file-process (name buffer program &rest program-args) "Start a program in a subprocess. Return the process object for it. diff --git a/lisp/skeleton.el b/lisp/skeleton.el index 8c694c128b5..ea4e5dbc227 100644 --- a/lisp/skeleton.el +++ b/lisp/skeleton.el @@ -1,4 +1,4 @@ -;;; skeleton.el --- Lisp language extension for writing statement skeletons +;;; skeleton.el --- Lisp language extension for writing statement skeletons -*- lexical-binding: t; -*- ;; Copyright (C) 1993-1996, 2001-2020 Free Software Foundation, Inc. @@ -135,7 +135,8 @@ A prefix argument of -1 says to wrap around region, even if not highlighted. A prefix argument of zero says to wrap around zero words---that is, nothing. This is a way of overriding the use of a highlighted region.") (interactive "*P\nP") - (skeleton-proxy-new ',skeleton str arg)))) + (atomic-change-group + (skeleton-proxy-new ',skeleton str arg))))) ;;;###autoload (defun skeleton-proxy-new (skeleton &optional str arg) @@ -154,8 +155,7 @@ of `str' whereas the skeleton's interactor is then ignored." (prefix-numeric-value (or arg current-prefix-arg)) (and skeleton-autowrap - (or (eq last-command 'mouse-drag-region) - (and transient-mark-mode mark-active)) + (use-region-p) ;; Deactivate the mark, in case one of the ;; elements of the skeleton is sensitive ;; to such situations (e.g. it is itself a @@ -258,23 +258,25 @@ available: (goto-char (car skeleton-regions)) (setq skeleton-regions (cdr skeleton-regions))) (let ((beg (point)) - skeleton-modified skeleton-point resume: help input v1 v2) - (setq skeleton-positions nil) - (unwind-protect - (cl-progv - (mapcar #'car skeleton-further-elements) - (mapcar (lambda (x) (eval (cadr x))) skeleton-further-elements) - (skeleton-internal-list skeleton str)) - (or (eolp) (not skeleton-end-newline) (newline-and-indent)) - (run-hooks 'skeleton-end-hook) - (sit-for 0) - (or (not (eq (window-buffer) (current-buffer))) - (pos-visible-in-window-p beg) - (progn - (goto-char beg) - (recenter 0))) - (if skeleton-point - (goto-char skeleton-point)))))) + skeleton-modified skeleton-point) ;; resume: + (with-suppressed-warnings ((lexical help input v1 v2)) + (dlet (help input v1 v2) + (setq skeleton-positions nil) + (unwind-protect + (cl-progv + (mapcar #'car skeleton-further-elements) + (mapcar (lambda (x) (eval (cadr x) t)) skeleton-further-elements) + (skeleton-internal-list skeleton str)) + (or (eolp) (not skeleton-end-newline) (newline-and-indent)) + (run-hooks 'skeleton-end-hook) + (sit-for 0) + (or (not (eq (window-buffer) (current-buffer))) + (pos-visible-in-window-p beg) + (progn + (goto-char beg) + (recenter 0))) + (if skeleton-point + (goto-char skeleton-point)))))))) (defun skeleton-read (prompt &optional initial-input recursive) "Function for reading a string from the minibuffer within skeletons. @@ -327,36 +329,39 @@ automatically, and you are prompted to fill in the variable parts."))) (signal 'quit t) prompt)) -(defun skeleton-internal-list (skeleton-il &optional str recursive) +(defun skeleton-internal-list (skeleton &optional str recursive) (let* ((start (line-beginning-position)) (column (current-column)) (line (buffer-substring start (line-end-position))) - opoint) - (or str - (setq str `(setq str - (skeleton-read ',(car skeleton-il) nil ,recursive)))) - (when (and (eq (cadr skeleton-il) '\n) (not recursive) - (save-excursion (skip-chars-backward " \t") (bolp))) - (setq skeleton-il (cons nil (cons '> (cddr skeleton-il))))) - (while (setq skeleton-modified (eq opoint (point)) - opoint (point) - skeleton-il (cdr skeleton-il)) - (condition-case quit - (skeleton-internal-1 (car skeleton-il) nil recursive) - (quit - (if (eq (cdr quit) 'recursive) - (setq recursive 'quit - skeleton-il (memq 'resume: skeleton-il)) - ;; Remove the subskeleton as far as it has been shown - ;; the subskeleton shouldn't have deleted outside current line. - (end-of-line) - (delete-region start (point)) - (insert line) - (move-to-column column) - (if (cdr quit) - (setq skeleton-il () - recursive nil) - (signal 'quit 'recursive))))))) + (skeleton-il skeleton) + opoint) + (with-suppressed-warnings ((lexical str)) + (dlet ((str (or str + `(setq str + (skeleton-read ',(car skeleton-il) + nil ,recursive))))) + (when (and (eq (cadr skeleton-il) '\n) (not recursive) + (save-excursion (skip-chars-backward " \t") (bolp))) + (setq skeleton-il (cons nil (cons '> (cddr skeleton-il))))) + (while (setq skeleton-modified (eq opoint (point)) + opoint (point) + skeleton-il (cdr skeleton-il)) + (condition-case quit + (skeleton-internal-1 (car skeleton-il) nil recursive) + (quit + (if (eq (cdr quit) 'recursive) + (setq recursive 'quit + skeleton-il (memq 'resume: skeleton-il)) + ;; Remove the subskeleton as far as it has been shown + ;; the subskeleton shouldn't have deleted outside current line. + (end-of-line) + (delete-region start (point)) + (insert line) + (move-to-column column) + (if (cdr quit) + (setq skeleton-il () + recursive nil) + (signal 'quit 'recursive))))))))) ;; maybe continue loop or go on to next outer resume: section (if (eq recursive 'quit) (signal 'quit 'recursive) diff --git a/lisp/so-long.el b/lisp/so-long.el index c800c7a1430..f8a5cc920d9 100644 --- a/lisp/so-long.el +++ b/lisp/so-long.el @@ -389,7 +389,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. @@ -1001,8 +1001,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..e9c15b71ce6 100644 --- a/lisp/speedbar.el +++ b/lisp/speedbar.el @@ -7,10 +7,12 @@ (defvar speedbar-version "1.0" "The current version of speedbar.") +(make-obsolete-variable 'speedbar-version nil "28.1") (defvar speedbar-incompatible-version "0.14beta4" "This version of speedbar is incompatible with this version. Due to massive API changes (removing the use of the word PATH) this version is not backward compatible to 0.14 or earlier.") +(make-obsolete-variable 'speedbar-incompatible-version nil "28.1") ;; This file is part of GNU Emacs. @@ -115,7 +117,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 +143,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 +304,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 +651,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 +664,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. @@ -1069,7 +1079,7 @@ in the selected file. (setq font-lock-keywords nil) ;; no font-locking please (setq truncate-lines t) (make-local-variable 'frame-title-format) - (setq frame-title-format (concat "Speedbar " speedbar-version) + (setq frame-title-format "Speedbar" case-fold-search nil buffer-read-only t) (speedbar-set-mode-line-format) @@ -1703,7 +1713,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 +4032,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..08a381801d7 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 @@ -1373,9 +1375,7 @@ If STROKES-MAP is not given, `strokes-global-map' will be used instead." (defun strokes-alphabetic-lessp (stroke1 stroke2) "Return t if STROKE1's command name precedes STROKE2's in lexicographic order." - (let ((command-name-1 (symbol-name (cdr stroke1))) - (command-name-2 (symbol-name (cdr stroke2)))) - (string-lessp command-name-1 command-name-2))) + (string-lessp (cdr stroke1) (cdr stroke2))) (defvar strokes-mode-map (let ((map (make-sparse-keymap))) diff --git a/lisp/subr.el b/lisp/subr.el index 2b3231b879b..6bd06a0b82c 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -257,10 +257,9 @@ Then evaluate RESULT to get return value, default nil. ;; use dolist. ;; FIXME: This cost disappears in byte-compiled lexical-binding files. (let ((temp '--dolist-tail--)) - ;; This is not a reliable test, but it does not matter because both - ;; semantics are acceptable, tho one is slightly faster with dynamic - ;; scoping and the other is slightly faster (and has cleaner semantics) - ;; with lexical scoping. + ;; This test does not matter much because both semantics are acceptable, + ;; but one is slightly faster with dynamic scoping and the other is + ;; slightly faster (and has cleaner semantics) with lexical scoping. (if lexical-binding `(let ((,temp ,(nth 1 spec))) (while ,temp @@ -292,9 +291,9 @@ the return value (nil if RESULT is omitted). Its use is deprecated. (let ((temp '--dotimes-limit--) (start 0) (end (nth 1 spec))) - ;; This is not a reliable test, but it does not matter because both - ;; semantics are acceptable, tho one is slightly faster with dynamic - ;; scoping and the other has cleaner semantics. + ;; This test does not matter much because both semantics are acceptable, + ;; but one is slightly faster with dynamic scoping and the other has + ;; cleaner semantics. (if lexical-binding (let ((counter '--dotimes-counter--)) `(let ((,temp ,end) @@ -884,6 +883,10 @@ side-effects, and the argument LIST is not modified." ;;;; Keymap support. +;; Declare before first use of `save-match-data', +;; where it is used internally. +(defvar save-match-data-internal) + (defun kbd (keys) "Convert KEYS to the internal Emacs key representation. KEYS should be a string in the format returned by commands such @@ -894,8 +897,9 @@ This is the same format used for saving keyboard macros (see For an approximate inverse of this, see `key-description'." ;; Don't use a defalias, since the `pure' property is true only for ;; the calling convention of `kbd'. - (read-kbd-macro keys)) -(put 'kbd 'pure t) + (declare (pure t)) + ;; A pure function is expected to preserve the match data. + (save-match-data (read-kbd-macro keys))) (defun undefined () "Beep to tell the user this binding is undefined." @@ -1558,7 +1562,6 @@ be a list of the form returned by `event-start' and `event-end'." ;;;; Obsolescent names for functions. -(make-obsolete 'forward-point "use (+ (point) N) instead." "23.1") (make-obsolete 'buffer-has-markers-at nil "24.3") (make-obsolete 'invocation-directory "use the variable of the same name." @@ -1580,6 +1583,11 @@ be a list of the form returned by `event-start' and `event-end'." (make-obsolete 'string-as-multibyte "use `decode-coding-string'." "26.1") (make-obsolete 'string-make-multibyte "use `decode-coding-string'." "26.1") +(defun forward-point (n) + "Return buffer position N characters after (before if N negative) point." + (declare (obsolete "use (+ (point) N) instead." "23.1")) + (+ (point) n)) + (defun log10 (x) "Return (log X 10), the log base 10 of X." (declare (obsolete log "24.4")) @@ -1621,6 +1629,9 @@ be a list of the form returned by `event-start' and `event-end'." (defvaralias 'messages-buffer-max-lines 'message-log-max) (define-obsolete-variable-alias 'inhibit-null-byte-detection 'inhibit-nul-byte-detection "27.1") +(make-obsolete-variable 'load-dangerous-libraries + "no longer used." "27.1") + ;;;; Alternate names for functions - these are not being phased out. @@ -1774,6 +1785,21 @@ all symbols are bound before any of the VALUEFORMs are evalled." ,@(mapcar (lambda (binder) `(setq ,@binder)) binders) ,@body)) +(defmacro dlet (binders &rest body) + "Like `let*' but using dynamic scoping." + (declare (indent 1) (debug let)) + ;; (defvar FOO) only affects the current scope, but in order for + ;; this not to affect code after the `let*' we need to create a new scope, + ;; which is what the surrounding `let' is for. + ;; FIXME: (let () ...) currently doesn't actually create a new scope, + ;; which is why we use (let (_) ...). + `(let (_) + ,@(mapcar (lambda (binder) + `(defvar ,(if (consp binder) (car binder) binder))) + binders) + (let* ,binders ,@body))) + + (defmacro with-wrapper-hook (hook args &rest body) "Run BODY, using wrapper functions from HOOK with additional ARGS. HOOK is an abnormal hook. Each hook function in HOOK \"wraps\" @@ -2263,6 +2289,8 @@ Otherwise TYPE is assumed to be a symbol property." (not (eq 'require (car match))))))) (throw 'found file)))))) +(declare-function read-library-name "find-func" nil) + (defun locate-library (library &optional nosuffix path interactive-call) "Show the precise file name of Emacs library LIBRARY. LIBRARY should be a relative file name of the library, a string. @@ -2279,12 +2307,7 @@ is used instead of `load-path'. When called from a program, the file name is normally returned as a string. When run interactively, the argument INTERACTIVE-CALL is t, and the file name is displayed in the echo area." - (interactive (list (completing-read "Locate library: " - (apply-partially - 'locate-file-completion-table - load-path (get-load-suffixes))) - nil nil - t)) + (interactive (list (read-library-name) nil nil t)) (let ((file (locate-file library (or path load-path) (append (unless nosuffix (get-load-suffixes)) @@ -2521,10 +2544,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 +2566,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)) @@ -3967,7 +3995,7 @@ the function `undo--wrap-and-run-primitive-undo'." (let (;; (inhibit-modification-hooks t) (before-change-functions ;; Ugly Hack: if the body uses syntax-ppss/syntax-propertize - ;; (e.g. via a regexp-search or sexp-movement trigerring + ;; (e.g. via a regexp-search or sexp-movement triggering ;; on-the-fly syntax-propertize), make sure that this gets ;; properly refreshed after subsequent changes. (if (memq #'syntax-ppss-flush-cache before-change-functions) @@ -4009,7 +4037,7 @@ the function `undo--wrap-and-run-primitive-undo'." (defmacro combine-change-calls (beg end &rest body) "Evaluate BODY, running the change hooks just once. -BODY is a sequence of lisp forms to evaluate. BEG and END bound +BODY is a sequence of Lisp forms to evaluate. BEG and END bound the region the change hooks will be run for. Firstly, `before-change-functions' is invoked for the region @@ -4027,7 +4055,8 @@ change `before-change-functions' or `after-change-functions'. Additionally, the buffer modifications of BODY are recorded on the buffer's undo list as a single \(apply ...) entry containing -the function `undo--wrap-and-run-primitive-undo'. " +the function `undo--wrap-and-run-primitive-undo'." + (declare (debug t) (indent 2)) `(combine-change-calls-1 ,beg ,end (lambda () ,@body))) (defun undo--wrap-and-run-primitive-undo (beg end list) @@ -4080,8 +4109,6 @@ MODES is as for `set-default-file-modes'." ;;; Matching and match data. -(defvar save-match-data-internal) - ;; We use save-match-data-internal as the local variable because ;; that works ok in practice (people should not use that variable elsewhere). ;; We used to use an uninterned symbol; the compiler handles that properly diff --git a/lisp/t-mouse.el b/lisp/t-mouse.el index fc174176cd6..a1af53d8c46 100644 --- a/lisp/t-mouse.el +++ b/lisp/t-mouse.el @@ -1,4 +1,4 @@ -;;; t-mouse.el --- mouse support within the text terminal +;;; t-mouse.el --- mouse support within the text terminal -*- lexical-binding:t -*- ;; Author: Nick Roberts <nickrob@gnu.org> ;; Maintainer: emacs-devel@gnu.org diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el index d97ca37a731..cee88cb4275 100644 --- a/lisp/tab-bar.el +++ b/lisp/tab-bar.el @@ -799,11 +799,14 @@ After the tab is created, the hooks in (run-hook-with-args 'tab-bar-tab-post-open-functions (nth to-index tabs))) - (when (and (not tab-bar-mode) - (or (eq tab-bar-show t) - (and (natnump tab-bar-show) - (> (length tabs) tab-bar-show)))) + (cond + (tab-bar-mode) + ((eq tab-bar-show t) (tab-bar-mode 1)) + ((and (natnump tab-bar-show) + (> (length (funcall tab-bar-tabs-function)) tab-bar-show) + (zerop (frame-parameter nil 'tab-bar-lines))) + (set-frame-parameter nil 'tab-bar-lines 1))) (force-mode-line-update) (unless tab-bar-mode @@ -936,10 +939,11 @@ for the last tab on a frame is determined by tab-bar-closed-tabs) (set-frame-parameter nil 'tabs (delq close-tab tabs))) - (when (and tab-bar-mode - (and (natnump tab-bar-show) - (<= (length tabs) tab-bar-show))) - (tab-bar-mode -1)) + (when (and (not (zerop (frame-parameter nil 'tab-bar-lines))) + (natnump tab-bar-show) + (<= (length (funcall tab-bar-tabs-function)) + tab-bar-show)) + (set-frame-parameter nil 'tab-bar-lines 0)) (force-mode-line-update) (unless tab-bar-mode @@ -975,10 +979,11 @@ for the last tab on a frame is determined by (run-hook-with-args 'tab-bar-tab-pre-close-functions (nth index tabs) nil))) (set-frame-parameter nil 'tabs (list (nth current-index tabs))) - (when (and tab-bar-mode - (and (natnump tab-bar-show) - (<= 1 tab-bar-show))) - (tab-bar-mode -1)) + (when (and (not (zerop (frame-parameter nil 'tab-bar-lines))) + (natnump tab-bar-show) + (<= (length (funcall tab-bar-tabs-function)) + tab-bar-show)) + (set-frame-parameter nil 'tab-bar-lines 0)) (force-mode-line-update) (unless tab-bar-mode @@ -1483,8 +1488,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 @@ -1496,17 +1500,46 @@ 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. @@ -1514,8 +1547,7 @@ 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 (window-normalize-buffer-to-switch-to buffer-or-name) - '((display-buffer-in-tab - display-buffer-same-window) + '((display-buffer-in-tab) (inhibit-same-window . nil)) norecord)) @@ -1534,6 +1566,25 @@ Like \\[find-file-other-frame] (which see), but creates a new tab." value) (switch-to-buffer-other-tab value)))) +(defun other-tab-prefix () + "Display the buffer of the next command in a new tab. +The next buffer is the buffer displayed by the next command invoked +immediately after this command (ignoring reading from the minibuffer). +Creates a new tab before displaying the buffer, or switches to the tab +that already contains that buffer. +When `switch-to-buffer-obey-display-actions' is non-nil, +`switch-to-buffer' commands are also supported." + (interactive) + (display-buffer-override-next-command + (lambda (buffer alist) + (cons (progn + (display-buffer-in-tab + buffer (append alist '((inhibit-same-window . nil)))) + (selected-window)) + 'tab)) + nil "[other-tab]") + (message "Display next command buffer in a new tab...")) + (define-key tab-prefix-map "2" 'tab-new) (define-key tab-prefix-map "1" 'tab-close-other) (define-key tab-prefix-map "0" 'tab-close) @@ -1544,6 +1595,7 @@ Like \\[find-file-other-frame] (which see), but creates a new tab." (define-key tab-prefix-map "b" 'switch-to-buffer-other-tab) (define-key tab-prefix-map "f" 'find-file-other-tab) (define-key tab-prefix-map "\C-f" 'find-file-other-tab) +(define-key tab-prefix-map "t" 'other-tab-prefix) (provide 'tab-bar) diff --git a/lisp/tar-mode.el b/lisp/tar-mode.el index 97d883eebd9..5cf09f9055e 100644 --- a/lisp/tar-mode.el +++ b/lisp/tar-mode.el @@ -480,23 +480,9 @@ checksum before doing the check." (defun tar-grind-file-mode (mode) "Construct a `rw-r--r--' string indicating MODE. -MODE should be an integer which is a file mode value." - (string - (if (zerop (logand 256 mode)) ?- ?r) - (if (zerop (logand 128 mode)) ?- ?w) - (if (zerop (logand 2048 mode)) - (if (zerop (logand 64 mode)) ?- ?x) - (if (zerop (logand 64 mode)) ?S ?s)) - (if (zerop (logand 32 mode)) ?- ?r) - (if (zerop (logand 16 mode)) ?- ?w) - (if (zerop (logand 1024 mode)) - (if (zerop (logand 8 mode)) ?- ?x) - (if (zerop (logand 8 mode)) ?S ?s)) - (if (zerop (logand 4 mode)) ?- ?r) - (if (zerop (logand 2 mode)) ?- ?w) - (if (zerop (logand 512 mode)) - (if (zerop (logand 1 mode)) ?- ?x) - (if (zerop (logand 1 mode)) ?T ?t)))) +MODE should be an integer which is a file mode value. +For instance, if mode is #o700, then it produces `rwx------'." + (substring (file-modes-number-to-symbolic mode) 1)) (defun tar-header-block-summarize (tar-hblock &optional mod-p) "Return a line similar to the output of `tar -vtf'." @@ -936,6 +922,56 @@ actually appear on disk when you save the tar-file's buffer." (setq buffer-undo-list nil)))) buffer)) +(defun tar-goto-file (file) + "Go to FILE in the current buffer. +FILE should be a relative file name. If FILE can't be found, +return nil. Otherwise point is returned." + (let ((start (point)) + found) + (goto-char (point-min)) + (while (and (not found) + (not (eobp))) + (forward-line 1) + (when-let ((descriptor (ignore-errors (tar-get-descriptor)))) + (when (equal (tar-header-name descriptor) file) + (setq found t)))) + (if (not found) + (progn + (goto-char start) + nil) + (point)))) + +(defun tar-next-file-displayer (file regexp n) + "Return a closure to display the next file after FILE that matches REGEXP." + (let ((short (replace-regexp-in-string "\\`.*!" "" file)) + next) + ;; The tar buffer chops off leading "./", so do the same + ;; here. + (setq short (replace-regexp-in-string "\\`\\./" "" file)) + (tar-goto-file short) + (while (and (not next) + ;; Stop if we reach the end/start of the buffer. + (if (> n 0) + (not (eobp)) + (not (save-excursion + (beginning-of-line) + (bobp))))) + (tar-next-line n) + (when-let ((descriptor (ignore-errors (tar-get-descriptor)))) + (let ((candidate (tar-header-name descriptor)) + (buffer (current-buffer))) + (when (and candidate + (string-match-p regexp candidate)) + (setq next (lambda () + (kill-buffer (current-buffer)) + (switch-to-buffer buffer) + (tar-extract))))))) + (unless next + ;; If we didn't find a next/prev file, then restore + ;; point. + (tar-goto-file short)) + next)) + (defun tar-extract (&optional other-window-p) "In Tar mode, extract this entry of the tar file into its own buffer." (interactive) @@ -1056,7 +1092,7 @@ extracted file." (write-region start end to-file nil nil nil t)) (when (and tar-copy-preserve-time date) - (set-file-times to-file date))) + (set-file-times to-file date 'nofollow))) (message "Copied tar entry %s to %s" name to-file))) (defun tar-new-entry (filename &optional index) diff --git a/lisp/tempo.el b/lisp/tempo.el index 9de5ac66c7d..bc398e7eb67 100644 --- a/lisp/tempo.el +++ b/lisp/tempo.el @@ -220,7 +220,9 @@ list of elements in the template, TAG is the tag used for completion, DOCUMENTATION is the documentation string for the insertion command created, and TAGLIST (a symbol) is the tag list that TAG (if provided) should be added to. If TAGLIST is nil and TAG is non-nil, TAG is -added to `tempo-tags'. +added to `tempo-tags'. If TAG already corresponds to a template in +the tag list, modify the list so that TAG now corresponds to the newly +defined template. The elements in ELEMENTS can be of several types: @@ -579,14 +581,20 @@ and insert the results." (defun tempo-add-tag (tag template &optional tag-list) "Add a template tag. Add the TAG, that should complete to TEMPLATE to the list in TAG-LIST, -or to `tempo-tags' if TAG-LIST is nil." +or to `tempo-tags' if TAG-LIST is nil. If TAG was already in the list, +replace its template with TEMPLATE." (interactive "sTag: \nCTemplate: ") (if (null tag-list) (setq tag-list 'tempo-tags)) - (if (not (assoc tag (symbol-value tag-list))) - (set tag-list (cons (cons tag template) (symbol-value tag-list)))) - (tempo-invalidate-collection)) + (let ((entry (assoc tag (symbol-value tag-list)))) + (if entry + ;; Tag is already in the list, assign a new template to it. + (setcdr entry template) + ;; Tag is not present in the list, add it with its template. + (set tag-list (cons (cons tag template) (symbol-value tag-list))))) + ;; Invalidate globally if we're modifying 'tempo-tags'. + (tempo-invalidate-collection (eq tag-list 'tempo-tags))) ;;; ;;; tempo-use-tag-list @@ -609,10 +617,17 @@ COMPLETION-FUNCTION just sets `tempo-match-finder' locally." ;;; ;;; tempo-invalidate-collection -(defun tempo-invalidate-collection () +(defun tempo-invalidate-collection (&optional global) "Marks the tag collection as obsolete. -Whenever it is needed again it will be rebuilt." - (setq tempo-dirty-collection t)) +Whenever it is needed again it will be rebuilt. If GLOBAL is non-nil, +mark the tag collection of all buffers as obsolete, not just the +current one." + (if global + (dolist (buffer (buffer-list)) + (with-current-buffer buffer + (when (assq 'tempo-dirty-collection (buffer-local-variables)) + (setq tempo-dirty-collection t)))) + (setq tempo-dirty-collection t))) ;;; ;;; tempo-build-collection diff --git a/lisp/term.el b/lisp/term.el index 09dfeb61d17..6f899fcb5c8 100644 --- a/lisp/term.el +++ b/lisp/term.el @@ -501,6 +501,13 @@ This variable is buffer-local." :type 'boolean :group 'term) +(defcustom term-scroll-snap-to-bottom t + "Control whether to keep the prompt at the bottom of the window. +If non-nil, when the prompt is visible within the window, then +scroll so that the prompt is on the bottom on any input or +output." + :type 'boolean) + (defcustom term-scroll-show-maximum-output nil "Controls how interpreter output causes window to scroll. If non-nil, then show the maximum output when the window is scrolled. @@ -2796,12 +2803,12 @@ See `term-prompt-regexp'." "\\(?:[\r\n\000\007\t\b\016\017]\\|" ;; some Emacs specific control sequences, implemented by ;; `term-command-hook', - "\032[^\n]+\r?\n\\|" + "\032[^\n]+\n\\|" ;; a C1 escape coded character (see [ECMA-48] section 5.3 "Elements ;; of the C1 set"), "\e\\(?:[DM78c]\\|" ;; another Emacs specific control sequence, - "AnSiT[^\n]+\r?\n\\|" + "AnSiT[^\n]+\n\\|" ;; or an escape sequence (section 5.4 "Control Sequences"), "\\[\\([\x30-\x3F]*\\)[\x20-\x2F]*[\x40-\x7E]\\)\\)") "Regexp matching control sequences handled by term.el.") @@ -3108,15 +3115,19 @@ See `term-prompt-regexp'." (or (eq scroll 'this) (not save-point))) (and (eq scroll 'others) (not (eq selected win)))) - (goto-char term-home-marker) - (recenter 0) + (when term-scroll-snap-to-bottom + (goto-char term-home-marker) + (recenter 0)) (goto-char (process-mark proc)) (if (not (pos-visible-in-window-p (point) win)) (recenter -1))) ;; Optionally scroll so that the text ;; ends at the bottom of the window. (when (and term-scroll-show-maximum-output - (>= (point) (process-mark proc))) + (>= (point) (process-mark proc)) + (or term-scroll-snap-to-bottom + (not (pos-visible-in-window-p + (point-max) win)))) (save-excursion (goto-char (point-max)) (recenter -1))))) diff --git a/lisp/term/bobcat.el b/lisp/term/bobcat.el index a32da6ae8f2..983c8cded2f 100644 --- a/lisp/term/bobcat.el +++ b/lisp/term/bobcat.el @@ -1,3 +1,4 @@ +;;; bobcat.el -*- lexical-binding:t -*- (defun terminal-init-bobcat () "Terminal initialization function for bobcat." diff --git a/lisp/term/cygwin.el b/lisp/term/cygwin.el index edc64b4404d..8f0d751cf29 100644 --- a/lisp/term/cygwin.el +++ b/lisp/term/cygwin.el @@ -1,4 +1,4 @@ -;;; cygwin.el --- support for the Cygwin terminal +;;; cygwin.el --- support for the Cygwin terminal -*- lexical-binding:t -*- ;;; The Cygwin terminal can't really display underlines. diff --git a/lisp/term/konsole.el b/lisp/term/konsole.el index 8b2e7e1d5f8..4af818b4a63 100644 --- a/lisp/term/konsole.el +++ b/lisp/term/konsole.el @@ -1,4 +1,4 @@ -;;; konsole.el --- terminal initialization for konsole +;;; konsole.el --- terminal initialization for konsole -*- lexical-binding:t -*- ;; Copyright (C) 2017-2020 Free Software Foundation, Inc. (require 'term/xterm) diff --git a/lisp/term/linux.el b/lisp/term/linux.el index 70730dc5844..35bd3ac0acb 100644 --- a/lisp/term/linux.el +++ b/lisp/term/linux.el @@ -1,4 +1,4 @@ -;; The Linux console handles Latin-1 by default. +;; The Linux console handles Latin-1 by default. -*- lexical-binding:t -*- (declare-function gpm-mouse-enable "t-mouse" ()) 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/term/rxvt.el b/lisp/term/rxvt.el index ca6c468f525..31e3d6ede4f 100644 --- a/lisp/term/rxvt.el +++ b/lisp/term/rxvt.el @@ -26,6 +26,16 @@ (require 'term/xterm) +(defgroup rxvt nil + "(U)RXVT support." + :version "28.1" + :group 'terminals) + +(defcustom rxvt-set-window-title nil + "Whether Emacs should set window titles to an Emacs frame in RXVT." + :version "28.1" + :type 'boolean) + (defvar rxvt-function-map (let ((map (make-sparse-keymap))) (set-keymap-parent map xterm-rxvt-function-map) @@ -171,7 +181,16 @@ (xterm-register-default-colors rxvt-standard-colors) (rxvt-set-background-mode) ;; This recomputes all the default faces given the colors we've just set up. - (tty-set-up-initial-frame-faces)) + (tty-set-up-initial-frame-faces) + + ;; Unconditionally enable bracketed paste mode: terminals that don't + ;; support it just ignore the sequence. + (xterm--init-bracketed-paste-mode) + + (when rxvt-set-window-title + (xterm--init-frame-title)) + + (run-hooks 'terminal-init-rxvt-hook)) ;; rxvt puts the default colors into an environment variable ;; COLORFGBG. We use this to set the background mode in a more diff --git a/lisp/term/st.el b/lisp/term/st.el new file mode 100644 index 00000000000..617664bb263 --- /dev/null +++ b/lisp/term/st.el @@ -0,0 +1,20 @@ +;;; st.el --- terminal initialization for st -*- lexical-binding:t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;;; Commentary: + +;; Support for the st terminal emulator. +;; https://st.suckless.org/ + +;;; Code: + +(require 'term/xterm) + +(defun terminal-init-st () + "Terminal initialization function for st." + (tty-run-terminal-initialization (selected-frame) "xterm")) + +(provide 'term/st) + +;; st.el ends here diff --git a/lisp/term/tty-colors.el b/lisp/term/tty-colors.el index 39ca2d36276..dda7fcc3691 100644 --- a/lisp/term/tty-colors.el +++ b/lisp/term/tty-colors.el @@ -923,62 +923,8 @@ The returned value reflects the standard Emacs definition of COLOR (see the info node `(emacs) Colors'), regardless of whether the terminal can display it, so the return value should be the same regardless of what display is being used." - (let ((len (length color))) - (cond ((and (>= len 4) ;; HTML/CSS/SVG-style "#XXYYZZ" color spec - (eq (aref color 0) ?#) - (member (aref color 1) - '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9 - ?a ?b ?c ?d ?e ?f - ?A ?B ?C ?D ?E ?F))) - ;; Translate the string "#XXYYZZ" into a list of numbers - ;; (XX YY ZZ), scaling each to the {0..65535} range. This - ;; follows the HTML color convention, where both "#fff" and - ;; "#ffffff" represent the same color, white. - (let* ((ndig (/ (- len 1) 3)) - (maxval (1- (ash 1 (* 4 ndig)))) - (i1 1) - (i2 (+ i1 ndig)) - (i3 (+ i2 ndig)) - (i4 (+ i3 ndig))) - (list - (/ (* (string-to-number - (substring color i1 i2) 16) - 65535) - maxval) - (/ (* (string-to-number - (substring color i2 i3) 16) - 65535) - maxval) - (/ (* (string-to-number - (substring color i3 i4) 16) - 65535) - maxval)))) - ((and (>= len 9) ;; X-style rgb:xx/yy/zz color spec - (string= (substring color 0 4) "rgb:")) - ;; Translate the string "rgb:XX/YY/ZZ" into a list of - ;; numbers (XX YY ZZ), scaling each to the {0..65535} - ;; range. "rgb:F/F/F" is white. - (let* ((ndig (/ (- len 3) 3)) - (maxval (1- (ash 1 (* 4 (- ndig 1))))) - (i1 4) - (i2 (+ i1 ndig)) - (i3 (+ i2 ndig)) - (i4 (+ i3 ndig))) - (list - (/ (* (string-to-number - (substring color i1 (- i2 1)) 16) - 65535) - maxval) - (/ (* (string-to-number - (substring color i2 (- i3 1)) 16) - 65535) - maxval) - (/ (* (string-to-number - (substring color i3 (1- i4)) 16) - 65535) - maxval)))) - (t - (cdr (assoc color color-name-rgb-alist)))))) + (or (color-values-from-color-spec color) + (cdr (assoc color color-name-rgb-alist)))) (defun tty-color-translate (color &optional frame) "Given a color COLOR, return the index of the corresponding TTY color. diff --git a/lisp/term/vt100.el b/lisp/term/vt100.el index 7ddbe38a287..2df14145231 100644 --- a/lisp/term/vt100.el +++ b/lisp/term/vt100.el @@ -1,4 +1,4 @@ -;;; vt100.el --- define VT100 function key sequences in function-key-map +;;; vt100.el --- define VT100 function key sequences in function-key-map -*- lexical-binding:t -*- ;; Copyright (C) 1989, 1993, 2001-2020 Free Software Foundation, Inc. diff --git a/lisp/term/vt200.el b/lisp/term/vt200.el index dde2e229068..569b79e25a1 100644 --- a/lisp/term/vt200.el +++ b/lisp/term/vt200.el @@ -1,3 +1,5 @@ +;;; vt200.el -*- lexical-binding:t -*- + ;; For our purposes we can treat the vt200 and vt100 almost alike. ;; Most differences are handled by the termcap entry. (defun terminal-init-vt200 () diff --git a/lisp/term/w32-win.el b/lisp/term/w32-win.el index 3e932c7593d..5901e0295e1 100644 --- a/lisp/term/w32-win.el +++ b/lisp/term/w32-win.el @@ -231,6 +231,8 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.") ;;; Set default known names for external libraries (setq dynamic-library-alist (list + '(gdiplus "gdiplus.dll") + '(shlwapi "shlwapi.dll") '(xpm "libxpm.dll" "xpm4.dll" "libXpm-nox4.dll") ;; Versions of libpng 1.4.x and later are incompatible with ;; earlier versions. Set up the list of libraries according to diff --git a/lisp/term/x-win.el b/lisp/term/x-win.el index 5b8feb14a5e..42a6f4030e5 100644 --- a/lisp/term/x-win.el +++ b/lisp/term/x-win.el @@ -1407,13 +1407,13 @@ This returns an error if any Emacs frames are X frames." ("etc/images/right-arrow" . ("go-next" "gtk-go-forward")) ("etc/images/home" . ("go-home" "gtk-home")) ("etc/images/jump-to" . ("go-jump" "gtk-jump-to")) - ("etc/images/index" . "gtk-index") + ("etc/images/index" . ("gtk-search" "gtk-index")) ("etc/images/exit" . ("application-exit" "gtk-quit")) ("etc/images/cancel" . "gtk-cancel") ("etc/images/info" . ("dialog-information" "gtk-info")) ("etc/images/bookmark_add" . "n:bookmark_add") ;; Used in Gnus and/or MH-E: - ("etc/images/attach" . "gtk-attach") + ("etc/images/attach" . ("mail-attachment" "gtk-attach")) ("etc/images/connect" . "gtk-connect") ("etc/images/contact" . "gtk-contact") ("etc/images/delete" . ("edit-delete" "gtk-delete")) @@ -1425,14 +1425,16 @@ This returns an error if any Emacs frames are X frames." ("etc/images/lock" . "gtk-lock") ("etc/images/next-page" . "gtk-next-page") ("etc/images/refresh" . ("view-refresh" "gtk-refresh")) + ("etc/images/search-replace" . "edit-find-replace") ("etc/images/sort-ascending" . ("view-sort-ascending" "gtk-sort-ascending")) ("etc/images/sort-column-ascending" . "gtk-sort-column-ascending") ("etc/images/sort-criteria" . "gtk-sort-criteria") ("etc/images/sort-descending" . ("view-sort-descending" "gtk-sort-descending")) ("etc/images/sort-row-ascending" . "gtk-sort-row-ascending") + ("etc/images/spell" . ("tools-check-spelling" "gtk-spell-check")) ("images/gnus/toggle-subscription" . "gtk-task-recurring") - ("images/mail/compose" . "gtk-mail-compose") + ("images/mail/compose" . ("mail-message-new" "gtk-mail-compose")) ("images/mail/copy" . "gtk-mail-copy") ("images/mail/forward" . "gtk-mail-forward") ("images/mail/inbox" . "gtk-inbox") @@ -1442,7 +1444,7 @@ This returns an error if any Emacs frames are X frames." ("images/mail/reply-all" . "gtk-mail-reply-to-all") ("images/mail/reply" . "gtk-mail-reply") ("images/mail/save-draft" . "gtk-mail-handling") - ("images/mail/send" . "gtk-mail-send") + ("images/mail/send" . ("mail-send" "gtk-mail-send")) ("images/mail/spam" . "gtk-spam") ;; Used for GDB Graphical Interface ("images/gud/break" . "gtk-no") diff --git a/lisp/textmodes/bibtex.el b/lisp/textmodes/bibtex.el index 670e763814c..0018b89d858 100644 --- a/lisp/textmodes/bibtex.el +++ b/lisp/textmodes/bibtex.el @@ -440,7 +440,7 @@ If parsing fails, try to set this variable to nil." "Alist of BibTeX entry types and their associated fields. Elements are lists (ENTRY-TYPE DOC REQUIRED CROSSREF OPTIONAL). ENTRY-TYPE is the type of a BibTeX entry. -DOC is a brief doc string used for menus. If nil ENTRY-TYPE is used. +DOC is a brief doc string used for menus. If nil ENTRY-TYPE is used. REQUIRED is a list of required fields. CROSSREF is a list of fields that are optional if a crossref field is present; but these fields are required otherwise. @@ -850,11 +850,11 @@ Predefined dialects include BibTeX and biblatex." To interactively change the dialect use the command `bibtex-set-dialect'." :group 'bibtex :version "24.1" - :set '(lambda (symbol value) - (set-default symbol value) - ;; `bibtex-set-dialect' is undefined during loading (no problem) - (if (fboundp 'bibtex-set-dialect) - (bibtex-set-dialect value))) + :set (lambda (symbol value) + (set-default symbol value) + ;; `bibtex-set-dialect' is undefined during loading (no problem). + (if (fboundp 'bibtex-set-dialect) + (bibtex-set-dialect value))) :type '(choice (const BibTeX) (const biblatex) (symbol :tag "Custom"))) @@ -1051,7 +1051,7 @@ See `bibtex-generate-autokey' for details." (defvaralias 'bibtex-autokey-name-case-convert 'bibtex-autokey-name-case-convert-function) -(defcustom bibtex-autokey-name-case-convert-function 'downcase +(defcustom bibtex-autokey-name-case-convert-function #'downcase "Function called for each name to perform case conversion. See `bibtex-generate-autokey' for details." :group 'bibtex-autokey @@ -1127,7 +1127,7 @@ Case is significant. See `bibtex-generate-autokey' for details." (defvaralias 'bibtex-autokey-titleword-case-convert 'bibtex-autokey-titleword-case-convert-function) -(defcustom bibtex-autokey-titleword-case-convert-function 'downcase +(defcustom bibtex-autokey-titleword-case-convert-function #'downcase "Function called for each titleword to perform case conversion. See `bibtex-generate-autokey' for details." :group 'bibtex-autokey @@ -1188,12 +1188,13 @@ See `bibtex-generate-autokey' for details." :group 'bibtex-autokey :type 'boolean) -(defcustom bibtex-autokey-before-presentation-function nil - "If non-nil, function to call before generated key is presented. +(defcustom bibtex-autokey-before-presentation-function #'identity + "Function to call before generated key is presented. The function must take one argument (the automatically generated key), and must return a string (the key to use)." :group 'bibtex-autokey - :type '(choice (const nil) function)) + :version "28.1" + :type 'function) (defcustom bibtex-entry-offset 0 "Offset for BibTeX entries. @@ -1242,7 +1243,7 @@ If non-nil, the column for the equal sign is the value of :group 'bibtex :type '(repeat string)) -(defcustom bibtex-summary-function 'bibtex-summary +(defcustom bibtex-summary-function #'bibtex-summary "Function to call for generating a summary of current BibTeX entry. It takes no arguments. Point must be at beginning of entry. Used by `bibtex-complete-crossref-cleanup' and `bibtex-copy-summary-as-kill'." @@ -1660,7 +1661,7 @@ Initialized by `bibtex-set-dialect'.") (defvar bibtex-font-lock-url-regexp ;; Assume that field names begin at the beginning of a line. (concat "^[ \t]*" - (regexp-opt (delete-dups (mapcar 'caar bibtex-generate-url-list)) t) + (regexp-opt (delete-dups (mapcar #'caar bibtex-generate-url-list)) t) "[ \t]*=[ \t]*") "Regexp for `bibtex-font-lock-url' derived from `bibtex-generate-url-list'.") @@ -1892,14 +1893,16 @@ If `bibtex-expand-strings' is non-nil, also expand BibTeX strings." (let ((mtch (match-string-no-properties 0))) (push (or (if bibtex-expand-strings (cdr (assoc-string mtch (bibtex-strings) t))) - mtch) content) + mtch) + content) (goto-char (match-end 0))) (let ((bounds (bibtex-parse-field-string))) (push (buffer-substring-no-properties - (1+ (car bounds)) (1- (cdr bounds))) content) + (1+ (car bounds)) (1- (cdr bounds))) + content) (goto-char (cdr bounds)))) (re-search-forward "\\=[ \t\n]*#[ \t\n]*" nil t)) - (apply 'concat (nreverse content)))) + (apply #'concat (nreverse content)))) (buffer-substring-no-properties (bibtex-start-of-text-in-field bounds) (bibtex-end-of-text-in-field bounds)))) @@ -2239,8 +2242,9 @@ Optional arg BEG is beginning of entry." Optional arg COMMA is as in `bibtex-enclosing-field'." (unless bibtex-last-kill-command (error "BibTeX kill ring is empty")) (let ((fun (lambda (kryp kr) ; adapted from `current-kill' - (car (set kryp (nthcdr (mod (- n (length (eval kryp))) - (length kr)) kr)))))) + (car (set kryp (nthcdr (mod (- n (length (symbol-value kryp))) + (length kr)) + kr)))))) ;; We put the mark at the beginning of the inserted field or entry ;; and point at its end - a behavior similar to what `yank' does. ;; The mark is then used by `bibtex-yank-pop', which needs to know @@ -2251,7 +2255,8 @@ Optional arg COMMA is as in `bibtex-enclosing-field'." (goto-char (bibtex-end-of-field (bibtex-enclosing-field comma))) (push-mark) (bibtex-make-field (funcall fun 'bibtex-field-kill-ring-yank-pointer - bibtex-field-kill-ring) t nil t)) + bibtex-field-kill-ring) + t nil t)) ;; insert past the current entry (bibtex-skip-to-valid-entry) (push-mark) @@ -2615,7 +2620,7 @@ Return optimized value to be used by `bibtex-format-entry'." regexp-alist)) (let (opt-list) ;; Loop over field names - (dolist (field (delete-dups (apply 'append (mapcar 'car regexp-alist)))) + (dolist (field (delete-dups (apply #'append (mapcar #'car regexp-alist)))) (let (rules) ;; Collect all matches we have for this field name (dolist (e regexp-alist) @@ -2623,7 +2628,7 @@ Return optimized value to be used by `bibtex-format-entry'." (push (cons (nth 1 e) (nth 2 e)) rules))) (if (eq type 'braces) ;; concatenate all regexps to a single regexp - (setq rules (concat "\\(?:" (mapconcat 'car rules "\\|") "\\)"))) + (setq rules (concat "\\(?:" (mapconcat #'car rules "\\|") "\\)"))) ;; create list of replacement rules. (push (cons field rules) opt-list))) opt-list)) @@ -2674,7 +2679,7 @@ and `bibtex-autokey-names-stretch'." (if (string= "" names) names (let* ((case-fold-search t) - (name-list (mapcar 'bibtex-autokey-demangle-name + (name-list (mapcar #'bibtex-autokey-demangle-name (split-string names "[ \t\n]+and[ \t\n]+"))) additional-names) (unless (or (not (numberp bibtex-autokey-names)) @@ -2686,7 +2691,7 @@ and `bibtex-autokey-names-stretch'." bibtex-autokey-names) (nreverse name-list))) additional-names bibtex-autokey-additional-names)) - (concat (mapconcat 'identity name-list + (concat (mapconcat #'identity name-list bibtex-autokey-name-separator) additional-names))))) @@ -2736,7 +2741,7 @@ Return the result as a string." ;; specific words and use only a specific amount of words. (let ((counter 0) (ignore-re (concat "\\`\\(?:" - (mapconcat 'identity + (mapconcat #'identity bibtex-autokey-titleword-ignore "\\|") "\\)\\'")) titlewords titlewords-extra word) @@ -2760,7 +2765,7 @@ Return the result as a string." ;; titlewords-extra in titlewords. Otherwise, we ignore titlewords-extra. (unless (string-match "\\b\\w+" titlestring) (setq titlewords (append titlewords-extra titlewords))) - (mapconcat 'bibtex-autokey-demangle-title (nreverse titlewords) + (mapconcat #'bibtex-autokey-demangle-title (nreverse titlewords) bibtex-autokey-titleword-separator)))) (defun bibtex-autokey-demangle-title (titleword) @@ -2837,7 +2842,7 @@ Concatenate the key: non-empty insert `bibtex-autokey-name-year-separator' between the two. If the title part and the year (or name) part are non-empty, insert `bibtex-autokey-year-title-separator' between the two. - 2. If `bibtex-autokey-before-presentation-function' is non-nil, it must be + 2. `bibtex-autokey-before-presentation-function' must be a function taking one argument. Call this function with the generated key as the argument. Use the return value of this function (a string) as the key. @@ -2865,7 +2870,7 @@ Concatenate the key: (defun bibtex-global-key-alist () "Return global key alist based on `bibtex-files'." (if bibtex-files - (apply 'append + (apply #'append (mapcar (lambda (buf) (with-current-buffer buf bibtex-reference-keys)) ;; include current buffer only if it uses `bibtex-mode' @@ -3129,7 +3134,7 @@ does not use `bibtex-mode'." (if buffer-list (switch-to-buffer (completing-read "Switch to BibTeX buffer: " - (mapcar 'buffer-name buffer-list) + (mapcar #'buffer-name buffer-list) nil t (if current (buffer-name (current-buffer))))) (message "No BibTeX buffers defined"))) @@ -3178,7 +3183,7 @@ that is generated by calling `bibtex-url'." Used as default value of `bibtex-summary-function'." ;; It would be neat to make this function customizable. How? (if (looking-at bibtex-entry-maybe-empty-head) - (let* ((bibtex-autokey-name-case-convert-function 'identity) + (let* ((bibtex-autokey-name-case-convert-function #'identity) (bibtex-autokey-name-length 'infty) (bibtex-autokey-names 1) (bibtex-autokey-names-stretch 0) @@ -3189,7 +3194,7 @@ Used as default value of `bibtex-summary-function'." (year (bibtex-autokey-get-year)) (bibtex-autokey-titlewords 5) (bibtex-autokey-titlewords-stretch 2) - (bibtex-autokey-titleword-case-convert-function 'identity) + (bibtex-autokey-titleword-case-convert-function #'identity) (bibtex-autokey-titleword-length 5) (bibtex-autokey-titleword-separator " ") (title (bibtex-autokey-get-title)) @@ -3336,12 +3341,12 @@ BOUND limits the search." (define-button-type 'bibtex-url 'action 'bibtex-button-action - 'bibtex-function 'bibtex-url + 'bibtex-function #'bibtex-url 'help-echo (purecopy "mouse-2, RET: follow URL")) (define-button-type 'bibtex-search-crossref 'action 'bibtex-button-action - 'bibtex-function 'bibtex-search-crossref + 'bibtex-function #'bibtex-search-crossref 'help-echo (purecopy "mouse-2, RET: follow crossref")) (defun bibtex-button (beg end type &rest args) @@ -3405,7 +3410,7 @@ if that value is non-nil. \\{bibtex-mode-map}" (add-hook 'completion-at-point-functions - 'bibtex-completion-at-point-function nil 'local) + #'bibtex-completion-at-point-function nil 'local) (make-local-variable 'bibtex-buffer-last-parsed-tick) ;; Install stealthy parse function if not already installed (unless bibtex-parse-idle-timer @@ -3419,7 +3424,7 @@ if that value is non-nil. (set (make-local-variable 'comment-column) 0) (set (make-local-variable 'defun-prompt-regexp) "^[ \t]*@[[:alnum:]]+[ \t]*") (set (make-local-variable 'outline-regexp) "[ \t]*@") - (set (make-local-variable 'fill-paragraph-function) 'bibtex-fill-field) + (set (make-local-variable 'fill-paragraph-function) #'bibtex-fill-field) (set (make-local-variable 'fill-prefix) (make-string (+ bibtex-entry-offset bibtex-contline-indentation) ?\s)) (set (make-local-variable 'font-lock-defaults) @@ -3441,7 +3446,7 @@ if that value is non-nil. (syntax-propertize-via-font-lock bibtex-font-lock-syntactic-keywords)) ;; Allow `bibtex-dialect' as a file-local variable. - (add-hook 'hack-local-variables-hook 'bibtex-set-dialect nil t)) + (add-hook 'hack-local-variables-hook #'bibtex-set-dialect nil t)) (defun bibtex-entry-alist (dialect) "Return entry-alist for DIALECT." @@ -3488,8 +3493,9 @@ are also bound buffer-locally if `bibtex-dialect' is already buffer-local in the current buffer (for example, as a file-local variable). LOCAL is t for interactive calls." (interactive (list (intern (completing-read "Dialect: " - (mapcar 'list bibtex-dialect-list) - nil t)) t)) + (mapcar #'list bibtex-dialect-list) + nil t)) + t)) (let ((setfun (if (or local (local-variable-p 'bibtex-dialect)) (lambda (var val) (set (make-local-variable var) val)) 'set))) @@ -3506,7 +3512,7 @@ LOCAL is t for interactive calls." bibtex-dialect)))) (funcall setfun 'bibtex-entry-type (concat "@[ \t]*\\(?:" - (regexp-opt (mapcar 'car bibtex-entry-alist)) "\\)")) + (regexp-opt (mapcar #'car bibtex-entry-alist)) "\\)")) (funcall setfun 'bibtex-entry-head (concat "^[ \t]*\\(" bibtex-entry-type "\\)[ \t]*[({][ \t\n]*\\(" bibtex-reference-key "\\)")) @@ -3516,7 +3522,7 @@ LOCAL is t for interactive calls." (concat "^[ \t]*@[ \t]*\\(?:" (regexp-opt (append '("String" "Preamble") - (mapcar 'car bibtex-entry-alist))) "\\)")) + (mapcar #'car bibtex-entry-alist))) "\\)")) (setq imenu-generic-expression (list (list nil bibtex-entry-head bibtex-key-in-head)) imenu-case-fold-search t))) @@ -3549,11 +3555,13 @@ LOCAL is t for interactive calls." (let* ((entry (car elt)) (fname (intern (format "bibtex-%s" entry)))) (unless (fboundp fname) - (eval (list 'defun fname nil - (format "Insert a template for a @%s entry; see also `bibtex-entry'." - entry) - '(interactive "*") - `(bibtex-entry ,entry)))) + (defalias fname + (lambda () + (:documentation + (format "Insert a template for a @%s entry; see also `bibtex-entry'." + entry)) + (interactive "*") + (bibtex-entry entry)))) ;; Menu entries (define-key menu-map (vector fname) `(menu-item ,(or (nth 1 elt) (car elt)) ,fname)))) @@ -3608,8 +3616,8 @@ is non-nil." (insert "@" entry-type (bibtex-entry-left-delimiter)) (if key (insert key)) (save-excursion - (mapc 'bibtex-make-field (car field-list)) - (mapc 'bibtex-make-optional-field (cdr field-list)) + (mapc #'bibtex-make-field (car field-list)) + (mapc #'bibtex-make-optional-field (cdr field-list)) (if bibtex-comma-after-last-field (insert ",")) (insert "\n") @@ -3657,8 +3665,8 @@ When called interactively with a prefix arg, query for a value of ENTRY-TYPE." (insert (bibtex-field-left-delimiter))) (goto-char end))) (skip-chars-backward " \t\n") - (mapc 'bibtex-make-field required) - (mapc 'bibtex-make-optional-field optional))))) + (mapc #'bibtex-make-field required) + (mapc #'bibtex-make-optional-field optional))))) (defun bibtex-parse-entry (&optional content keep-opt-alt) "Parse entry at point, return an alist. @@ -4980,7 +4988,8 @@ If mark is active reformat entries in region, if not in whole buffer." ("Remove empty optional and alternative fields? " . opts-or-alts) ("Remove delimiters around pure numerical fields? " . numerical-fields) (,(concat (if bibtex-comma-after-last-field "Insert" "Remove") - " comma at end of entry? ") . last-comma) + " comma at end of entry? ") + . last-comma) ("Replace double page dashes by single ones? " . page-dashes) ("Delete whitespace at the beginning and end of fields? " . whitespace) ("Inherit booktitle? " . inherit-booktitle) @@ -5047,7 +5056,7 @@ entries from minibuffer." (goto-char (point-max)) (message "Buffer is now parsable. Please save it."))) -(define-obsolete-function-alias 'bibtex-complete 'completion-at-point "24.1") +(define-obsolete-function-alias 'bibtex-complete #'completion-at-point "24.1") (defun bibtex-completion-at-point-function () (let ((pnt (point)) (case-fold-search t) @@ -5258,8 +5267,8 @@ Return the URL or nil if none can be generated." ;; If SCHEME is set up correctly, ;; we should never reach this point (error "Match failed: %s" text))) - (if fmt (apply 'format fmt (nreverse obj)) - (apply 'concat (nreverse obj))))) + (if fmt (apply #'format fmt (nreverse obj)) + (apply #'concat (nreverse obj))))) (if (called-interactively-p 'interactive) (message "%s" url)) (unless no-browse (browse-url url))) (if (and (not url) (called-interactively-p 'interactive)) @@ -5289,10 +5298,11 @@ where FILE is the BibTeX file of ENTRY." (list (completing-read "Field: " (delete-dups - (apply 'append + (apply #'append bibtex-user-optional-fields - (mapcar (lambda (x) (mapcar 'car (apply 'append (nthcdr 2 x)))) - bibtex-entry-alist))) nil t) + (mapcar (lambda (x) (mapcar #'car (apply #'append (nthcdr 2 x)))) + bibtex-entry-alist))) + nil t) (read-string "Regexp: ") (if bibtex-search-entry-globally (not current-prefix-arg) diff --git a/lisp/textmodes/conf-mode.el b/lisp/textmodes/conf-mode.el index 86db6980433..722fc0a3137 100644 --- a/lisp/textmodes/conf-mode.el +++ b/lisp/textmodes/conf-mode.el @@ -44,28 +44,23 @@ "Align assignments to this column by default with \\[conf-align-assignments]. If this number is negative, the `=' comes before the whitespace. Use 0 to not align (only setting space according to `conf-assignment-space')." - :type 'integer - :group 'conf) + :type 'integer) (defcustom conf-javaprop-assignment-column 32 "Value for `conf-assignment-column' in Java properties buffers." - :type 'integer - :group 'conf) + :type 'integer) (defcustom conf-colon-assignment-column (- (abs conf-assignment-column)) "Value for `conf-assignment-column' in Java properties buffers." - :type 'integer - :group 'conf) + :type 'integer) (defcustom conf-assignment-space t "Put at least one space around assignments when aligning." - :type 'boolean - :group 'conf) + :type 'boolean) (defcustom conf-colon-assignment-space nil "Value for `conf-assignment-space' in colon style Conf mode buffers." - :type 'boolean - :group 'conf) + :type 'boolean) (defvar conf-mode-map (let ((map (make-sparse-keymap)) @@ -349,9 +344,37 @@ unbalanced, but hey...)" (scan-error depth)))) +(defun conf--guess-mode () + "Try to guess sub-mode of `conf-mode' based on buffer content." + (let ((unix 0) (win 0) (equal 0) (colon 0) (space 0) (jp 0)) + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (skip-chars-forward " \t\f") + (cond ((eq (char-after) ?\#) (setq unix (1+ unix))) + ((eq (char-after) ?\;) (setq win (1+ win))) + ((eq (char-after) ?\[)) ; nop + ((eolp)) ; nop + ((eq (char-after) ?})) ; nop + ;; recognize at most double spaces within names + ((looking-at "[^ \t\n=:]+\\(?: ?[^ \t\n=:]+\\)*[ \t]*[=:]") + (if (eq (char-before (match-end 0)) ?=) + (setq equal (1+ equal)) + (setq colon (1+ colon)))) + ((looking-at "/[/*]") (setq jp (1+ jp))) + ((looking-at ".*{")) ; nop + ((setq space (1+ space)))) + (forward-line))) + (cond + ((> jp (max unix win 3)) #'conf-javaprop-mode) + ((> colon (max equal space)) #'conf-colon-mode) + ((> space (max equal colon)) #'conf-space-mode) + ((or (> win unix) (and (= win unix) (eq system-type 'windows-nt))) + #'conf-windows-mode) + (t #'conf-unix-mode)))) ;;;###autoload -(defun conf-mode () +(define-derived-mode conf-mode nil "Conf[?]" "Mode for Unix and Windows Conf files and Java properties. Most conf files know only three kinds of constructs: parameter assignments optionally grouped into sections and comments. Yet @@ -382,75 +405,41 @@ See also `conf-space-mode', `conf-colon-mode', `conf-javaprop-mode', \\{conf-mode-map}" - (interactive) - ;; `conf-mode' plays two roles: it's the parent of several sub-modes - ;; but it's also the function that chooses between those submodes. - ;; To tell the difference between those two cases where the function - ;; might be called, we check `delay-mode-hooks'. - ;; (adopted from tex-mode.el) - (if (not delay-mode-hooks) - ;; try to guess sub-mode of conf-mode based on buffer content - (let ((unix 0) (win 0) (equal 0) (colon 0) (space 0) (jp 0)) - (save-excursion - (goto-char (point-min)) - (while (not (eobp)) - (skip-chars-forward " \t\f") - (cond ((eq (char-after) ?\#) (setq unix (1+ unix))) - ((eq (char-after) ?\;) (setq win (1+ win))) - ((eq (char-after) ?\[)) ; nop - ((eolp)) ; nop - ((eq (char-after) ?})) ; nop - ;; recognize at most double spaces within names - ((looking-at "[^ \t\n=:]+\\(?: ?[^ \t\n=:]+\\)*[ \t]*[=:]") - (if (eq (char-before (match-end 0)) ?=) - (setq equal (1+ equal)) - (setq colon (1+ colon)))) - ((looking-at "/[/*]") (setq jp (1+ jp))) - ((looking-at ".*{")) ; nop - ((setq space (1+ space)))) - (forward-line))) - (cond - ((> jp (max unix win 3)) (conf-javaprop-mode)) - ((> colon (max equal space)) (conf-colon-mode)) - ((> space (max equal colon)) (conf-space-mode)) - ((or (> win unix) (and (= win unix) (eq system-type 'windows-nt))) - (conf-windows-mode)) - (t (conf-unix-mode)))) - - (kill-all-local-variables) - (use-local-map conf-mode-map) - (setq major-mode 'conf-mode - mode-name "Conf[?]") - (set (make-local-variable 'font-lock-defaults) - '(conf-font-lock-keywords nil t nil nil)) - ;; Let newcomment.el decide this for itself. - ;; (set (make-local-variable 'comment-use-syntax) t) - (set (make-local-variable 'parse-sexp-ignore-comments) t) - (set (make-local-variable 'outline-regexp) - "[ \t]*\\(?:\\[\\|.+[ \t\n]*{\\)") - (set (make-local-variable 'outline-heading-end-regexp) - "[\n}]") - (set (make-local-variable 'outline-level) - 'conf-outline-level) - (set-syntax-table conf-mode-syntax-table) - (setq imenu-generic-expression - '(("Parameters" "^[ \t]*\\(.+?\\)[ \t]*=" 1) - ;; [section] - (nil "^[ \t]*\\[[ \t]*\\(.+\\)[ \t]*\\]" 1) - ;; section { ... } - (nil "^[ \t]*\\([^=:{} \t\n][^=:{}\n]+\\)[ \t\n]*{" 1))) - (run-mode-hooks 'conf-mode-hook))) + (setq-local font-lock-defaults '(conf-font-lock-keywords nil t nil nil)) + ;; Let newcomment.el decide this for itself. + ;; (setq-local comment-use-syntax t) + (setq-local parse-sexp-ignore-comments t) + (setq-local outline-regexp "[ \t]*\\(?:\\[\\|.+[ \t\n]*{\\)") + (setq-local outline-heading-end-regexp "[\n}]") + (setq-local outline-level #'conf-outline-level) + (setq-local imenu-generic-expression + '(("Parameters" "^[ \t]*\\(.+?\\)[ \t]*=" 1) + ;; [section] + (nil "^[ \t]*\\[[ \t]*\\(.+\\)[ \t]*\\]" 1) + ;; section { ... } + (nil "^[ \t]*\\([^=:{} \t\n][^=:{}\n]+\\)[ \t\n]*{" 1)))) + +;; `conf-mode' plays two roles: it's the parent of several sub-modes +;; but it's also the function that chooses between those submodes. +;; To tell the difference between those two cases where the function +;; might be called, we check `delay-mode-hooks'. +;; (inspired from tex-mode.el) +(advice-add 'conf-mode :around + (lambda (orig-fun) + "Redirect to one of the submodes when called directly." + (funcall (if delay-mode-hooks orig-fun (conf--guess-mode))))) + + (defun conf-mode-initialize (comment &optional font-lock) "Initializations for sub-modes of `conf-mode'. COMMENT initializes `comment-start' and `comment-start-skip'. The optional arg FONT-LOCK is the value for FONT-LOCK-KEYWORDS." - (set (make-local-variable 'comment-start) comment) - (set (make-local-variable 'comment-start-skip) - (concat (regexp-quote comment-start) "+\\s *")) + (setq-local comment-start comment) + (setq-local comment-start-skip + (concat (regexp-quote comment-start) "+\\s *")) (if font-lock - (set (make-local-variable 'font-lock-defaults) - `(,font-lock nil t nil nil)))) + (setq-local font-lock-defaults `(,font-lock nil t nil nil)))) ;;;###autoload (define-derived-mode conf-unix-mode conf-mode "Conf[Unix]" @@ -497,13 +486,11 @@ x.1 = x.2.y.1.z.1 = x.2.y.1.z.2.zz =" (conf-mode-initialize "#" 'conf-javaprop-font-lock-keywords) - (set (make-local-variable 'conf-assignment-column) - conf-javaprop-assignment-column) - (set (make-local-variable 'conf-assignment-regexp) - ".+?\\([ \t]*[=: \t][ \t]*\\|$\\)") - (setq comment-start-skip "\\(?:#+\\|/[/*]+\\)\\s *") - (setq imenu-generic-expression - '(("Parameters" "^[ \t]*\\(.+?\\)[=: \t]" 1)))) + (setq-local conf-assignment-column conf-javaprop-assignment-column) + (setq-local conf-assignment-regexp ".+?\\([ \t]*[=: \t][ \t]*\\|$\\)") + (setq-local comment-start-skip "\\(?:#+\\|/[/*]+\\)\\s *") + (setq-local imenu-generic-expression + '(("Parameters" "^[ \t]*\\(.+?\\)[=: \t]" 1)))) ;;;###autoload (define-derived-mode conf-space-mode conf-unix-mode "Conf[Space]" @@ -529,20 +516,18 @@ class desktop add /dev/audio desktop add /dev/mixer desktop" (conf-mode-initialize "#" 'conf-space-font-lock-keywords) - (make-local-variable 'conf-assignment-sign) - (setq conf-assignment-sign nil) - (make-local-variable 'conf-space-keywords) + (setq-local conf-assignment-sign nil) (cond (buffer-file-name ;; We set conf-space-keywords directly, but a value which is ;; in the local variables list or interactively specified ;; (see the function conf-space-keywords) takes precedence. - (setq conf-space-keywords - (assoc-default buffer-file-name conf-space-keywords-alist - 'string-match)))) + (setq-local conf-space-keywords + (assoc-default buffer-file-name conf-space-keywords-alist + #'string-match)))) (conf-space-mode-internal) ;; In case the local variables list specifies conf-space-keywords, ;; recompute other things from that afterward. - (add-hook 'hack-local-variables-hook 'conf-space-mode-internal nil t)) + (add-hook 'hack-local-variables-hook #'conf-space-mode-internal nil t)) ;;;###autoload (defun conf-space-keywords (keywords) @@ -553,16 +538,16 @@ See `conf-space-mode'." (conf-space-mode)) (if (string-equal keywords "") (setq keywords nil)) - (setq conf-space-keywords keywords) + (setq-local conf-space-keywords keywords) (conf-space-mode-internal) (run-mode-hooks)) (defun conf-space-mode-internal () - (make-local-variable 'conf-assignment-regexp) - (setq conf-assignment-regexp - (if conf-space-keywords - (concat "\\(?:" conf-space-keywords "\\)[ \t]+.+?\\([ \t]+\\|$\\)") - ".+?\\([ \t]+\\|$\\)")) + (setq-local conf-assignment-regexp + (if conf-space-keywords + (concat "\\(?:" conf-space-keywords + "\\)[ \t]+.+?\\([ \t]+\\|$\\)") + ".+?\\([ \t]+\\|$\\)")) ;; If Font Lock is already enabled, reenable it with new ;; conf-assignment-regexp. (when (and font-lock-mode @@ -596,17 +581,13 @@ For details see `conf-mode'. Example: <Multi_key> <exclam> <exclam> : \"\\241\" exclamdown <Multi_key> <c> <slash> : \"\\242\" cent" (conf-mode-initialize "#" 'conf-colon-font-lock-keywords) - (set (make-local-variable 'conf-assignment-space) - conf-colon-assignment-space) - (set (make-local-variable 'conf-assignment-column) - conf-colon-assignment-column) - (set (make-local-variable 'conf-assignment-sign) - ?:) - (set (make-local-variable 'conf-assignment-regexp) - ".+?\\([ \t]*:[ \t]*\\)") - (setq imenu-generic-expression - `(("Parameters" "^[ \t]*\\(.+?\\)[ \t]*:" 1) - ,@(cdr imenu-generic-expression)))) + (setq-local conf-assignment-space conf-colon-assignment-space) + (setq-local conf-assignment-column conf-colon-assignment-column) + (setq-local conf-assignment-sign ?:) + (setq-local conf-assignment-regexp ".+?\\([ \t]*:[ \t]*\\)") + (setq-local imenu-generic-expression + `(("Parameters" "^[ \t]*\\(.+?\\)[ \t]*:" 1) + ,@(cdr imenu-generic-expression)))) ;;;###autoload (define-derived-mode conf-ppd-mode conf-colon-mode "Conf[PPD]" diff --git a/lisp/textmodes/css-mode.el b/lisp/textmodes/css-mode.el index 0d4a910a1db..cc5879880c8 100644 --- a/lisp/textmodes/css-mode.el +++ b/lisp/textmodes/css-mode.el @@ -67,7 +67,7 @@ (defconst scss-at-ids '("at-root" "content" "debug" "each" "else" "else if" "error" "extend" - "for" "function" "if" "import" "include" "mixin" "return" "warn" + "for" "function" "if" "import" "include" "mixin" "return" "use" "warn" "while") "Additional identifiers that appear in the form @foo in SCSS.") @@ -119,7 +119,6 @@ ("cue" cue-before cue-after) ("cue-after" uri "none") ("cue-before" uri "none") - ("direction" "ltr" "rtl") ("display" "inline" "block" "list-item" "inline-block" "table" "inline-table" "table-row-group" "table-header-group" "table-footer-group" "table-row" "table-column-group" @@ -180,7 +179,6 @@ ("stress" number) ("table-layout" "auto" "fixed") ("top" length percentage "auto") - ("unicode-bidi" "normal" "embed" "bidi-override") ("vertical-align" "baseline" "sub" "super" "top" "text-top" "middle" "bottom" "text-bottom" percentage length) ("visibility" "visible" "hidden" "collapse") @@ -278,6 +276,10 @@ ("color" color) ("opacity" alphavalue) + ;; CSS Containment Module Level 1 + ;; (https://www.w3.org/TR/css-contain-1/#property-index) + ("contain" "none" "strict" "content" "size" "layout" "paint") + ;; CSS Grid Layout Module Level 1 ;; (https://www.w3.org/TR/css-grid-1/#property-index) ("grid" grid-template grid-template-rows "auto-flow" "dense" @@ -490,6 +492,16 @@ ;; (https://www.w3.org/TR/css-will-change-1/#property-index) ("will-change" "auto" animateable-feature) + ;; CSS Writing Modes Level 3 + ;; (https://www.w3.org/TR/css-writing-modes-3/#property-index) + ;; "glyph-orientation-vertical" is obsolete and left out. + ("direction" "ltr" "rtl") + ("text-combine-upright" "none" "all") + ("text-orientation" "mixed" "upright" "sideways") + ("unicode-bidi" "normal" "embed" "isolate" "bidi-override" + "isolate-override" "plaintext") + ("writing-mode" "horizontal-tb" "vertical-rl" "vertical-lr") + ;; Filter Effects Module Level 1 ;; (http://www.w3.org/TR/filter-effects/#property-index) ("color-interpolation-filters" "auto" "sRGB" "linearRGB") @@ -874,7 +886,7 @@ cannot be completed sensibly: `custom-ident', (defconst css-escapes-re "\\\\\\(?:[^\000-\037\177]\\|[[:xdigit:]]+[ \n\t\r\f]?\\)") -(defconst css-nmchar-re (concat "\\(?:[-[:alnum:]]\\|" css-escapes-re "\\)")) +(defconst css-nmchar-re (concat "\\(?:[-_[:alnum:]]\\|" css-escapes-re "\\)")) (defconst css-nmstart-re (concat "\\(?:[[:alpha:]]\\|" css-escapes-re "\\)")) (defconst css-ident-re ;; (concat css-nmstart-re css-nmchar-re "*") ;; Apparently, "at rules" names can start with a dash, e.g. @-moz-keyframes. @@ -1137,17 +1149,6 @@ returns, point will be at the end of the recognized color." ;; Evaluate to the color if the name is found. ((css--named-color start-point match)))) -(defun css--contrasty-color (name) - "Return a color that contrasts with NAME. -NAME is of any form accepted by `color-distance'. -The returned color will be usable by Emacs and will contrast -with NAME; in particular so that if NAME is used as a background -color, the returned color can be used as the foreground and still -be readable." - ;; See bug#25525 for a discussion of this. - (if (> (color-distance name "black") 292485) - "black" "white")) - (defcustom css-fontify-colors t "Whether CSS colors should be fontified using the color as the background. When non-`nil', a text representing CSS color will be fontified @@ -1187,7 +1188,8 @@ START and END are buffer positions." (add-text-properties start (point) (list 'face (list :background color - :foreground (css--contrasty-color color) + :foreground (readable-foreground-color + color) :box '(:line-width -1)))))))))))) extended-region)) 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/mhtml-mode.el b/lisp/textmodes/mhtml-mode.el index b9161d9697e..54e20779bdc 100644 --- a/lisp/textmodes/mhtml-mode.el +++ b/lisp/textmodes/mhtml-mode.el @@ -73,7 +73,9 @@ code(); (defconst mhtml--crucial-variable-prefix (regexp-opt '("comment-" "uncomment-" "electric-indent-" - "smie-" "forward-sexp-function" "completion-" "major-mode")) + "smie-" "forward-sexp-function" "completion-" "major-mode" + "adaptive-fill-" "fill-" "normal-auto-fill-function" + "paragraph-")) "Regexp matching the prefix of \"crucial\" buffer-locals we want to capture.") (defconst mhtml--variable-prefix @@ -157,54 +159,6 @@ code(); (mhtml--submode-name submode) ""))) -(defvar font-lock-beg) -(defvar font-lock-end) - -(defun mhtml--extend-font-lock-region () - "Extend the font lock region according to HTML sub-mode needs. - -This is used via `font-lock-extend-region-functions'. It ensures -that the font-lock region is extended to cover either whole -lines, or to the spot where the submode changes, whichever is -smallest." - (let ((orig-beg font-lock-beg) - (orig-end font-lock-end)) - ;; The logic here may look odd but it is needed to ensure that we - ;; do the right thing when trying to limit the search. - (save-excursion - (goto-char font-lock-beg) - ;; previous-single-property-change starts by looking at the - ;; previous character, but we're trying to extend a region to - ;; include just characters with the same submode as this - ;; character. - (unless (eobp) - (forward-char)) - (setq font-lock-beg (previous-single-property-change - (point) 'mhtml-submode nil - (line-beginning-position))) - (unless (eq (get-text-property font-lock-beg 'mhtml-submode) - (get-text-property orig-beg 'mhtml-submode)) - (cl-incf font-lock-beg)) - - (goto-char font-lock-end) - (unless (bobp) - (backward-char)) - (setq font-lock-end (next-single-property-change - (point) 'mhtml-submode nil - (line-beginning-position 2))) - (unless (eq (get-text-property font-lock-end 'mhtml-submode) - (get-text-property orig-end 'mhtml-submode)) - (cl-decf font-lock-end))) - - ;; Also handle the multiline property -- but handle it here, and - ;; not via font-lock-extend-region-functions, to avoid the - ;; situation where the two extension functions disagree. - ;; See bug#29159. - (font-lock-extend-region-multiline) - - (or (/= font-lock-beg orig-beg) - (/= font-lock-end orig-end)))) - (defun mhtml--submode-fontify-one-region (submode beg end &optional loudly) (if submode (mhtml--with-locals submode @@ -303,17 +257,14 @@ This is used by `mhtml--pre-command'.") sgml-syntax-propertize-rules)) (defun mhtml-syntax-propertize (start end) - ;; First remove our special settings from the affected text. They - ;; will be re-applied as needed. - (remove-list-of-text-properties start end - '(syntax-table local-map mhtml-submode)) - (goto-char start) - ;; Be sure to look back one character, because START won't yet have - ;; been propertized. - (unless (bobp) - (let ((submode (get-text-property (1- (point)) 'mhtml-submode))) - (if submode - (mhtml--syntax-propertize-submode submode end)))) + (let ((submode (get-text-property start 'mhtml-submode))) + ;; First remove our special settings from the affected text. They + ;; will be re-applied as needed. + (remove-list-of-text-properties start end + '(syntax-table local-map mhtml-submode)) + (goto-char start) + (if submode + (mhtml--syntax-propertize-submode submode end))) (sgml-syntax-propertize (point) end mhtml--syntax-propertize)) (defun mhtml-indent-line () @@ -364,8 +315,6 @@ the rules from `css-mode'." (setq-local syntax-propertize-function #'mhtml-syntax-propertize) (setq-local font-lock-fontify-region-function #'mhtml--submode-fontify-region) - (setq-local font-lock-extend-region-functions - '(mhtml--extend-font-lock-region)) ;; Attach this to both pre- and post- hooks just in case it ever ;; changes a key binding that might be accessed from the menu bar. @@ -383,6 +332,18 @@ the rules from `css-mode'." ;: Hack (js--update-quick-match-re) + ;; Setup the appropriate js-mode value of auto-fill-function. + (setf (mhtml--submode-crucial-captured-locals mhtml--js-submode) + (push (cons 'auto-fill-function + (if (and (boundp 'auto-fill-function) auto-fill-function) + #'js-do-auto-fill + nil)) + (mhtml--submode-crucial-captured-locals mhtml--js-submode))) + + ;; This mode might be using CC Mode's filling functionality. + (c-foreign-init-lit-pos-cache) + (add-hook 'before-change-functions #'c-foreign-truncate-lit-pos-cache nil t) + ;; This is sort of a prog-mode as well as a text mode. (run-hooks 'prog-mode-hook)) diff --git a/lisp/textmodes/nroff-mode.el b/lisp/textmodes/nroff-mode.el index 62e8b1f0934..bb2582cf7a2 100644 --- a/lisp/textmodes/nroff-mode.el +++ b/lisp/textmodes/nroff-mode.el @@ -50,7 +50,6 @@ (let ((map (make-sparse-keymap)) (menu-map (make-sparse-keymap))) (define-key map "\t" 'tab-to-tab-stop) - (define-key map "\es" 'center-line) (define-key map "\e?" 'nroff-count-text-lines) (define-key map "\n" 'nroff-electric-newline) (define-key map "\en" 'nroff-forward-text-line) diff --git a/lisp/textmodes/paragraphs.el b/lisp/textmodes/paragraphs.el index 99c3e471241..b0975291428 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) @@ -371,33 +371,50 @@ See `forward-paragraph' for more information." (defun mark-paragraph (&optional arg allow-extend) "Put point at beginning of this paragraph, mark at end. -The paragraph marked is the one that contains point or follows point. +The paragraph marked is the one that contains point or follows +point. -With argument ARG, puts mark at end of a following paragraph, so that -the number of paragraphs marked equals ARG. +With argument ARG, puts mark at the end of this or a following +paragraph, so that the number of paragraphs marked equals ARG. -If ARG is negative, point is put at end of this paragraph, mark is put -at beginning of this or a previous paragraph. +If ARG is negative, point is put at the end of this paragraph, +mark is put at the beginning of this or a previous paragraph. Interactively (or if ALLOW-EXTEND is non-nil), if this command is -repeated or (in Transient Mark mode) if the mark is active, -it marks the next ARG paragraphs after the ones already marked." - (interactive "p\np") - (unless arg (setq arg 1)) - (when (zerop arg) - (error "Cannot mark zero paragraphs")) - (cond ((and allow-extend - (or (and (eq last-command this-command) (mark t)) - (and transient-mark-mode mark-active))) - (set-mark - (save-excursion - (goto-char (mark)) - (forward-paragraph arg) - (point)))) - (t - (forward-paragraph arg) - (push-mark nil t t) - (backward-paragraph arg)))) +repeated or (in Transient Mark mode) if the mark is active, it +marks the next ARG paragraphs after the region already marked. +This also means when activating the mark immediately before using +this command, the current paragraph is only marked from point." + (interactive "P\np") + (let ((numeric-arg (prefix-numeric-value arg))) + (cond ((zerop numeric-arg)) + ((and allow-extend + (or (and (eq last-command this-command) mark-active) + (region-active-p))) + (if arg + (setq arg numeric-arg) + (if (< (mark) (point)) + (setq arg -1) + (setq arg 1))) + (set-mark + (save-excursion + (goto-char (mark)) + (forward-paragraph arg) + (point)))) + ;; don't activate the mark when at eob + ((and (eobp) (> numeric-arg 0))) + (t + (unless (save-excursion + (forward-line 0) + (looking-at paragraph-start)) + (backward-paragraph (cond ((> numeric-arg 0) 1) + ((< numeric-arg 0) -1) + (t 0)))) + (push-mark + (save-excursion + (forward-paragraph numeric-arg) + (point)) + t t))))) (defun kill-paragraph (arg) "Kill forward to end of paragraph. diff --git a/lisp/textmodes/po.el b/lisp/textmodes/po.el index d5645e86304..29c6d3f4608 100644 --- a/lisp/textmodes/po.el +++ b/lisp/textmodes/po.el @@ -1,4 +1,4 @@ -;;; po.el --- basic support of PO translation files +;;; po.el --- basic support of PO translation files -*- lexical-binding:t -*- ;; Copyright (C) 1995-1998, 2000-2020 Free Software Foundation, Inc. diff --git a/lisp/textmodes/reftex-vars.el b/lisp/textmodes/reftex-vars.el index ca92541331e..c9fd19d2324 100644 --- a/lisp/textmodes/reftex-vars.el +++ b/lisp/textmodes/reftex-vars.el @@ -925,7 +925,7 @@ DOWNCASE t: Downcase words before using them." "\\<label[[:space:]]*=[[:space:]]*" ;; Match the label value; braces around the value are ;; optional. - "{?\\(?1:[^] ,}\r\n\t%]+\\)}?" + "{?\\(?1:[^] ,}\r\n\t%]+\\)" ;; We are done. Just search until the next closing bracket "[^]]*\\]")) "List of regexps matching \\label definitions. @@ -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/remember.el b/lisp/textmodes/remember.el index 836dfb4a538..279dbb4450c 100644 --- a/lisp/textmodes/remember.el +++ b/lisp/textmodes/remember.el @@ -5,7 +5,7 @@ ;; Author: John Wiegley <johnw@gnu.org> ;; Maintainer: emacs-devel@gnu.org ;; Created: 29 Mar 1999 -;; Version: 2.0 +;; Old-Version: 2.0 ;; Keywords: data memory todo pim ;; URL: http://gna.org/projects/remember-el/ @@ -181,6 +181,7 @@ (defconst remember-version "2.0" "This version of remember.") +(make-obsolete-variable 'remember-version nil "28.1") (defgroup remember nil "A mode to remember information." diff --git a/lisp/textmodes/sgml-mode.el b/lisp/textmodes/sgml-mode.el index 6152a8ad0a7..1672dce4f23 100644 --- a/lisp/textmodes/sgml-mode.el +++ b/lisp/textmodes/sgml-mode.el @@ -286,7 +286,10 @@ separated by a space." (defconst sgml-namespace-re "[_[:alpha:]][-_.[:alnum:]]*") (defconst sgml-name-re "[_:[:alpha:]][-_.:[:alnum:]]*") (defconst sgml-tag-name-re (concat "<\\([!/?]?" sgml-name-re "\\)")) -(defconst sgml-attrs-re "\\(?:[^\"'/><]\\|\"[^\"]*\"\\|'[^']*'\\)*") +(defconst sgml-attrs-re + ;; This pattern cannot begin with a character matched by the end of + ;; `sgml-name-re' above. + "\\(?:[^_.:\"'/><[:alnum:]-]\\(?:[^\"'/><]\\|\"[^\"]*\"\\|'[^']*'\\)*\\)?") (defconst sgml-start-tag-regex (concat "<" sgml-name-re sgml-attrs-re) "Regular expression that matches a non-empty start tag. Any terminating `>' or `/' is not matched.") @@ -1803,6 +1806,7 @@ This takes effect when first loading the library.") (define-key map "\C-c\C-cc" 'html-checkboxes) (define-key map "\C-c\C-cl" 'html-list-item) (define-key map "\C-c\C-ch" 'html-href-anchor) + (define-key map "\C-c\C-cf" 'html-href-anchor-file) (define-key map "\C-c\C-cn" 'html-name-anchor) (define-key map "\C-c\C-c#" 'html-id-anchor) (define-key map "\C-c\C-ci" 'html-image) @@ -1815,6 +1819,7 @@ This takes effect when first loading the library.") (define-key map "\C-cc" 'html-checkboxes) (define-key map "\C-cl" 'html-list-item) (define-key map "\C-ch" 'html-href-anchor) + (define-key map "\C-cf" 'html-href-anchor-file) (define-key map "\C-cn" 'html-name-anchor) (define-key map "\C-c#" 'html-id-anchor) (define-key map "\C-ci" 'html-image) @@ -1842,15 +1847,16 @@ This takes effect when first loading the library.") (define-key menu-map "\n" '("Line Break" . html-line)) (define-key menu-map "\r" '("Paragraph" . html-paragraph)) (define-key menu-map "i" '("Image" . html-image)) - (define-key menu-map "h" '("Href Anchor" . html-href-anchor)) + (define-key menu-map "h" '("Href Anchor URL" . html-href-anchor)) + (define-key menu-map "f" '("Href Anchor File" . html-href-anchor-file)) (define-key menu-map "n" '("Name Anchor" . html-name-anchor)) (define-key menu-map "#" '("ID Anchor" . html-id-anchor)) map) "Keymap for commands for use in HTML mode.") (defvar html-face-tag-alist - '((bold . "b") - (italic . "i") + '((bold . "strong") + (italic . "em") (underline . "u") (mode-line . "rev")) "Value of `sgml-face-tag-alist' for HTML mode.") @@ -2360,7 +2366,7 @@ have <h1>Very Major Headlines</h1> through <h6>Very Minor Headlines</h6> <p>Paragraphs only need an opening tag. Line breaks and multiple spaces are ignored unless the text is <pre>preformatted.</pre> Text can be marked as -<b>bold</b>, <i>italic</i> or <u>underlined</u> using the normal M-o or +<strong>bold</strong>, <em>italic</em> or <u>underlined</u> using the normal M-o or Edit/Text Properties/Face commands. Pages can have <a name=\"SOMENAME\">named points</a> and can link other points @@ -2450,6 +2456,11 @@ HTML Autoview mode is a buffer-local minor mode for use with ;; '(setq input "http:") "<a href=\"" str "\">" _ "</a>") +(define-skeleton html-href-anchor-file + "HTML anchor tag with href attribute (from a local file)." + (file-relative-name (read-file-name "File name: ") default-directory) + "<a href=\"" str "\">" _ "</a>") + (define-skeleton html-name-anchor "HTML anchor tag with name attribute." "Name: " diff --git a/lisp/textmodes/table.el b/lisp/textmodes/table.el index bd2cac7aebb..33f181b80c3 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." @@ -3207,11 +3209,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/tex-mode.el b/lisp/textmodes/tex-mode.el index 0e28756ea75..a905d148009 100644 --- a/lisp/textmodes/tex-mode.el +++ b/lisp/textmodes/tex-mode.el @@ -224,7 +224,7 @@ Should show the queue(s) that \\[tex-print] puts jobs on." :group 'tex-view) ;;;###autoload -(defcustom tex-default-mode 'latex-mode +(defcustom tex-default-mode #'latex-mode "Mode to enter for a new file that might be either TeX or LaTeX. This variable is used when it can't be determined whether the file is plain TeX or LaTeX or what because the file contains no commands. @@ -465,7 +465,7 @@ An alternative value is \" . \", if you use a font with a narrow period." ; ("{\\\\bf\\([^}]+\\)}" 1 'bold keep) ; ("{\\\\\\(em\\|it\\|sl\\)\\([^}]+\\)}" 2 'italic keep) ; ("\\\\\\([a-zA-Z@]+\\|.\\)" . font-lock-keyword-face) -; ("^[ \t\n]*\\\\def[\\\\@]\\(\\w+\\)" 1 font-lock-function-name-face keep)) +; ("^[ \t\n]*\\\\def[\\@]\\(\\w+\\)" 1 font-lock-function-name-face keep)) ; ;; Rewritten and extended for LaTeX2e by Ulrik Dickow <dickow@nbi.dk>. ; '(("\\\\\\(begin\\|end\\|newcommand\\){\\([a-zA-Z0-9\\*]+\\)}" ; 2 font-lock-function-name-face) @@ -593,7 +593,7 @@ An alternative value is \" . \", if you use a font with a narrow period." ;; Miscellany. (slash "\\\\") (opt " *\\(\\[[^]]*\\] *\\)*") - (args "\\(\\(?:[^{}&\\]+\\|\\\\.\\|{[^}]*}\\)+\\)") + (args "\\(\\(?:[^${}&\\]+\\|\\\\.\\|{[^}]*}\\)+\\)") (arg "{\\(\\(?:[^{}\\]+\\|\\\\.\\|{[^}]*}\\)+\\)")) (list ;; @@ -668,7 +668,9 @@ An alternative value is \" . \", if you use a font with a narrow period." "Default expressions to highlight in TeX modes.") (defvar tex-verbatim-environments - '("verbatim" "verbatim*")) + '("verbatim" "verbatim*" + "Verbatim" ;; From "fancyvrb" + )) (put 'tex-verbatim-environments 'safe-local-variable (lambda (x) (not (memq nil (mapcar #'stringp x))))) @@ -966,7 +968,7 @@ Inherits `shell-mode-map' with a few additions.") ;; This would be a lot simpler if we just used a regexp search, ;; but then it would be too slow. -(defun tex-guess-mode () +(defun tex--guess-mode () (let ((mode tex-default-mode) slash comment) (save-excursion (goto-char (point-min)) @@ -983,52 +985,40 @@ Inherits `shell-mode-map' with a few additions.") (regexp-opt '("documentstyle" "documentclass" "begin" "subsection" "section" "part" "chapter" "newcommand" - "renewcommand" "RequirePackage") 'words) + "renewcommand" "RequirePackage") + 'words) "\\|NeedsTeXFormat{LaTeX"))) (if (and (looking-at "document\\(style\\|class\\)\\(\\[.*\\]\\)?{slides}") ;; SliTeX is almost never used any more nowadays. (tex-executable-exists-p slitex-run-command)) - 'slitex-mode - 'latex-mode) - 'plain-tex-mode)))) - (funcall mode))) + #'slitex-mode + #'latex-mode) + #'plain-tex-mode)))) + mode)) ;; `tex-mode' plays two roles: it's the parent of several sub-modes ;; but it's also the function that chooses between those submodes. ;; To tell the difference between those two cases where the function ;; might be called, we check `delay-mode-hooks'. -(define-derived-mode tex-mode text-mode "generic-TeX" - (tex-common-initialization)) -;; We now move the function and define it again. This gives a warning -;; in the byte-compiler :-( but it's difficult to avoid because -;; `define-derived-mode' will necessarily define the function once -;; and we need to define it a second time for `autoload' to get the -;; proper docstring. -(defalias 'tex-mode-internal (symbol-function 'tex-mode)) - -;; Suppress the byte-compiler warning about multiple definitions. -;; This is a) ugly, and b) cheating, but this was the last -;; remaining warning from byte-compiling all of Emacs... -(eval-when-compile - (if (boundp 'byte-compile-function-environment) - (setq byte-compile-function-environment - (delq (assq 'tex-mode byte-compile-function-environment) - byte-compile-function-environment)))) - ;;;###autoload -(defun tex-mode () +(define-derived-mode tex-mode text-mode "generic-TeX" "Major mode for editing files of input for TeX, LaTeX, or SliTeX. +This is the shared parent mode of several submodes. Tries to determine (by looking at the beginning of the file) whether this file is for plain TeX, LaTeX, or SliTeX and calls `plain-tex-mode', -`latex-mode', or `slitex-mode', respectively. If it cannot be determined, +`latex-mode', or `slitex-mode', accordingly. If it cannot be determined, such as if there are no commands in the file, the value of `tex-default-mode' says which mode to use." - (interactive) - (if delay-mode-hooks - ;; We're called from one of the children already. - (tex-mode-internal) - (tex-guess-mode))) + (tex-common-initialization)) + +(advice-add 'tex-mode :around #'tex--redirect-to-submode) +(defun tex--redirect-to-submode (orig-fun) + "Redirect to one of the submodes when called directly." + (funcall (if delay-mode-hooks + ;; We're called from one of the children already. + orig-fun + (tex--guess-mode)))) ;; The following three autoloaded aliases appear to conflict with ;; AUCTeX. However, even though AUCTeX uses the mixed case variants @@ -1037,6 +1027,10 @@ says which mode to use." ;; AUCTeX to provide a fully functional user-level replacement. So ;; these aliases should remain as they are, in particular since AUCTeX ;; users are likely to use them. +;; Note from Stef: I don't understand the above explanation, the only +;; justification I can find to keep those confusing aliases is for those +;; users who may have files annotated with -*- LaTeX -*- (e.g. because they +;; received them from someone using AUCTeX). ;;;###autoload (defalias 'TeX-mode 'tex-mode) @@ -1252,10 +1246,10 @@ Entering SliTeX mode runs the hook `text-mode-hook', then the hook ("\\\\[a-zA-Z]+\\( +\\|{}\\)[a-zA-Z]*" . "") ("%" . "$")))) ;; A line containing just $$ is treated as a paragraph separator. - (setq-local paragraph-start "[ \t]*$\\|[\f\\\\%]\\|[ \t]*\\$\\$") + (setq-local paragraph-start "[ \t]*$\\|[\f\\%]\\|[ \t]*\\$\\$") ;; A line starting with $$ starts a paragraph, ;; but does not separate paragraphs if it has more stuff on it. - (setq-local paragraph-separate "[ \t]*$\\|[\f\\\\%]\\|[ \t]*\\$\\$[ \t]*$") + (setq-local paragraph-separate "[ \t]*$\\|[\f\\%]\\|[ \t]*\\$\\$[ \t]*$") (setq-local add-log-current-defun-function #'tex-current-defun-name) (setq-local comment-start "%") (setq-local comment-add 1) @@ -2301,9 +2295,6 @@ FILE is typically the output DVI or PDF file." (setq uptodate nil))))) uptodate))) - -(autoload 'format-spec "format-spec") - (defvar tex-executable-cache nil) (defun tex-executable-exists-p (name) "Like `executable-find' but with a cache." diff --git a/lisp/textmodes/texinfo.el b/lisp/textmodes/texinfo.el index 438cb7798a1..b3bc634de9b 100644 --- a/lisp/textmodes/texinfo.el +++ b/lisp/textmodes/texinfo.el @@ -482,6 +482,13 @@ Subexpression 1 is what goes into the corresponding `@end' statement.") (define-key map "\C-c\C-ce" 'texinfo-insert-@end) (define-key map "\C-c\C-cd" 'texinfo-insert-@dfn) (define-key map "\C-c\C-cc" 'texinfo-insert-@code) + + ;; bindings for environment movement + (define-key map "\C-c." 'texinfo-to-environment-bounds) + (define-key map "\C-c\C-c\C-f" 'texinfo-next-environment-end) + (define-key map "\C-c\C-c\C-b" 'texinfo-previous-environment-end) + (define-key map "\C-c\C-c\C-n" 'texinfo-next-environment-start) + (define-key map "\C-c\C-c\C-p" 'texinfo-previous-environment-start) map)) (easy-menu-define texinfo-mode-menu @@ -958,6 +965,12 @@ to jump to the corresponding spot in the Texinfo source file." :type 'string :group 'texinfo) +(defcustom texinfo-texi2dvi-options "" + "Command line options for `texinfo-texi2dvi-command'." + :type 'string + :group 'texinfo + :version "28.1") + (defcustom texinfo-tex-command "tex" "Command used by `texinfo-tex-region' to run TeX on a region." :type 'string @@ -1002,9 +1015,10 @@ The value of `texinfo-tex-trailer' is appended to the temporary file after the r (interactive) (require 'tex-mode) (let ((tex-command texinfo-texi2dvi-command) - ;; Disable tex-start-options-string. texi2dvi would not - ;; understand anything specified here. - (tex-start-options-string "")) + (tex-start-options texinfo-texi2dvi-options) + ;; Disable tex-start-commands. texi2dvi would not understand + ;; anything specified here. + (tex-start-commands "")) (tex-buffer))) (defun texinfo-texindex () @@ -1065,6 +1079,70 @@ You are prompted for the job number (use a number shown by a previous ;; job-number"\n")) (tex-recenter-output-buffer nil)) +(defun texinfo-to-environment-bounds () + "Move point alternately to the start and end of a Texinfo environment. +Do nothing when outside of an environment. This command does not +handle nested environments." + (interactive) + (cond ((save-excursion + (forward-line 0) + (looking-at texinfo-environment-regexp)) + (if (save-excursion + (forward-line 0) + (looking-at "^@end")) + (texinfo-previous-environment-start) + (texinfo-next-environment-end))) + ((save-excursion + (and (re-search-backward texinfo-environment-regexp nil t) + (not (looking-at "^@end")))) + (texinfo-previous-environment-start)) + ;; Otherwise, point is outside of an environment, so do nothing. + )) + +(defun texinfo-next-environment-start () + "Move forward to the beginning of a Texinfo environment." + (interactive) + (if (looking-at texinfo-environment-regexp) + (forward-line 1)) + (while (and (re-search-forward texinfo-environment-regexp nil t) + (save-excursion + (goto-char (match-beginning 0)) + (looking-at "@end")))) + (if (save-excursion + (forward-line 0) + (looking-at texinfo-environment-regexp)) + (forward-line 0))) + +(defun texinfo-previous-environment-start () + "Move back to the beginning of the previous Texinfo environment." + (interactive) + (while (and (re-search-backward texinfo-environment-regexp nil t) + (save-excursion + (goto-char (match-beginning 0)) + (looking-at "@end"))))) + +(defun texinfo-next-environment-end () + "Move forward to the beginning of the next @end line of an environment." + (interactive) + (if (looking-at "^@end") + (forward-line 1)) + (while (and (re-search-forward texinfo-environment-regexp nil t) + (save-excursion + (goto-char (match-beginning 0)) + (not (looking-at "^@end"))))) + (if (save-excursion + (forward-line 0) + (looking-at "^@end")) + (forward-line 0))) + +(defun texinfo-previous-environment-end () + "Move backward to the beginning of the next @end line of an environment." + (interactive) + (while (and (re-search-backward texinfo-environment-regexp nil t) + (save-excursion + (goto-char (match-beginning 0)) + (not (looking-at "@end")))))) + (provide 'texinfo) ;;; texinfo.el ends here 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/thingatpt.el b/lisp/thingatpt.el index 1a15df33e50..483a2c9bd83 100644 --- a/lisp/thingatpt.el +++ b/lisp/thingatpt.el @@ -334,7 +334,7 @@ the bounds of a possible ill-formed URI (one lacking a scheme)." ;; may contain parentheses but may not contain spaces (RFC3986). (let* ((allowed-chars "--:=&?$+@-Z_[:alpha:]~#,%;*()!'") (skip-before "^[0-9a-zA-Z]") - (skip-after ":;.,!?") + (skip-after ":;.,!?'") (pt (point)) (beg (save-excursion (skip-chars-backward allowed-chars) 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-about.el b/lisp/url/url-about.el index dde47e94de5..5fe817cc0e8 100644 --- a/lisp/url/url-about.el +++ b/lisp/url/url-about.el @@ -51,7 +51,7 @@ " <title>Supported Protocols</title>\n" " </head>\n" " <body>\n" - " <h1>Supported Protocols - URL v" url-version "</h1>\n" + " <h1>Supported Protocols - URL package in Emacs " emacs-version "</h1>\n" " <table width='100%' border='1'>\n" " <tr>\n" " <td>Protocol\n" diff --git a/lisp/url/url-expand.el b/lisp/url/url-expand.el index 47964b081f4..f34ef810c4a 100644 --- a/lisp/url/url-expand.el +++ b/lisp/url/url-expand.el @@ -92,12 +92,19 @@ path components followed by `..' are removed, along with the `..' itself." (cond ((= (length url) 0) ; nil or empty string (url-recreate-url default)) - ((string-match url-nonrelative-link url) ; Fully-qualified URL, return it immediately + ((string-match url-nonrelative-link url) ; Fully-qualified URL, + ; return it immediately url) (t (let* ((urlobj (url-generic-parse-url url)) (inhibit-file-name-handlers t) - (expander (url-scheme-get-property (url-type default) 'expand-file-name))) + (expander (if (url-type default) + (url-scheme-get-property (url-type default) + 'expand-file-name) + ;; If neither the default nor the URL to be + ;; expanded have a protocol, then just use the + ;; identity expander as a fallback. + 'url-identity-expander))) (if (string-match "^//" url) (setq urlobj (url-generic-parse-url (concat (url-type default) ":" url)))) diff --git a/lisp/url/url-gw.el b/lisp/url/url-gw.el index bcb67431aa8..f16fc234025 100644 --- a/lisp/url/url-gw.el +++ b/lisp/url/url-gw.el @@ -191,7 +191,7 @@ linked Emacs under SunOS 4.x." proc (concat (mapconcat 'identity (append url-gateway-telnet-parameters (list host service)) " ") "\n")) - (url-wait-for-string "^\r*Escape character.*\r*\n+" proc) + (url-wait-for-string "^\r*Escape character.*\n+" proc) (delete-region (point-min) (match-end 0)) (process-send-string proc "\^]\n") (url-wait-for-string "^telnet" proc) diff --git a/lisp/url/url-handlers.el b/lisp/url/url-handlers.el index 331152808fd..1c3607bb661 100644 --- a/lisp/url/url-handlers.el +++ b/lisp/url/url-handlers.el @@ -339,8 +339,7 @@ if it had been inserted from a file named URL." (decode-coding-inserted-region (point-min) (point) url visit beg end replace)) (let ((inserted (car size-and-charset))) - (list url (or (and (fboundp 'after-insert-file-set-coding) - (after-insert-file-set-coding inserted visit)) + (list url (or (after-insert-file-set-coding inserted visit) inserted)))))) ;;;###autoload diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el index 55953c83c04..8532da1d1fb 100644 --- a/lisp/url/url-http.el +++ b/lisp/url/url-http.el @@ -225,7 +225,7 @@ request.") (os-info (unless (and (listp url-privacy-level) (memq 'os url-privacy-level)) (format "(%s; %s)" url-system-type url-os-type))) - (url-info (format "URL/%s" url-version))) + (url-info (format "URL/Emacs"))) (string-join (delq nil (list package-info url-info emacs-info os-info)) " "))) @@ -702,15 +702,7 @@ should be shown to the user." ;; Treat everything like '300' nil)) (when redirect-uri - ;; Clean off any whitespace and/or <...> cruft. - (if (string-match "\\([^ \t]+\\)[ \t]" redirect-uri) - (setq redirect-uri (match-string 1 redirect-uri))) - (if (string-match "^<\\(.*\\)>$" redirect-uri) - (setq redirect-uri (match-string 1 redirect-uri))) - - ;; Some stupid sites (like sourceforge) send a - ;; non-fully-qualified URL (ie: /), which royally confuses - ;; the URL library. + ;; Handle relative redirect URIs. (if (not (string-match url-nonrelative-link redirect-uri)) ;; Be careful to use the real target URL, otherwise we may ;; compute the redirection relative to the URL of the proxy. @@ -1404,13 +1396,22 @@ The return value of this function is the retrieval buffer." (defun url-https-proxy-connect (connection) (setq url-http-after-change-function 'url-https-proxy-after-change-function) - (process-send-string connection (format (concat "CONNECT %s:%d HTTP/1.1\r\n" - "Host: %s\r\n" - "\r\n") - (url-host url-current-object) - (or (url-port url-current-object) - url-https-default-port) - (url-host url-current-object)))) + (process-send-string + connection + (format + (concat "CONNECT %s:%d HTTP/1.1\r\n" + "Host: %s\r\n" + (let ((proxy-auth (let ((url-basic-auth-storage + 'url-http-proxy-basic-auth-storage)) + (url-get-authentication url-http-proxy nil + 'any nil)))) + (and proxy-auth + (concat "Proxy-Authorization: " proxy-auth "\r\n"))) + "\r\n") + (url-host url-current-object) + (or (url-port url-current-object) + url-https-default-port) + (url-host url-current-object)))) (defun url-https-proxy-after-change-function (_st _nd _length) (let* ((process-buffer (current-buffer)) diff --git a/lisp/url/url-news.el b/lisp/url/url-news.el index d47eb02db68..9ef17cccd77 100644 --- a/lisp/url/url-news.el +++ b/lisp/url/url-news.el @@ -75,7 +75,7 @@ " </div>\n" " </body>\n" "</html>\n" - "<!-- Automatically generated by URL v" url-version " -->\n" + "<!-- Automatically generated by URL in Emacs " emacs-version " -->\n" ))) buf)) diff --git a/lisp/url/url-queue.el b/lisp/url/url-queue.el index ff18cf1fe40..46cdff0f724 100644 --- a/lisp/url/url-queue.el +++ b/lisp/url/url-queue.el @@ -123,17 +123,24 @@ The variable `url-queue-timeout' sets a timeout." (setq url-queue-progress-timer nil)))) (defun url-queue-callback-function (status job) - (setq url-queue (delq job url-queue)) - (when (and (eq (car status) :error) - (eq (cadr (cadr status)) 'connection-failed)) - ;; If we get a connection error, then flush all other jobs from - ;; the host from the queue. This particularly makes sense if the - ;; error really is a DNS resolver issue, which happens - ;; synchronously and totally halts Emacs. - (url-queue-remove-jobs-from-host - (plist-get (nthcdr 3 (cadr status)) :host))) - (url-queue-run-queue) - (apply (url-queue-callback job) (cons status (url-queue-cbargs job)))) + (let ((buffer (current-buffer))) + (setq url-queue (delq job url-queue)) + (when (and (eq (car status) :error) + (eq (cadr (cadr status)) 'connection-failed)) + ;; If we get a connection error, then flush all other jobs from + ;; the host from the queue. This particularly makes sense if the + ;; error really is a DNS resolver issue, which happens + ;; synchronously and totally halts Emacs. + (url-queue-remove-jobs-from-host + (plist-get (nthcdr 3 (cadr status)) :host))) + (url-queue-run-queue) + ;; Somehow something deep in the bowels in the URL library may + ;; have killed off the current buffer. So check that it's still + ;; alive before doing anything, and if not, just create a dummy + ;; buffer and do the callback anyway. + (unless (buffer-live-p buffer) + (set-buffer (generate-new-buffer " *temp*"))) + (apply (url-queue-callback job) (cons status (url-queue-cbargs job))))) (defun url-queue-remove-jobs-from-host (host) (let ((jobs nil)) diff --git a/lisp/url/url-util.el b/lisp/url/url-util.el index 645011a5783..6dd7a9c2aac 100644 --- a/lisp/url/url-util.el +++ b/lisp/url/url-util.el @@ -615,9 +615,7 @@ Creates FILE and its parent directories if they do not exist." (with-temp-buffer (write-region (point-min) (point-max) file nil 'silent nil 'excl))) (file-already-exists - (if (file-symlink-p file) - (error "Danger: `%s' is a symbolic link" file)) - (set-file-modes file #o0600)))) + (set-file-modes file #o0600 'nofollow)))) (autoload 'puny-encode-domain "puny") (autoload 'url-domsuf-cookie-allowed-p "url-domsuf") diff --git a/lisp/url/url-vars.el b/lisp/url/url-vars.el index 82617b76a71..d9277cf6f42 100644 --- a/lisp/url/url-vars.el +++ b/lisp/url/url-vars.el @@ -24,6 +24,7 @@ (defconst url-version "Emacs" "Version number of URL package.") +(make-obsolete-variable 'url-version nil "28.1") (defgroup url nil "Uniform Resource Locator tool." @@ -430,6 +431,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/url/url.el b/lisp/url/url.el index 12a8a9c2e21..321e79c019f 100644 --- a/lisp/url/url.el +++ b/lisp/url/url.el @@ -238,7 +238,8 @@ how long to wait for a response before giving up." (let ((retrieval-done nil) (start-time (current-time)) (url-asynchronous nil) - (asynch-buffer nil)) + (asynch-buffer nil) + (timed-out nil)) (setq asynch-buffer (url-retrieve url (lambda (&rest ignored) (url-debug 'retrieval "Synchronous fetching done (%S)" (current-buffer)) @@ -261,7 +262,9 @@ how long to wait for a response before giving up." ;; process output. (while (and (not retrieval-done) (or (not timeout) - (time-less-p (time-since start-time) timeout))) + (not (setq timed-out + (time-less-p timeout + (time-since start-time)))))) (url-debug 'retrieval "Spinning in url-retrieve-synchronously: %S (%S)" retrieval-done asynch-buffer) @@ -300,8 +303,16 @@ how long to wait for a response before giving up." (when quit-flag (delete-process proc)) (setq proc (and (not quit-flag) - (get-buffer-process asynch-buffer))))))) - asynch-buffer))) + (get-buffer-process asynch-buffer)))))) + ;; On timeouts, make sure we kill any pending processes. + ;; There may be more than one if we had a redirect. + (when timed-out + (when (process-live-p proc) + (delete-process proc)) + (when-let ((aproc (get-buffer-process asynch-buffer))) + (when (process-live-p aproc) + (delete-process aproc)))))) + asynch-buffer)) ;; url-mm-callback called from url-mm, which requires mm-decode. (declare-function mm-dissect-buffer "mm-decode" diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index 8171a585158..d194d6c0a0e 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -484,7 +484,7 @@ and the face `diff-added' for added lines.") ;; Prefer second name as first is most likely to be a backup or ;; version-control name. The [\t\n] at the end of the unidiff pattern ;; catches Debian source diff files (which lack the trailing date). - '((nil "\\+\\+\\+\\ \\([^\t\n]+\\)[\t\n]" 1) ; unidiffs + '((nil "\\+\\+\\+ \\([^\t\n]+\\)[\t\n]" 1) ; unidiffs (nil "^--- \\([^\t\n]+\\)\t.*\n\\*" 1))) ; context diffs ;;;; @@ -2720,7 +2720,9 @@ hunk text is not found in the source file." ;; When initialization is requested, we should be in a brand new ;; temp buffer. (cl-assert (null buffer-file-name)) - (let ((enable-local-variables :safe) ;; to find `mode:' + ;; Use `:safe' to find `mode:'. In case of hunk-only, use nil because + ;; Local Variables list might be incomplete when context is truncated. + (let ((enable-local-variables (unless hunk-only :safe)) (buffer-file-name file)) ;; Don't run hooks that might assume buffer-file-name ;; really associates buffer with a file (bug#39190). diff --git a/lisp/vc/ediff-init.el b/lisp/vc/ediff-init.el index fb1f25b6c6d..f5177bca112 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. @@ -1255,22 +1257,8 @@ Instead, C-h would jump to previous difference." :type 'boolean :group 'ediff) -;; This is the same as temporary-file-directory from Emacs 20.3. -;; Copied over here because XEmacs doesn't have this variable. -(defcustom ediff-temp-file-prefix - (file-name-as-directory - (cond ((boundp 'temporary-file-directory) temporary-file-directory) - ((fboundp 'temp-directory) (temp-directory)) - (t "/tmp/"))) -;;; (file-name-as-directory -;;; (cond ((memq system-type '(ms-dos windows-nt)) -;;; (or (getenv "TEMP") (getenv "TMPDIR") (getenv "TMP") "c:/temp")) -;;; (t -;;; (or (getenv "TMPDIR") (getenv "TMP") (getenv "TEMP") "/tmp")))) - "Prefix to put on Ediff temporary file names. -Do not start with `~/' or `~USERNAME/'." - :type 'string - :group 'ediff) +(define-obsolete-variable-alias 'ediff-temp-file-prefix + 'temporary-file-directory "28.1") (defcustom ediff-temp-file-mode 384 ; u=rw only "Mode for Ediff temporary files." @@ -1282,11 +1270,11 @@ 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. -(defvar ediff-H-glyph (if (featurep 'xemacs) (make-glyph "H"))) +(defvar ediff-H-glyph nil) +(make-obsolete-variable 'ediff-H-glyph nil "28.1") ;; Temporary file used for refining difference regions in buffer A. @@ -1522,34 +1510,9 @@ This default should work without changes." (setq dir (substring dir 0 pos))) (ediff-abbreviate-file-name (file-name-directory dir)))) -(defun ediff-truncate-string-left (str newlen) - ;; leave space for ... on the left - (let ((len (length str)) - substr) - (if (<= len newlen) - str - (setq newlen (max 0 (- newlen 3))) - (setq substr (substring str (max 0 (- len 1 newlen)))) - (concat "..." substr)))) - (defsubst ediff-nonempty-string-p (string) (and (stringp string) (not (string= string "")))) -(unless (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))) - -(unless (fboundp 'format-message) - (defalias 'format-message 'format)) - (defun ediff-abbrev-jobname (jobname) (cond ((eq jobname 'ediff-directories) "Compare two directories") diff --git a/lisp/vc/ediff-mult.el b/lisp/vc/ediff-mult.el index fee87e8352e..2b1b07927f8 100644 --- a/lisp/vc/ediff-mult.el +++ b/lisp/vc/ediff-mult.el @@ -113,7 +113,6 @@ (require 'ediff-wind) (require 'ediff-util) - ;; meta-buffer (ediff-defvar-local ediff-meta-buffer nil "") (ediff-defvar-local ediff-parent-meta-buffer nil "") @@ -1172,7 +1171,7 @@ behavior." ;; abbreviate the file name, if file exists (if (and (not (stringp fname)) (< file-size -1)) "-------" ; file doesn't exist - (ediff-truncate-string-left + (string-truncate-left (ediff-abbreviate-file-name fname) max-filename-width))))))) @@ -1266,7 +1265,7 @@ Useful commands: (if (= (mod membership-code ediff-membership-code1) 0) ; dir1 (let ((beg (point))) (insert (format "%-27s" - (ediff-truncate-string-left + (string-truncate-left (ediff-abbreviate-file-name (if (file-directory-p (concat dir1 file)) (file-name-as-directory file) @@ -1281,7 +1280,7 @@ Useful commands: (if (= (mod membership-code ediff-membership-code2) 0) ; dir2 (let ((beg (point))) (insert (format "%-26s" - (ediff-truncate-string-left + (string-truncate-left (ediff-abbreviate-file-name (if (file-directory-p (concat dir2 file)) (file-name-as-directory file) @@ -1295,7 +1294,7 @@ Useful commands: (if (= (mod membership-code ediff-membership-code3) 0) ; dir3 (let ((beg (point))) (insert (format " %-25s" - (ediff-truncate-string-left + (string-truncate-left (ediff-abbreviate-file-name (if (file-directory-p (concat dir3 file)) (file-name-as-directory file) diff --git a/lisp/vc/ediff-ptch.el b/lisp/vc/ediff-ptch.el index cb0ae6ff6e1..f6af5a45550 100644 --- a/lisp/vc/ediff-ptch.el +++ b/lisp/vc/ediff-ptch.el @@ -119,7 +119,7 @@ patch. So, don't change these variables, unless the default doesn't work." (defcustom ediff-context-diff-label-regexp (let ((stuff "\\([^ \t\n]+\\)")) (concat "\\(" ; context diff 2-liner - "^\\*\\*\\* +" stuff "[^*]+[\t ]*\n--- +" stuff + "^\\*\\*\\* +" stuff "[^*]+\n--- +" stuff "\\|" ; unified format diff 2-liner "^--- +" stuff ".*\n\\+\\+\\+ +" stuff "\\)")) diff --git a/lisp/vc/ediff-util.el b/lisp/vc/ediff-util.el index a8af9ba37a2..4a84c1ecd9c 100644 --- a/lisp/vc/ediff-util.el +++ b/lisp/vc/ediff-util.el @@ -131,7 +131,6 @@ to invocation.") (define-key ediff-mode-map [delete] 'ediff-previous-difference) (define-key ediff-mode-map "\C-h" (if ediff-no-emacs-help-in-control-buffer 'ediff-previous-difference nil)) - ;; must come after C-h, or else C-h wipes out backspace's binding in XEmacs (define-key ediff-mode-map [backspace] 'ediff-previous-difference) (define-key ediff-mode-map [?\S-\ ] 'ediff-previous-difference) (define-key ediff-mode-map "n" 'ediff-next-difference) @@ -1540,10 +1539,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 @@ -3144,8 +3143,8 @@ Hit \\[ediff-recenter] to reset the windows afterward." (> (length p) 2)) (setq short-p (substring p 0 2))) - (setq f (concat ediff-temp-file-prefix p) - short-f (concat ediff-temp-file-prefix short-p) + (setq f (concat temporary-file-directory p) + short-f (concat temporary-file-directory short-p) f (cond (given-file) ((find-file-name-handler f 'insert-file-contents) ;; to thwart file name handlers in write-region, @@ -3449,7 +3448,6 @@ Without an argument, it saves customized diff argument, if available (declare-function ediff-regions-internal "ediff" (buffer-a beg-a end-a buffer-b beg-b end-b startup-hooks job-name word-mode setup-parameters)) -(defvar zmacs-regions) ;;XEmacs'ism. (defun ediff-inferior-compare-regions () "Compare regions in an active Ediff session. @@ -3461,7 +3459,6 @@ Ediff Control Panel to restore highlighting." (interactive) (let ((answer "") (possibilities (list ?A ?B ?C)) - (zmacs-regions t) use-current-diff-p begA begB endA endB bufA bufB) diff --git a/lisp/vc/ediff-vers.el b/lisp/vc/ediff-vers.el index a95606fad5e..4ee7ee5c1f5 100644 --- a/lisp/vc/ediff-vers.el +++ b/lisp/vc/ediff-vers.el @@ -49,15 +49,10 @@ comparison or merge operations are being performed." :group 'ediff-vers ) -(defalias 'ediff-vc-revision-other-window - (if (fboundp 'vc-revision-other-window) - 'vc-revision-other-window - 'vc-version-other-window)) - -(defalias 'ediff-vc-working-revision - (if (fboundp 'vc-working-revision) - 'vc-working-revision - 'vc-workfile-version)) +(define-obsolete-function-alias 'ediff-vc-revision-other-window + #'vc-revision-other-window "28.1") +(define-obsolete-function-alias 'ediff-vc-working-revision + #'vc-working-revision "28.1") ;; VC.el support @@ -88,12 +83,12 @@ comparison or merge operations are being performed." (setq rev1 (ediff-vc-latest-version (buffer-file-name)))) (save-window-excursion (save-excursion - (ediff-vc-revision-other-window rev1) + (vc-revision-other-window rev1) (setq rev1buf (current-buffer) file1 (buffer-file-name))) (save-excursion (or (string= rev2 "") ; use current buffer - (ediff-vc-revision-other-window rev2)) + (vc-revision-other-window rev2)) (setq rev2buf (current-buffer) file2 (buffer-file-name))) (push (lambda () @@ -165,18 +160,18 @@ comparison or merge operations are being performed." (let (buf1 buf2 ancestor-buf) (save-window-excursion (save-excursion - (ediff-vc-revision-other-window rev1) + (vc-revision-other-window rev1) (setq buf1 (current-buffer))) (save-excursion (or (string= rev2 "") - (ediff-vc-revision-other-window rev2)) + (vc-revision-other-window rev2)) (setq buf2 (current-buffer))) (if ancestor-rev (save-excursion (if (string= ancestor-rev "") - (setq ancestor-rev (ediff-vc-working-revision + (setq ancestor-rev (vc-working-revision buffer-file-name))) - (ediff-vc-revision-other-window ancestor-rev) + (vc-revision-other-window ancestor-rev) (setq ancestor-buf (current-buffer)))) (push (let ((f1 (buffer-file-name buf1)) (f2 (unless (string= rev2 "") (buffer-file-name buf2))) diff --git a/lisp/vc/ediff-wind.el b/lisp/vc/ediff-wind.el index 7b2e1109c87..a23d72070ab 100644 --- a/lisp/vc/ediff-wind.el +++ b/lisp/vc/ediff-wind.el @@ -156,12 +156,10 @@ In this case, Ediff will use those frames to display these buffers." '(name . "Ediff") ;;'(unsplittable . t) '(minibuffer . nil) - '(user-position . t) ; Emacs only - '(vertical-scroll-bars . nil) ; Emacs only - '(scrollbar-width . 0) ; XEmacs only - '(scrollbar-height . 0) ; XEmacs only - '(menu-bar-lines . 0) ; Emacs only - '(tool-bar-lines . 0) ; Emacs 21+ only + '(user-position . t) + '(vertical-scroll-bars . nil) + '(menu-bar-lines . 0) + '(tool-bar-lines . 0) '(left-fringe . 0) '(right-fringe . 0) ;; don't lower but auto-raise @@ -260,10 +258,9 @@ the frame used for the wide display.") This has effect only on a windowing system. If t, hitting `?' to toggle control panel off iconifies it. -This is only useful in Emacs and only for certain kinds of window managers, -such as TWM and its derivatives, since the window manager must permit -keyboard input to go into icons. XEmacs completely ignores keyboard input -into icons, regardless of the window manager." +This is only useful for certain kinds of window managers, such as +TWM and its derivatives, since the window manager must permit +keyboard input to go into icons." :type 'boolean) ;;; Functions @@ -952,8 +949,7 @@ create a new splittable frame if none is found." ;; just a precaution--we should be in ctl-buffer already (with-current-buffer ctl-buffer (make-local-variable 'frame-title-format) - (make-local-variable 'frame-icon-title-format) ; XEmacs - (make-local-variable 'icon-title-format)) ; Emacs + (make-local-variable 'icon-title-format)) (ediff-setup-control-buffer ctl-buffer) (setq dont-iconify-ctl-frame @@ -1098,6 +1094,7 @@ create a new splittable frame if none is found." ))) (defun ediff-xemacs-select-frame-hook () + (declare (obsolete nil "28.1")) (if (and (equal (selected-frame) ediff-control-frame) (not ediff-use-long-help-message)) (raise-frame ediff-control-frame))) diff --git a/lisp/vc/log-edit.el b/lisp/vc/log-edit.el index 906f9a94205..cd19b4e065b 100644 --- a/lisp/vc/log-edit.el +++ b/lisp/vc/log-edit.el @@ -51,6 +51,9 @@ ;; The main keymap +(define-obsolete-variable-alias 'vc-log-mode-map 'log-edit-mode-map "28.1") +(define-obsolete-variable-alias 'vc-log-entry-mode 'log-edit-mode-map "28.1") + (easy-mmode-defmap log-edit-mode-map '(("\C-c\C-c" . log-edit-done) ("\C-c\C-a" . log-edit-insert-changelog) @@ -67,10 +70,6 @@ "Keymap for the `log-edit-mode' (to edit version control log messages)." :group 'log-edit) -;; Compatibility with old names. Should we bother ? -(defvar vc-log-mode-map log-edit-mode-map) -(defvar vc-log-entry-mode vc-log-mode-map) - (easy-menu-define log-edit-menu log-edit-mode-map "Menu used for `log-edit-mode'." '("Log-Edit" diff --git a/lisp/vc/pcvs-parse.el b/lisp/vc/pcvs-parse.el index 466c621311f..dd56aec94a0 100644 --- a/lisp/vc/pcvs-parse.el +++ b/lisp/vc/pcvs-parse.el @@ -472,7 +472,7 @@ The remaining KEYS are passed directly to `cvs-create-fileinfo'." ;; Let's not get all worked up if the format changes a bit (cvs-match " *Working revision:.*$")) (cvs-or - (cvs-match " *RCS Version:[ \t]*\\([0-9.]+\\)[ \t]*.*$" (head-rev 1)) + (cvs-match " *RCS Version:[ \t]*\\([0-9.]+\\).*$" (head-rev 1)) (cvs-match " *Repository revision:[ \t]*\\([0-9.]+\\)[ \t]*\\(.*\\)$" (head-rev 1)) (cvs-match " *Repository revision:.*")) diff --git a/lisp/vc/smerge-mode.el b/lisp/vc/smerge-mode.el index 85868b91ecc..d0a83fd7c49 100644 --- a/lisp/vc/smerge-mode.el +++ b/lisp/vc/smerge-mode.el @@ -1429,15 +1429,16 @@ with a \\[universal-argument] prefix, makes up a 3-way conflict." (smerge-remove-props (point-min) (point-max)))) ;;;###autoload -(defun smerge-start-session () +(defun smerge-start-session (&optional interactively) "Turn on `smerge-mode' and move point to first conflict marker. If no conflict maker is found, turn off `smerge-mode'." - (interactive) - (smerge-mode 1) - (condition-case nil - (unless (looking-at smerge-begin-re) - (smerge-next)) - (error (smerge-auto-leave)))) + (interactive "p") + (when (or (null smerge-mode) interactively) + (smerge-mode 1) + (condition-case nil + (unless (looking-at smerge-begin-re) + (smerge-next)) + (error (smerge-auto-leave))))) (defcustom smerge-change-buffer-confirm t "If non-nil, request confirmation before moving to another buffer." diff --git a/lisp/vc/vc-bzr.el b/lisp/vc/vc-bzr.el index e5d307e7ede..f98730ed221 100644 --- a/lisp/vc/vc-bzr.el +++ b/lisp/vc/vc-bzr.el @@ -1316,6 +1316,15 @@ stream. Standard error output is discarded." vc-bzr-revision-keywords)) string pred))))) +(defun vc-bzr-repository-url (file-or-dir &optional _remote-name) + (let ((default-directory (vc-bzr-root file-or-dir))) + (with-temp-buffer + (vc-bzr-command "info" (current-buffer) 0 nil) + (goto-char (point-min)) + (if (re-search-forward "parent branch: \\(.*\\)$" nil t) + (match-string 1) + (error "Cannot determine Bzr repository URL"))))) + (provide 'vc-bzr) ;;; vc-bzr.el ends here diff --git a/lisp/vc/vc-dir.el b/lisp/vc/vc-dir.el index 38b4937e854..cdf8ab984e8 100644 --- a/lisp/vc/vc-dir.el +++ b/lisp/vc/vc-dir.el @@ -147,6 +147,12 @@ See `run-hooks'." '(menu-item "Unmark Previous " vc-dir-unmark-file-up :help "Move to the previous line and unmark the file")) + (define-key map [mark-unregistered] + '(menu-item "Mark Unregistered" vc-dir-mark-unregistered-files + :help "Mark all files in the unregistered state")) + (define-key map [mark-registered] + '(menu-item "Mark Registered" vc-dir-mark-registered-files + :help "Mark all files in the state edited, added or removed")) (define-key map [mark-all] '(menu-item "Mark All" vc-dir-mark-all-files :help "Mark all files that are in the same state as the current file\ @@ -310,6 +316,10 @@ See `run-hooks'." (define-key branch-map "l" 'vc-print-branch-log) (define-key branch-map "s" 'vc-retrieve-tag)) + (let ((mark-map (make-sparse-keymap))) + (define-key map "*" mark-map) + (define-key mark-map "r" 'vc-dir-mark-registered-files)) + ;; Hook up the menu. (define-key map [menu-bar vc-dir-mode] `(menu-item @@ -696,6 +706,38 @@ share the same state." (vc-dir-mark-file crt))) (setq crt (ewoc-next vc-ewoc crt)))))))) +(defun vc-dir-mark-files (mark-files) + "Mark files specified by file names in the argument MARK-FILES. +MARK-FILES should be a list of absolute filenames." + (ewoc-map + (lambda (filearg) + (when (member (expand-file-name (vc-dir-fileinfo->name filearg)) + mark-files) + (setf (vc-dir-fileinfo->marked filearg) t) + t)) + vc-ewoc)) + +(defun vc-dir-mark-state-files (states) + "Mark files that are in the state specified by the list in STATES." + (unless (listp states) + (setq states (list states))) + (ewoc-map + (lambda (filearg) + (when (memq (vc-dir-fileinfo->state filearg) states) + (setf (vc-dir-fileinfo->marked filearg) t) + t)) + vc-ewoc)) + +(defun vc-dir-mark-registered-files () + "Mark files that are in one of registered state: edited, added or removed." + (interactive) + (vc-dir-mark-state-files '(edited added removed))) + +(defun vc-dir-mark-unregistered-files () + "Mark files that are in unregistered state." + (interactive) + (vc-dir-mark-state-files 'unregistered)) + (defun vc-dir-unmark-file () ;; Unmark the current file and move to the next line. (let* ((crt (ewoc-locate vc-ewoc)) @@ -1064,6 +1106,7 @@ the *vc-dir* buffer. (set (make-local-variable 'vc-dir-backend) use-vc-backend) (set (make-local-variable 'desktop-save-buffer) 'vc-dir-desktop-buffer-misc-data) + (setq-local bookmark-make-record-function #'vc-dir-bookmark-make-record) (setq buffer-read-only t) (when (boundp 'tool-bar-map) (set (make-local-variable 'tool-bar-map) vc-dir-tool-bar-map)) @@ -1193,7 +1236,8 @@ Throw an error if another update process is in progress." (if remaining (vc-dir-refresh-files (mapcar 'vc-dir-fileinfo->name remaining)) - (setq mode-line-process nil)))))))))))) + (setq mode-line-process nil) + (run-hooks 'vc-dir-refresh-hook)))))))))))) (defun vc-dir-show-fileentry (file) "Insert an entry for a specific file into the current *VC-dir* listing. @@ -1287,6 +1331,16 @@ state of item at point, if any." (list vc-dir-backend files only-files-list state model))) ;;;###autoload +(defun vc-dir-root () + "Run `vc-dir' in the repository root directory without prompt. +If the default directory of the current buffer is +not under version control, prompt for a directory." + (interactive) + (let ((root-dir (vc-root-dir))) + (if root-dir (vc-dir root-dir) + (call-interactively 'vc-dir)))) + +;;;###autoload (defun vc-dir (dir &optional backend) "Show the VC status for \"interesting\" files in and below DIR. This allows you to mark files and perform VC operations on them. @@ -1309,7 +1363,7 @@ These are the commands available for use in the file status buffer: ;; When you hit C-x v d in a visited VC file, ;; the *vc-dir* buffer visits the directory under its truename; ;; therefore it makes sense to always do that. - ;; Otherwise if you do C-x v d -> C-x C-f -> C-c v d + ;; Otherwise if you do C-x v d -> C-x C-f -> C-x v d ;; you may get a new *vc-dir* buffer, different from the original (file-truename (read-directory-name "VC status for directory: " (vc-root-dir) nil t @@ -1413,6 +1467,42 @@ These are the commands available for use in the file status buffer: '(vc-dir-mode . vc-dir-restore-desktop-buffer)) +;;; Support for bookmark.el (adapted from what info.el does). + +(declare-function bookmark-make-record-default + "bookmark" (&optional no-file no-context posn)) +(declare-function bookmark-prop-get "bookmark" (bookmark prop)) +(declare-function bookmark-default-handler "bookmark" (bmk)) +(declare-function bookmark-get-bookmark-record "bookmark" (bmk)) + +(defun vc-dir-bookmark-make-record () + "Make record used to bookmark a `vc-dir' buffer. +This implements the `bookmark-make-record-function' type for +`vc-dir' buffers." + (let* ((bookmark-name + (concat "(" (symbol-name vc-dir-backend) ") " + (file-name-nondirectory + (directory-file-name default-directory)))) + (defaults (list bookmark-name default-directory))) + `(,bookmark-name + ,@(bookmark-make-record-default 'no-file) + (filename . ,default-directory) + (handler . vc-dir-bookmark-jump) + (defaults . ,defaults)))) + +;;;###autoload +(defun vc-dir-bookmark-jump (bmk) + "Provides the bookmark-jump behavior for a `vc-dir' buffer. +This implements the `handler' function interface for the record +type returned by `vc-dir-bookmark-make-record'." + (let* ((file (bookmark-prop-get bmk 'filename)) + (buf (progn ;; Don't use save-window-excursion (bug#39722) + (vc-dir file) + (current-buffer)))) + (bookmark-default-handler + `("" (buffer . ,buf) . ,(bookmark-get-bookmark-record bmk))))) + + (provide 'vc-dir) ;;; vc-dir.el ends here diff --git a/lisp/vc/vc-dispatcher.el b/lisp/vc/vc-dispatcher.el index 5ae300bf09b..4a04c9365a5 100644 --- a/lisp/vc/vc-dispatcher.el +++ b/lisp/vc/vc-dispatcher.el @@ -746,7 +746,8 @@ the buffer contents as a comment." (defun vc-dispatcher-browsing () "Are we in a directory browser buffer?" - (derived-mode-p 'vc-dir-mode)) + (or (derived-mode-p 'vc-dir-mode) + (derived-mode-p 'dired-mode))) ;; These are unused. ;; (defun vc-dispatcher-in-fileset-p (fileset) diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 61e6c642d1f..78a2fa08795 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -72,6 +72,7 @@ ;; by git, so it's probably ;; not a good idea. ;; - merge-news (file) see `merge-file' +;; - mark-resolved (file) OK ;; - steal-lock (file &optional revision) NOT NEEDED ;; HISTORY FUNCTIONS ;; * print-log (files buffer &optional shortlog start-revision limit) OK @@ -100,6 +101,7 @@ ;; - rename-file (old new) OK ;; - find-file-hook () OK ;; - conflicted-files OK +;; - repository-url (file-or-dir) OK ;;; Code: @@ -166,7 +168,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 @@ -241,7 +243,7 @@ toggle display of the entire list." ;; path specs. ;; See also: http://marc.info/?l=git&m=125787684318129&w=2 (name (file-relative-name file dir)) - (str (ignore-errors + (str (with-demoted-errors "Error: %S" (cd dir) (vc-git--out-ok "ls-files" "-c" "-z" "--" name) ;; If result is empty, use ls-tree to check for deleted @@ -733,6 +735,7 @@ or an empty string if none." (with-current-buffer standard-output (vc-git--out-ok "symbolic-ref" "HEAD")))) (stash-list (vc-git-stash-list)) + (default-directory dir) branch remote remote-url stash-button stash-string) (if (string-match "^\\(refs/heads/\\)?\\(.+\\)$" str) @@ -745,14 +748,8 @@ or an empty string if none." (concat "branch." branch ".remote"))))) (when (string-match "\\([^\n]+\\)" remote) (setq remote (match-string 1 remote))) - (when remote - (setq remote-url - (with-output-to-string - (with-current-buffer standard-output - (vc-git--out-ok "config" - (concat "remote." remote ".url")))))) - (when (string-match "\\([^\n]+\\)" remote-url) - (setq remote-url (match-string 1 remote-url)))) + (when (> (length remote) 0) + (setq remote-url (vc-git-repository-url dir remote)))) (setq branch "not (detached HEAD)")) (when stash-list (let* ((len (length stash-list)) @@ -807,7 +804,7 @@ or an empty string if none." (propertize "Branch : " 'face 'font-lock-type-face) (propertize branch 'face 'font-lock-variable-name-face) - (when remote + (when remote-url (concat "\n" (propertize "Remote : " 'face 'font-lock-type-face) @@ -819,10 +816,10 @@ or an empty string if none." (when (file-exists-p (expand-file-name ".git/rebase-apply" (vc-git-root dir))) (propertize "\nRebase : in progress" 'face 'font-lock-warning-face)) (if stash-list - (concat - (propertize "\nStash : " 'face 'font-lock-type-face) - stash-button - stash-string) + (concat + (propertize "\nStash : " 'face 'font-lock-type-face) + stash-button + stash-string) (concat (propertize "\nStash : " 'face 'font-lock-type-face) (propertize "Nothing stashed" @@ -1081,6 +1078,13 @@ This prompts for a branch to merge from." "DU" "AA" "UU")) (push (expand-file-name file directory) files))))))) +(defun vc-git-repository-url (file-or-dir &optional remote-name) + (let ((default-directory (vc-git-root file-or-dir))) + (with-temp-buffer + (vc-git-command (current-buffer) 0 nil "remote" "get-url" + (or remote-name "origin")) + (buffer-substring-no-properties (point-min) (1- (point-max)))))) + ;; Everywhere but here, follows vc-git-command, which uses vc-do-command ;; from vc-dispatcher. (autoload 'vc-resynch-buffer "vc-dispatcher") @@ -1233,7 +1237,7 @@ log entries." (set (make-local-variable 'log-view-message-re) (if (not (memq vc-log-view-type '(long log-search with-diff))) (cadr vc-git-root-log-format) - "^commit *\\([0-9a-z]+\\)")) + "^commit +\\([0-9a-z]+\\)")) ;; Allow expanding short log entries. (when (memq vc-log-view-type '(short log-outgoing log-incoming mergebase)) (setq truncate-lines t) @@ -1262,7 +1266,7 @@ log entries." ("^Merge: \\([0-9a-z]+\\) \\([0-9a-z]+\\)" (1 'change-log-acknowledgment) (2 'change-log-acknowledgment)) - ("^Date: \\(.+\\)" (1 'change-log-date)) + ("^\\(?:Date: \\|AuthorDate: \\)\\(.+\\)" (1 'change-log-date)) ("^summary:[ \t]+\\(.+\\)" (1 'log-view-message))))))) @@ -1530,6 +1534,9 @@ This requires git 1.8.4 or later, for the \"-L\" option of \"git log\"." (defun vc-git-rename-file (old new) (vc-git-command nil 0 (list old new) "mv" "-f" "--")) +(defun vc-git-mark-resolved (files) + (vc-git-command nil 0 files "add")) + (defvar vc-git-extra-menu-map (let ((map (make-sparse-keymap))) (define-key map [git-grep] diff --git a/lisp/vc/vc-hg.el b/lisp/vc/vc-hg.el index d00b69c0d08..cb0657e70a0 100644 --- a/lisp/vc/vc-hg.el +++ b/lisp/vc/vc-hg.el @@ -182,10 +182,20 @@ 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") +(defcustom vc-hg-create-bookmark t + "This controls whether `vc-create-tag' will create a bookmark or branch. +If nil, named branch will be created. +If t, bookmark will be created. +If `ask', you will be prompted for a branch type." + :type '(choice (const :tag "No" nil) + (const :tag "Yes" t) + (const :tag "Ask" ask)) + :version "28.1") + ;; Clear up the cache to force vc-call to check again and discover ;; new functions when we reload this file. @@ -625,10 +635,18 @@ Optional arg REVISION is a revision to annotate from." ;;; Tag system (defun vc-hg-create-tag (dir name branchp) - "Attach the tag NAME to the state of the working copy." + "Create tag NAME in repo in DIR. Create branch if BRANCHP. +Variable `vc-hg-create-bookmark' controls what kind of branch will be created." (let ((default-directory dir)) - (and (vc-hg-command nil 0 nil "status") - (vc-hg-command nil 0 nil (if branchp "bookmark" "tag") name)))) + (vc-hg-command nil 0 nil + (if branchp + (if (if (eq vc-hg-create-bookmark 'ask) + (yes-or-no-p "Create bookmark instead of branch? ") + vc-hg-create-bookmark) + "bookmark" + "branch") + "tag") + name))) (defun vc-hg-retrieve-tag (dir name _update) "Retrieve the version tagged by NAME of all registered files at or below DIR." @@ -1366,25 +1384,28 @@ REV is the revision to check out into WORKFILE." (vc-run-delayed (vc-hg-after-dir-status update-function))) -(defun vc-hg-dir-extra-header (name &rest commands) - (concat (propertize name 'face 'font-lock-type-face) - (propertize - (with-temp-buffer - (apply 'vc-hg-command (current-buffer) 0 nil commands) - (buffer-substring-no-properties (point-min) (1- (point-max)))) - 'face 'font-lock-variable-name-face))) - (defun vc-hg-dir-extra-headers (dir) - "Generate extra status headers for a Mercurial tree." + "Generate extra status headers for a repository in DIR. +This runs the command \"hg summary\"." (let ((default-directory dir)) - (concat - (vc-hg-dir-extra-header "Root : " "root") "\n" - (vc-hg-dir-extra-header "Branch : " "id" "-b") "\n" - (vc-hg-dir-extra-header "Tags : " "id" "-t") ; "\n" - ;; these change after each commit - ;; (vc-hg-dir-extra-header "Local num : " "id" "-n") "\n" - ;; (vc-hg-dir-extra-header "Global id : " "id" "-i") - ))) + (with-temp-buffer + (vc-hg-command t 0 nil "summary") + (goto-char (point-min)) + (mapconcat + #'identity + (let (result) + (while (not (eobp)) + (push + (let ((entry (if (looking-at "\\([^ ].*\\): \\(.*\\)") + (cons (capitalize (match-string 1)) (match-string 2)) + (cons "" (buffer-substring (point) (line-end-position)))))) + (concat + (propertize (format "%-11s: " (car entry)) 'face 'font-lock-type-face) + (propertize (cdr entry) 'face 'font-lock-variable-name-face))) + result) + (forward-line)) + (nreverse result)) + "\n")))) (defun vc-hg-log-incoming (buffer remote-location) (vc-setup-buffer buffer) @@ -1525,6 +1546,14 @@ This function differs from vc-do-command in that it invokes (defun vc-hg-root (file) (vc-find-root file ".hg")) +(defun vc-hg-repository-url (file-or-dir &optional remote-name) + (let ((default-directory (vc-hg-root file-or-dir))) + (with-temp-buffer + (vc-hg-command (current-buffer) 0 nil + "config" + (concat "paths." (or remote-name "default"))) + (buffer-substring-no-properties (point-min) (1- (point-max)))))) + (provide 'vc-hg) ;;; vc-hg.el ends here diff --git a/lisp/vc/vc-hooks.el b/lisp/vc/vc-hooks.el index 345a28d3f1d..ce72a49b955 100644 --- a/lisp/vc/vc-hooks.el +++ b/lisp/vc/vc-hooks.el @@ -498,7 +498,7 @@ status of this file. Otherwise, the value returned is one of: "Return the repository version from which FILE was checked out. If FILE is not registered, this function always returns nil." (or (vc-file-getprop file 'vc-working-revision) - (progn + (let ((default-directory (file-name-directory file))) (setq backend (or backend (vc-backend file))) (when backend (vc-file-setprop file 'vc-working-revision @@ -972,9 +972,9 @@ In the latter case, VC mode is deactivated for this buffer." (bindings--define-key map [vc-ignore] '(menu-item "Ignore File..." vc-ignore :help "Ignore a file under current version control system")) - (bindings--define-key map [vc-dir] - '(menu-item "VC Dir" vc-dir - :help "Show the VC status of files in a directory")) + (bindings--define-key map [vc-dir-root] + '(menu-item "VC Dir" vc-dir-root + :help "Show the VC status of the repository")) map)) (defalias 'vc-menu-map vc-menu-map) diff --git a/lisp/vc/vc-rcs.el b/lisp/vc/vc-rcs.el index 273f37c10d6..23f088b0cff 100644 --- a/lisp/vc/vc-rcs.el +++ b/lisp/vc/vc-rcs.el @@ -312,7 +312,7 @@ whether to remove it." (and (string= (file-name-nondirectory (directory-file-name dir)) "RCS") ;; check whether RCS dir is empty, i.e. it does not ;; contain any files except "." and ".." - (not (directory-files dir nil (rx (or (not ".") "...")))) + (not (directory-files dir nil directory-files-no-dot-files-regexp)) (yes-or-no-p (format "Directory %s is empty; remove it? " dir)) (delete-directory dir))))) diff --git a/lisp/vc/vc-src.el b/lisp/vc/vc-src.el index db127ee726d..4eb638978a9 100644 --- a/lisp/vc/vc-src.el +++ b/lisp/vc/vc-src.el @@ -146,6 +146,20 @@ For a description of possible values, see `vc-check-master-templates'." (progn (defun vc-src-registered (f) (vc-default-registered 'src f))) +(defun vc-src--parse-state (out) + (when (null (string-match "does not exist or is unreadable" out)) + (let ((state (aref out 0))) + (cond + ;; FIXME: What to do about L code? + ((eq state ?.) 'up-to-date) + ((eq state ?A) 'added) + ((eq state ?M) 'edited) + ((eq state ?I) 'ignored) + ((eq state ?R) 'removed) + ((eq state ?!) 'missing) + ((eq state ??) 'unregistered) + (t 'up-to-date))))) + (defun vc-src-state (file) "SRC-specific version of `vc-state'." (let* @@ -163,32 +177,41 @@ For a description of possible values, see `vc-check-master-templates'." "status" "-a" (file-relative-name file)) (error nil))))))) (when (eq 0 status) - (when (null (string-match "does not exist or is unreadable" out)) - (let ((state (aref out 0))) - (cond - ;; FIXME: What to do about A and L codes? - ((eq state ?.) 'up-to-date) - ((eq state ?A) 'added) - ((eq state ?M) 'edited) - ((eq state ?I) 'ignored) - ((eq state ?R) 'removed) - ((eq state ?!) 'missing) - ((eq state ??) 'unregistered) - (t 'up-to-date))))))) + (vc-src--parse-state out)))) (autoload 'vc-expand-dirs "vc") (defun vc-src-dir-status-files (dir files update-function) - ;; FIXME: Use one src status -a call for this - (if (not files) (setq files (vc-expand-dirs (list dir) 'SRC))) - (let ((result nil)) - (dolist (file files) - (let ((state (vc-state file)) - (frel (file-relative-name file))) - (when (and (eq (vc-backend file) 'SRC) - (not (eq state 'up-to-date))) - (push (list frel state) result)))) - (funcall update-function result))) + (let* ((result nil) + (status nil) + (default-directory (or dir default-directory)) + (out + (with-output-to-string + (with-current-buffer standard-output + (setq status + (ignore-errors + (apply + #'process-file vc-src-program nil t nil + "status" "-a" + (mapcar #'file-relative-name files))))))) + dlist) + (when (eq 0 status) + (dolist (line (split-string out "[\n\r]" t)) + (let* ((pair (split-string line "[\t]" t)) + (state (vc-src--parse-state (car pair))) + (frel (cadr pair))) + (if (file-directory-p frel) + (push frel dlist) + (when (not (eq state 'up-to-date)) + (push (list frel state) result))))) + (dolist (drel dlist) + (let ((dresult (vc-src-dir-status-files + (expand-file-name drel) nil #'identity))) + (dolist (dres dresult) + (push (list (concat (file-name-as-directory drel) (car dres)) + (cadr dres)) + result)))) + (funcall update-function result)))) (defun vc-src-command (buffer file-or-list &rest flags) "A wrapper around `vc-do-command' for use in vc-src.el. diff --git a/lisp/vc/vc-svn.el b/lisp/vc/vc-svn.el index d039bf3c6a3..e108b3a340f 100644 --- a/lisp/vc/vc-svn.el +++ b/lisp/vc/vc-svn.el @@ -816,7 +816,14 @@ Set file properties accordingly. If FILENAME is non-nil, return its status." (push (match-string 1 loglines) vc-svn-revisions) (setq start (+ start (match-end 0))) (setq loglines (buffer-substring-no-properties start (point-max))))) - vc-svn-revisions))) + vc-svn-revisions))) + +(defun vc-svn-repository-url (file-or-dir &optional _remote-name) + (let ((default-directory (vc-svn-root file-or-dir))) + (with-temp-buffer + (vc-svn-command (current-buffer) 0 nil + "info" "--show-item" "repos-root-url") + (buffer-substring-no-properties (point-min) (1- (point-max)))))) (provide 'vc-svn) diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index fe666413168..65775f8e46e 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -553,6 +553,13 @@ ;; Return the list of files where conflict resolution is needed in ;; the project that contains DIR. ;; FIXME: what should it do with non-text conflicts? +;; +;; - repository-url (file-or-dir &optional remote-name) +;; +;; Returns the URL of the repository of the current checkout +;; containing FILE-OR-DIR. The optional REMOTE-NAME specifies the +;; remote (in Git parlance) whose URL is to be returned. It has +;; only a meaning for distributed VCS and is ignored otherwise. ;;; Changes from the pre-25.1 API: ;; @@ -957,7 +964,7 @@ use." (throw 'found bk)))) ;;;###autoload -(defun vc-responsible-backend (file) +(defun vc-responsible-backend (file &optional no-error) "Return the name of a backend system that is responsible for FILE. If FILE is already registered, return the @@ -967,7 +974,10 @@ responsible for FILE is returned. Note that if FILE is a symbolic link, it will not be resolved -- the responsible backend system for the symbolic link itself will -be reported." +be reported. + +If NO-ERROR is nil, signal an error that no VC backend is +responsible for the given file." (or (and (not (file-directory-p file)) (vc-backend file)) (catch 'found ;; First try: find a responsible backend. If this is for registration, @@ -975,7 +985,8 @@ be reported." (dolist (backend vc-handled-backends) (and (vc-call-backend backend 'responsible-p file) (throw 'found backend)))) - (error "No VC backend is responsible for %s" file))) + (unless no-error + (error "No VC backend is responsible for %s" file)))) (defun vc-expand-dirs (file-or-dir-list backend) "Expands directories in a file list specification. @@ -1006,35 +1017,47 @@ Within directories, only files already under version control are noticed." (declare-function vc-dir-current-file "vc-dir" ()) (declare-function vc-dir-deduce-fileset "vc-dir" (&optional state-model-only-files)) +(declare-function dired-vc-deduce-fileset "dired-aux" (&optional state-model-only-files not-state-changing)) -(defun vc-deduce-fileset (&optional observer allow-unregistered +(defun vc-deduce-fileset (&optional not-state-changing + allow-unregistered state-model-only-files) "Deduce a set of files and a backend to which to apply an operation. -Return (BACKEND FILESET FILESET-ONLY-FILES STATE CHECKOUT-MODEL). +Return a list of the form: + + (BACKEND FILESET FILESET-ONLY-FILES STATE CHECKOUT-MODEL) -If we're in VC-dir mode, FILESET is the list of marked files, -or the directory if no files are marked. -Otherwise, if in a buffer visiting a version-controlled file, -FILESET is a single-file fileset containing that file. +where the last 3 members are optional, and must be present only if +STATE-MODEL-ONLY-FILES is non-nil. + +NOT-STATE-CHANGING, if non-nil, means that the operation +requesting the fileset doesn't intend to change the VC state, +such as when printing the log or showing the diffs. + +If the current buffer is in `vc-dir' or Dired mode, FILESET is the +list of marked files, or the current directory if no files are +marked. +Otherwise, if the current buffer is visiting a version-controlled +file, FILESET is a single-file list containing that file's name. Otherwise, if ALLOW-UNREGISTERED is non-nil and the visited file -is unregistered, FILESET is a single-file fileset containing it. +is unregistered, FILESET is a single-file list containing the +name of the visited file. Otherwise, throw an error. -STATE-MODEL-ONLY-FILES if non-nil, means that the caller needs -the FILESET-ONLY-FILES STATE and MODEL info. Otherwise, that -part may be skipped. +STATE-MODEL-ONLY-FILES, if non-nil, means that the caller needs +the FILESET-ONLY-FILES, STATE, and CHECKOUT-MODEL info, where +FILESET-ONLY-FILES means only files in similar VC states, +possible values of STATE are explained in `vc-state', and MODEL in +`vc-checkout-model'. Otherwise, these 3 members may be omitted from +the returned list. BEWARE: this function may change the current buffer." - ;; FIXME: OBSERVER is unused. The name is not intuitive and is not - ;; documented. It's set to t when called from diff and print-log. (let (backend) (cond ((derived-mode-p 'vc-dir-mode) (vc-dir-deduce-fileset state-model-only-files)) ((derived-mode-p 'dired-mode) - (if observer - (vc-dired-deduce-fileset) - (error "State changing VC operations not supported in `dired-mode'"))) + (dired-vc-deduce-fileset state-model-only-files not-state-changing)) ((setq backend (vc-backend buffer-file-name)) (if state-model-only-files (list backend (list buffer-file-name) @@ -1046,15 +1069,14 @@ BEWARE: this function may change the current buffer." ;; FIXME: Why this test? --Stef (or (buffer-file-name vc-parent-buffer) (with-current-buffer vc-parent-buffer - (derived-mode-p 'vc-dir-mode)))) + (or (derived-mode-p 'vc-dir-mode) + (derived-mode-p 'dired-mode))))) (progn ;FIXME: Why not `with-current-buffer'? --Stef. (set-buffer vc-parent-buffer) - (vc-deduce-fileset observer allow-unregistered state-model-only-files))) - ((and (derived-mode-p 'log-view-mode) + (vc-deduce-fileset not-state-changing allow-unregistered state-model-only-files))) + ((and (not buffer-file-name) (setq backend (vc-responsible-backend default-directory))) (list backend nil)) - ((not buffer-file-name) - (error "Buffer %s is not associated with a file" (buffer-name))) ((and allow-unregistered (not (vc-registered buffer-file-name))) (if state-model-only-files (list (vc-backend-for-registration (buffer-file-name)) @@ -1066,10 +1088,6 @@ BEWARE: this function may change the current buffer." (list buffer-file-name)))) (t (error "File is not under version control"))))) -(defun vc-dired-deduce-fileset () - (list (vc-responsible-backend default-directory) - (dired-map-over-marks (dired-get-filename nil t) nil))) - (defun vc-ensure-vc-buffer () "Make sure that the current buffer visits a version-controlled file." (cond @@ -2537,15 +2555,17 @@ with its diffs (if the underlying VCS supports that)." ;;;###autoload (defun vc-print-branch-log (branch) - "Show the change log for BRANCH in a window." + "Show the change log for BRANCH root in a window." (interactive (list (vc-read-revision "Branch to log: "))) (when (equal branch "") (error "No branch specified")) - (vc-print-log-internal (vc-responsible-backend default-directory) - (list default-directory) branch t - (when (> vc-log-show-limit 0) vc-log-show-limit))) + (let* ((backend (vc-responsible-backend default-directory)) + (rootdir (vc-call-backend backend 'root default-directory))) + (vc-print-log-internal backend + (list rootdir) branch t + (when (> vc-log-show-limit 0) vc-log-show-limit)))) ;;;###autoload (defun vc-log-incoming (&optional remote-location) diff --git a/lisp/version.el b/lisp/version.el index bf666cbff99..b247232dcfd 100644 --- a/lisp/version.el +++ b/lisp/version.el @@ -1,4 +1,4 @@ -;;; version.el --- record version number of Emacs +;;; version.el --- record version number of Emacs -*- lexical-binding:t -*- ;; Copyright (C) 1985, 1992, 1994-1995, 1999-2020 Free Software ;; Foundation, Inc. @@ -123,7 +123,7 @@ or if we could not determine the revision.") (looking-at "[[:xdigit:]]\\{40\\}")) (match-string 0))))) -(defun emacs-repository-get-version (&optional dir external) +(defun emacs-repository-get-version (&optional dir _external) "Try to return as a string the repository revision of the Emacs sources. The format of the returned string is dependent on the VCS in use. Value is nil if the sources do not seem to be under version diff --git a/lisp/vt100-led.el b/lisp/vt100-led.el index 7552fbb99c1..1e81dd241f1 100644 --- a/lisp/vt100-led.el +++ b/lisp/vt100-led.el @@ -1,4 +1,4 @@ -;;; vt100-led.el --- functions for LED control on VT-100 terminals & clones +;;; vt100-led.el --- functions for LED control on VT-100 terminals & clones -*- lexical-binding:t -*- ;; Copyright (C) 1988, 2001-2020 Free Software Foundation, Inc. diff --git a/lisp/w32-fns.el b/lisp/w32-fns.el index 8a816da1f2c..c252c0b18f8 100644 --- a/lisp/w32-fns.el +++ b/lisp/w32-fns.el @@ -238,14 +238,18 @@ bit output with no translation." ;; value from x-select-font etc, so list the most important charsets last. (w32-add-charset-info "iso8859-14" 'w32-charset-ansi 28604) (w32-add-charset-info "iso8859-15" 'w32-charset-ansi 28605) + (w32-add-charset-info "iso8859-16" 'w32-charset-ansi 28606) ;; The following two are included for pattern matching. (w32-add-charset-info "jisx0201" 'w32-charset-shiftjis 932) (w32-add-charset-info "jisx0208" 'w32-charset-shiftjis 932) (w32-add-charset-info "jisx0201-latin" 'w32-charset-shiftjis 932) (w32-add-charset-info "jisx0201-katakana" 'w32-charset-shiftjis 932) + (w32-add-charset-info "jisx0212" 'w32-charset-shiftjis 932) (w32-add-charset-info "ksc5601.1989" 'w32-charset-hangeul 949) + (w32-add-charset-info "ksx1001" 'w32-charset-hangeul 949) (w32-add-charset-info "big5" 'w32-charset-chinesebig5 950) (w32-add-charset-info "gb2312.1980" 'w32-charset-gb2312 936) + (w32-add-charset-info "gbk" 'w32-charset-gb2312 936) (w32-add-charset-info "ms-symbol" 'w32-charset-symbol nil) (w32-add-charset-info "ms-oem" 'w32-charset-oem 437) (w32-add-charset-info "ms-oemlatin" 'w32-charset-oem 850) @@ -258,9 +262,12 @@ bit output with no translation." (w32-add-charset-info "iso8859-9" 'w32-charset-turkish 1254) (w32-add-charset-info "iso8859-13" 'w32-charset-baltic 1257) (w32-add-charset-info "koi8-r" 'w32-charset-russian 20866) + (w32-add-charset-info "microsoft-cp1251" 'w32-charset-russian 1251) + (w32-add-charset-info "windows-1251" 'w32-charset-russian 1251) (w32-add-charset-info "tis620-2533" 'w32-charset-russian 28595) (w32-add-charset-info "iso8859-11" 'w32-charset-thai 874) (w32-add-charset-info "windows-1258" 'w32-charset-vietnamese 1258) + (w32-add-charset-info "viscii" 'w32-charset-vietnamese 1258) (w32-add-charset-info "ksc5601.1992" 'w32-charset-johab 1361) (w32-add-charset-info "mac-roman" 'w32-charset-mac 10000) (w32-add-charset-info "iso10646-1" 'w32-charset-default t) diff --git a/lisp/w32-vars.el b/lisp/w32-vars.el index 307490dc4b0..642a48446ef 100644 --- a/lisp/w32-vars.el +++ b/lisp/w32-vars.el @@ -1,4 +1,4 @@ -;;; w32-vars.el --- MS-Windows specific user options +;;; w32-vars.el --- MS-Windows specific user options -*- lexical-binding:t -*- ;; Copyright (C) 2002-2020 Free Software Foundation, Inc. @@ -44,22 +44,19 @@ after changing the value of this variable." :type 'boolean :set (lambda (symbol value) (set symbol value) - (setq mouse-appearance-menu-map nil)) - :group 'w32) + (setq mouse-appearance-menu-map nil))) (unless (eq system-type 'cygwin) (defcustom w32-allow-system-shell nil "Disable startup warning when using \"system\" shells." - :type 'boolean - :group 'w32)) + :type 'boolean)) (unless (eq system-type 'cygwin) (defcustom w32-system-shells '("cmd" "cmd.exe" "command" "command.com" "4nt" "4nt.exe" "4dos" "4dos.exe" "tcc" "tcc.exe" "ndos" "ndos.exe") "List of strings recognized as Windows system shells." - :type '(repeat string) - :group 'w32)) + :type '(repeat string))) ;; Want "menu" custom type for this. (defcustom w32-fixed-font-alist @@ -149,8 +146,7 @@ menu if the variable `w32-use-w32-font-dialog' is nil." (const :tag "Separator" ("")) (list :tag "Font Entry" (string :tag "Menu text") - (string :tag "Font"))))))) - :group 'w32) + (string :tag "Font")))))))) (make-obsolete-variable 'w32-enable-synthesized-fonts nil "24.4") diff --git a/lisp/wdired.el b/lisp/wdired.el index d91853e64dd..b98becfafe7 100644 --- a/lisp/wdired.el +++ b/lisp/wdired.el @@ -4,7 +4,7 @@ ;; Filename: wdired.el ;; Author: Juan León Lahoz GarcÃa <juanleon1@gmail.com> -;; Version: 2.0 +;; Old-Version: 2.0 ;; Keywords: dired, environment, files, renaming ;; This file is part of GNU Emacs. @@ -609,7 +609,10 @@ Optional arguments are ignored." (defun wdired--restore-dired-filename-prop (beg end _len) (save-match-data (save-excursion - (let ((lep (line-end-position))) + (let ((lep (line-end-position)) + (used-F (dired-check-switches + dired-actual-switches + "F" "classify"))) (beginning-of-line) (when (re-search-forward directory-listing-before-filename-regexp lep t) @@ -623,13 +626,17 @@ Optional arguments are ignored." (and (re-search-backward dired-permission-flags-regexp nil t) (looking-at "l") - (search-forward " -> " lep t)) + ;; macOS and Ultrix adds "@" to the end + ;; of symlinks when using -F. + (if (and used-F + dired-ls-F-marks-symlinks) + (re-search-forward "@? -> " lep t) + (search-forward " -> " lep t))) ;; When dired-listing-switches includes "F" ;; or "classify", don't treat appended ;; indicator characters as part of the file ;; name (bug#34915). - (and (dired-check-switches dired-actual-switches - "F" "classify") + (and used-F (re-search-forward "[*/@|=>]$" lep t))) (goto-char (match-beginning 0)) lep)) @@ -640,6 +647,7 @@ Optional arguments are ignored." See `wdired-use-dired-vertical-movement'. Optional prefix ARG says how many lines to move; default is one line." (interactive "^p") + (setq this-command 'next-line) ;Let `line-move' preserve the column. (with-no-warnings (next-line arg)) (if (or (eq wdired-use-dired-vertical-movement t) (and wdired-use-dired-vertical-movement @@ -653,6 +661,7 @@ says how many lines to move; default is one line." See `wdired-use-dired-vertical-movement'. Optional prefix ARG says how many lines to move; default is one line." (interactive "^p") + (setq this-command 'previous-line) ;Let `line-move' preserve the column. (with-no-warnings (previous-line arg)) (if (or (eq wdired-use-dired-vertical-movement t) (and wdired-use-dired-vertical-movement diff --git a/lisp/whitespace.el b/lisp/whitespace.el index db7c023324b..8a1bb8ade87 100644 --- a/lisp/whitespace.el +++ b/lisp/whitespace.el @@ -262,7 +262,7 @@ ;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; code: +;;; Code: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -283,7 +283,8 @@ '(face tabs spaces trailing lines space-before-tab newline indentation empty space-after-tab - space-mark tab-mark newline-mark) + space-mark tab-mark newline-mark + missing-newline-at-eof) "Specify which kind of blank is visualized. It's a list containing some or all of the following values: @@ -326,6 +327,11 @@ It's a list containing some or all of the following values: It has effect only if `face' (see above) is present in `whitespace-style'. + missing-newline-at-eof Missing newline at the end of the file is + visualized via faces. + It has effect only if `face' (see above) + is present in `whitespace-style'. + empty empty lines at beginning and/or end of buffer are visualized via faces. It has effect only if `face' (see above) @@ -586,6 +592,10 @@ line. Used when `whitespace-style' includes the value `indentation'.") "Face used to visualize big indentation." :group 'whitespace) +(defface whitespace-missing-newline-at-eof + '((((class mono)) :inverse-video t :weight bold :underline t) + (t :background "#d0d040" :foreground "black")) + "Face used to visualize missing newline at the end of the file.") (defvar whitespace-empty 'whitespace-empty "Symbol face used to visualize empty lines at beginning and/or end of buffer. @@ -716,8 +726,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 +757,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 @@ -1700,6 +1710,8 @@ cleaning up these problems." (whitespace-space-after-tab-regexp 'tab)) ((eq (car option) 'space-after-tab::space) (whitespace-space-after-tab-regexp 'space)) + ((eq (car option) 'missing-newline-at-eof) + "[^\n]\\'") (t (cdr option))))) (when (re-search-forward regexp rend t) @@ -2067,16 +2079,7 @@ resultant list will be returned." ,@(when (or (memq 'lines whitespace-active-style) (memq 'lines-tail whitespace-active-style)) ;; Show "long" lines. - `((,(let ((line-column (or whitespace-line-column fill-column))) - (format - "^\\([^\t\n]\\{%s\\}\\|[^\t\n]\\{0,%s\\}\t\\)\\{%d\\}%s\\(.+\\)$" - tab-width - (1- tab-width) - (/ line-column tab-width) - (let ((rem (% line-column tab-width))) - (if (zerop rem) - "" - (format ".\\{%d\\}" rem))))) + `((,#'whitespace-lines-regexp ,(if (memq 'lines whitespace-active-style) 0 ; whole line 2) ; line tail @@ -2131,7 +2134,16 @@ resultant list will be returned." ((memq 'space-after-tab::space whitespace-active-style) ;; Show SPACEs after TAB (TABs). (whitespace-space-after-tab-regexp 'space))) - 1 whitespace-space-after-tab t))))) + 1 whitespace-space-after-tab t))) + ,@(when (memq 'missing-newline-at-eof whitespace-active-style) + ;; Show missing newline. + `(("[^\n]\\'" 0 + ;; Don't mark the end of the buffer is point is there -- + ;; it probably means that the user is typing something + ;; at the end of the buffer. + (and (/= whitespace-point (point-max)) + 'whitespace-missing-newline-at-eof) + t))))) (font-lock-add-keywords nil whitespace-font-lock-keywords t) (font-lock-flush))) @@ -2177,6 +2189,19 @@ resultant list will be returned." (setq status nil))) ;; end of buffer status)) +(defun whitespace-lines-regexp (limit) + (re-search-forward + (let ((line-column (or whitespace-line-column fill-column))) + (format + "^\\([^\t\n]\\{%s\\}\\|[^\t\n]\\{0,%s\\}\t\\)\\{%d\\}%s\\(.+\\)$" + tab-width + (1- tab-width) + (/ line-column tab-width) + (let ((rem (% line-column tab-width))) + (if (zerop rem) + "" + (format ".\\{%d\\}" rem))))) + limit t)) (defun whitespace-empty-at-bob-regexp (limit) "Match spaces at beginning of buffer which do not contain the point at \ diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index 62846523be4..ea7e266e0d0 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. ;; @@ -594,6 +577,63 @@ respectively." (if (and widget (funcall function widget maparg)) (setq overlays nil))))) +(defun widget-describe (&optional widget-or-pos) + "Describe the widget at point. +Displays a buffer with information about the widget (e.g., its actions) as well +as a link to browse all the properties of the widget. + +This command resolves the indirection of widgets running the action of its +parents, so the real action executed can be known. + +When called from Lisp, pass WIDGET-OR-POS as the widget to describe, +or a buffer position where a widget is present. If WIDGET-OR-POS is nil, +the widget at point is the widget to describe." + (interactive "d") + (require 'wid-browse) ; The widget-browse widget. + (let ((widget (if (widgetp widget-or-pos) + widget-or-pos + (widget-at widget-or-pos))) + props) + (when widget + (help-setup-xref (list #'widget-describe widget) + (called-interactively-p 'interactive)) + (setq props (list (cons 'action (widget--resolve-parent-action widget)) + (cons 'mouse-down-action + (widget-get widget :mouse-down-action)))) + (with-help-window (help-buffer) + (with-current-buffer (help-buffer) + (widget-insert "This widget's type is ") + (widget-create 'widget-browse :format "%[%v%]\n%d" + :doc (get (car widget) 'widget-documentation) + :help-echo "Browse this widget's properties" + widget) + (dolist (action '(action mouse-down-action)) + (let ((name (symbol-name action)) + (val (alist-get action props))) + (when (functionp val) + (widget-insert "\n\n" (propertize (capitalize name) 'face 'bold) + "'\nThe " name " of this widget is") + (if (symbolp val) + (progn (widget-insert " ") + (widget-create 'function-link :value val + :button-prefix "" :button-suffix "" + :help-echo "Describe this function")) + (widget-insert "\n") + (princ val))))))) + (widget-setup) + t))) + +(defun widget--resolve-parent-action (widget) + "Resolve the real action of WIDGET up its inheritance chain. +Follow the WIDGET's parents, until its :action is no longer +`widget-parent-action', and return its value." + (let ((action (widget-get widget :action)) + (parent (widget-get widget :parent))) + (while (eq action 'widget-parent-action) + (setq parent (widget-get parent :parent) + action (widget-get parent :action))) + action)) + ;;; Images. (defcustom widget-image-directory (file-name-as-directory diff --git a/lisp/windmove.el b/lisp/windmove.el index 6e62e161548..65579600640 100644 --- a/lisp/windmove.el +++ b/lisp/windmove.el @@ -461,50 +461,38 @@ select the window with a displayed buffer, and the meaning of the prefix argument is reversed. When `switch-to-buffer-obey-display-actions' is non-nil, `switch-to-buffer' commands are also supported." - (let* ((no-select (xor (consp arg) windmove-display-no-select)) - (old-window (or (minibuffer-selected-window) (selected-window))) - (new-window) - (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)) - (unless window - (setq window (split-window nil nil dir) type 'window)) - (setq new-window (window--display-buffer buffer window - type alist)))))) - (command this-command) - (clearfun (make-symbol "clear-display-buffer-overriding-action")) - (exitfun - (lambda () - (setq display-buffer-overriding-action - (delq action display-buffer-overriding-action)) - (when (window-live-p (if no-select old-window new-window)) - (select-window (if no-select old-window new-window))) - (remove-hook 'post-command-hook clearfun)))) - (fset clearfun - (lambda () - (unless (or - ;; Remove the hook immediately - ;; after exiting the minibuffer. - (> (minibuffer-depth) minibuffer-depth) - ;; But don't remove immediately after - ;; adding the hook by the same command below. - (eq this-command command)) - (funcall exitfun)))) - (add-hook 'post-command-hook clearfun) - (push action display-buffer-overriding-action) - (message "[display-%s]" dir))) + (let ((no-select (xor (consp arg) windmove-display-no-select))) + (display-buffer-override-next-command + (lambda (_buffer alist) + (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 'new-frame) + (let* ((params (cdr (assq 'pop-up-frame-parameters alist))) + (pop-up-frame-alist (append params pop-up-frame-alist)) + (frame (make-frame-on-current-monitor + pop-up-frame-alist))) + (unless (cdr (assq 'inhibit-switch-frame alist)) + (window--maybe-raise-frame frame)) + (setq type 'frame) + (frame-selected-window frame))) + ((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)) + (cons window type))) + (lambda (old-window new-window) + (when (window-live-p (if no-select old-window new-window)) + (select-window (if no-select old-window new-window)))) + (format "[display-%s]" dir)))) ;;;###autoload (defun windmove-display-left (&optional arg) @@ -541,6 +529,12 @@ See the logic of the prefix ARG in `windmove-display-in-direction'." (windmove-display-in-direction 'same-window arg)) ;;;###autoload +(defun windmove-display-new-frame (&optional arg) + "Display the next buffer in a new frame." + (interactive "P") + (windmove-display-in-direction 'new-frame arg)) + +;;;###autoload (defun windmove-display-new-tab (&optional arg) "Display the next buffer in a new tab." (interactive "P") @@ -561,6 +555,7 @@ Default value of MODIFIERS is `shift-meta'." (global-set-key (vector (append modifiers '(up))) 'windmove-display-up) (global-set-key (vector (append modifiers '(down))) 'windmove-display-down) (global-set-key (vector (append modifiers '(?0))) 'windmove-display-same-window) + (global-set-key (vector (append modifiers '(?f))) 'windmove-display-new-frame) (global-set-key (vector (append modifiers '(?t))) 'windmove-display-new-tab)) diff --git a/lisp/window.el b/lisp/window.el index 5c4ff83d82d..f20940fa0ea 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -226,7 +226,9 @@ BODY." "Show a buffer BUFFER-OR-NAME and evaluate BODY in that buffer. This construct is like `with-current-buffer-window' but unlike that, displays the buffer specified by BUFFER-OR-NAME before running BODY." - (declare (debug t) (indent 3)) + (declare (debug t) (indent 3) + (obsolete "use `with-current-buffer-window' with action alist entry `body-function'." + "28.1")) (let ((buffer (make-symbol "buffer")) (window (make-symbol "window")) (value (make-symbol "value"))) @@ -278,6 +280,24 @@ displays the buffer specified by BUFFER-OR-NAME before running BODY." (funcall ,vquit-function ,window ,value) ,value))))) +(defmacro with-window-non-dedicated (window &rest body) + "Evaluate BODY with WINDOW temporarily made non-dedicated. +If WINDOW is nil, use the selected window. Return the value of +the last form in BODY." + (declare (indent 1) (debug t)) + (let ((window-dedicated-sym (gensym)) + (window-sym (gensym))) + `(let* ((,window-sym (window-normalize-window ,window t)) + (,window-dedicated-sym (window-dedicated-p ,window-sym))) + (set-window-dedicated-p ,window-sym nil) + (unwind-protect + (progn ,@body) + ;; `window-dedicated-p' returns the value set by + ;; `set-window-dedicated-p', which differentiates non-nil and + ;; t, so we cannot simply use t here. That's why we use + ;; `window-dedicated-sym'. + (set-window-dedicated-p ,window-sym ,window-dedicated-sym))))) + ;; The following two functions are like `window-next-sibling' and ;; `window-prev-sibling' but the WINDOW argument is _not_ optional (so ;; they don't substitute the selected window for nil), and they return @@ -3911,7 +3931,7 @@ TOP RIGHT BOTTOM) as returned by `window-edges'." (setq frame (window-normalize-frame frame)) (window--subtree (frame-root-window frame) t)) -(defun other-window (count &optional all-frames) +(defun other-window (count &optional all-frames interactive) "Select another window in cyclic ordering of windows. COUNT specifies the number of windows to skip, starting with the selected window, before making the selection. If COUNT is @@ -3931,7 +3951,7 @@ This function uses `next-window' for finding the window to select. The argument ALL-FRAMES has the same meaning as in `next-window', but the MINIBUF argument of `next-window' is always effectively nil." - (interactive "p") + (interactive "p\ni\np") (let* ((window (selected-window)) (original-window window) (function (and (not ignore-window-parameters) @@ -3977,13 +3997,53 @@ always effectively nil." (setq count (1+ count))))) (when (and (eq window original-window) - (called-interactively-p 'interactive)) + interactive + (not (or executing-kbd-macro noninteractive))) (message "No other window to select")) (select-window window) ;; Always return nil. nil)))) +(defun other-window-prefix () + "Display the buffer of the next command in a new window. +The next buffer is the buffer displayed by the next command invoked +immediately after this command (ignoring reading from the minibuffer). +Creates a new window before displaying the buffer. +When `switch-to-buffer-obey-display-actions' is non-nil, +`switch-to-buffer' commands are also supported." + (interactive) + (display-buffer-override-next-command + (lambda (buffer alist) + (let ((alist (append '((inhibit-same-window . t)) alist)) + window type) + (if (setq window (display-buffer-pop-up-window buffer alist)) + (setq type 'window) + (setq window (display-buffer-use-some-window buffer alist) + type 'reuse)) + (cons window type))) + nil "[other-window]") + (message "Display next command buffer in a new window...")) + +(defun same-window-prefix () + "Display the buffer of the next command in the same window. +The next buffer is the buffer displayed by the next command invoked +immediately after this command (ignoring reading from the minibuffer). +Even when the default rule should display the buffer in a new window, +force its display in the already selected window. +When `switch-to-buffer-obey-display-actions' is non-nil, +`switch-to-buffer' commands are also supported." + (interactive) + (display-buffer-override-next-command + (lambda (buffer alist) + (setq alist (append '((inhibit-same-window . nil)) alist)) + (cons (or + (display-buffer-same-window buffer alist) + (display-buffer-use-some-window buffer alist)) + 'reuse)) + nil "[same-window]") + (message "Display next command buffer in the same window...")) + ;; This should probably return non-nil when the selected window is part ;; of an atomic window whose root is the frame's root window. (defun one-window-p (&optional nomini all-frames) @@ -4192,7 +4252,7 @@ that is its frame's root window." ;; Always return nil. nil)))) -(defun delete-other-windows (&optional window) +(defun delete-other-windows (&optional window interactive) "Make WINDOW fill its frame. WINDOW must be a valid window and defaults to the selected one. Return nil. @@ -4209,7 +4269,7 @@ with the root of the atomic window as its argument. Signal an error if that root window is the root window of WINDOW's frame. Also signal an error if WINDOW is a side window. Do not delete any window whose `no-delete-other-windows' parameter is non-nil." - (interactive) + (interactive "i\np") (setq window (window-normalize-window window)) (let* ((frame (window-frame window)) (function (window-parameter window 'delete-other-windows)) @@ -4275,7 +4335,8 @@ any window whose `no-delete-other-windows' parameter is non-nil." (if (eq window main) ;; Give a message to the user if this has been called as a ;; command. - (when (called-interactively-p 'interactive) + (when (and interactive + (not (or executing-kbd-macro noninteractive))) (message "No other windows to delete")) (delete-other-windows-internal window main) (window--check frame)) @@ -4838,11 +4899,11 @@ displayed there." (interactive) (switch-to-buffer (last-buffer))) -(defun next-buffer (&optional arg) +(defun next-buffer (&optional arg interactive) "In selected window switch to ARGth next buffer. Call `switch-to-next-buffer' unless the selected window is the minibuffer window or is dedicated to its buffer." - (interactive "p") + (interactive "p\np") (cond ((window-minibuffer-p) (user-error "Cannot switch buffers in minibuffer window")) @@ -4851,14 +4912,15 @@ minibuffer window or is dedicated to its buffer." (t (dotimes (_ (or arg 1)) (when (and (not (switch-to-next-buffer)) - (called-interactively-p 'interactive)) + interactive + (not (or executing-kbd-macro noninteractive))) (user-error "No next buffer")))))) -(defun previous-buffer (&optional arg) +(defun previous-buffer (&optional arg interactive) "In selected window switch to ARGth previous buffer. Call `switch-to-prev-buffer' unless the selected window is the minibuffer window or is dedicated to its buffer." - (interactive "p") + (interactive "p\np") (cond ((window-minibuffer-p) (user-error "Cannot switch buffers in minibuffer window")) @@ -4867,7 +4929,8 @@ minibuffer window or is dedicated to its buffer." (t (dotimes (_ (or arg 1)) (when (and (not (switch-to-prev-buffer)) - (called-interactively-p 'interactive)) + interactive + (not (or executing-kbd-macro noninteractive))) (user-error "No previous buffer")))))) (defun delete-windows-on (&optional buffer-or-name frame) @@ -5009,6 +5072,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 +6437,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,8 +7109,14 @@ 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)) + + (when (functionp (cdr (assq 'body-function alist))) + (let ((inhibit-read-only t) + (inhibit-modification-hooks t)) + (funcall (cdr (assq 'body-function alist)) window))) + (let ((quit-restore (window-parameter window 'quit-restore)) (height (cdr (assq 'window-height alist))) (width (cdr (assq 'window-width alist))) @@ -7363,6 +7444,12 @@ Action alist entries are: parameters to give the chosen window. `allow-no-window' -- A non-nil value means that `display-buffer' may not display the buffer and return nil immediately. + `body-function' -- A function called with one argument - the + displayed window. It is called after the buffer is + displayed, and before `window-height', `window-width' + and `preserve-size' are applied. The function is supposed + to fill the window body with some contents that might depend + on dimensions of the displayed window. The entries `window-height', `window-width' and `preserve-size' are applied only when the window used for displaying the buffer @@ -7879,15 +7966,15 @@ Info node `(elisp) Buffer Display Action Alists' for details of such alists. ALIST has to contain a `direction' entry whose value should be -one of `left', `above' (or `up'), `right' and `below' (or -'down'). Other values are usually interpreted as `below'. +one of `left', `above' (or `up'), `right' and `below' (or `down'). +Other values are usually interpreted as `below'. If ALIST also contains a `window' entry, its value specifies a reference window. That value can be a special symbol like -'main' (which stands for the selected frame's main window) or -'root' (standings for the selected frame's root window) or an +`main' (which stands for the selected frame's main window) or +`root' (standings for the selected frame's root window) or an arbitrary valid window. Any other value (or omitting the -'window' entry) means to use the selected window as reference +`window' entry) means to use the selected window as reference window. This function tries to reuse or split a window such that the @@ -8530,6 +8617,60 @@ documentation for additional customization information." (interactive (list (read-buffer-to-switch "Switch to buffer in other frame: "))) (pop-to-buffer buffer-or-name display-buffer--other-frame-action norecord)) + +(defun display-buffer-override-next-command (pre-function &optional post-function echo) + "Set `display-buffer-overriding-action' for the next command. +`pre-function' is called to prepare the window where the buffer should be +displayed. This function takes two arguments `buffer' and `alist', and +should return a cons with the displayed window and its type. See the +meaning of these values in `window--display-buffer'. +Optional `post-function' is called after the buffer is displayed in the +window; the function takes two arguments: an old and new window. +Optional string argument `echo' can be used to add a prefix to the +command echo keystrokes that should describe the current prefix state." + (let* ((old-window (or (minibuffer-selected-window) (selected-window))) + (new-window nil) + (minibuffer-depth (minibuffer-depth)) + (clearfun (make-symbol "clear-display-buffer-overriding-action")) + (action (lambda (buffer alist) + (unless (> (minibuffer-depth) minibuffer-depth) + (let* ((ret (funcall pre-function buffer alist)) + (window (car ret)) + (type (cdr ret))) + (setq new-window (window--display-buffer buffer window + type alist)) + ;; Reset display-buffer-overriding-action + ;; after the first buffer display action + (funcall clearfun) + (setq post-function nil) + new-window)))) + (command this-command) + (echofun (when echo (lambda () echo))) + (exitfun + (lambda () + (setcar display-buffer-overriding-action + (delq action (car display-buffer-overriding-action))) + (remove-hook 'post-command-hook clearfun) + (remove-hook 'prefix-command-echo-keystrokes-functions echofun) + (when (functionp post-function) + (funcall post-function old-window new-window))))) + (fset clearfun + (lambda () + (unless (or + ;; Remove the hook immediately + ;; after exiting the minibuffer. + (> (minibuffer-depth) minibuffer-depth) + ;; But don't remove immediately after + ;; adding the hook by the same command below. + (eq this-command command)) + (funcall exitfun)))) + ;; Reset display-buffer-overriding-action + ;; after the next command finishes + (add-hook 'post-command-hook clearfun) + (when echofun + (add-hook 'prefix-command-echo-keystrokes-functions echofun)) + (push action (car display-buffer-overriding-action)))) + (defun set-window-text-height (window height) "Set the height in lines of the text display area of WINDOW to HEIGHT. @@ -8590,16 +8731,32 @@ in some window." (setq end (point-max))) (if (= beg end) 0 - (save-excursion - (save-restriction - (widen) - (narrow-to-region (min beg end) - (if (and (not count-final-newline) - (= ?\n (char-before (max beg end)))) - (1- (max beg end)) - (max beg end))) - (goto-char (point-min)) - (1+ (vertical-motion (buffer-size) window)))))) + (let ((start (min beg end)) + (finish (max beg end)) + count end-invisible-p) + ;; When END is invisible because lines are truncated in WINDOW, + ;; vertical-motion returns a number that is 1 larger than it + ;; should. We need to fix that. + (setq end-invisible-p + (and (or truncate-lines + (and (natnump truncate-partial-width-windows) + (< (window-total-width window) + truncate-partial-width-windows))) + (save-excursion + (goto-char finish) + (> (- (current-column) (window-hscroll window)) + (window-body-width window))))) + (save-excursion + (save-restriction + (widen) + (narrow-to-region start + (if (and (not count-final-newline) + (= ?\n (char-before finish))) + (1- finish) + finish)) + (goto-char start) + (setq count (vertical-motion (buffer-size) window)) + (if end-invisible-p count (1+ count))))))) (defun window-buffer-height (window) "Return the height (in screen lines) of the buffer that WINDOW is displaying. @@ -10019,5 +10176,7 @@ displaying that processes's buffer." (define-key ctl-x-map "-" 'shrink-window-if-larger-than-buffer) (define-key ctl-x-map "+" 'balance-windows) (define-key ctl-x-4-map "0" 'kill-buffer-and-window) +(define-key ctl-x-4-map "1" 'same-window-prefix) +(define-key ctl-x-4-map "4" 'other-window-prefix) ;;; window.el ends here diff --git a/lisp/woman.el b/lisp/woman.el index 8465ab7c32e..c0e27c57077 100644 --- a/lisp/woman.el +++ b/lisp/woman.el @@ -6,7 +6,7 @@ ;; Maintainer: emacs-devel@gnu.org ;; Keywords: help, unix ;; Adapted-By: Eli Zaretskii <eliz@gnu.org> -;; Version: 0.551 +;; Old-Version: 0.551 ;; URL: http://centaur.maths.qmul.ac.uk/Emacs/WoMan/ ;; This file is part of GNU Emacs. @@ -401,6 +401,7 @@ ;;; Code: (defvar woman-version "0.551 (beta)" "WoMan version information.") +(make-obsolete-variable 'woman-version nil "28.1") (require 'man) (require 'button) @@ -674,7 +675,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 +754,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) @@ -1830,7 +1831,6 @@ Argument EVENT is the invoking mouse event." ["Mini Help" woman-mini-help t] ,@(if (fboundp 'customize-group) '(["Customize..." (customize-group 'woman) t])) - ["Show Version" (message "WoMan %s" woman-version) t] "--" ("Advanced" ["View Source" (view-file woman-last-file-name) woman-last-file-name] @@ -1878,7 +1878,6 @@ Argument EVENT is the invoking mouse event." WoMan is an ELisp emulation of much of the functionality of the Emacs `man' command running the standard UN*X man and ?roff programs. WoMan author: F.J.Wright@Maths.QMW.ac.uk -WoMan version: see `woman-version'. See `Man-mode' for additional details. \\{woman-mode-map}" (let ((Man-build-page-list (symbol-function 'Man-build-page-list)) diff --git a/lisp/x-dnd.el b/lisp/x-dnd.el index ea9d119e2ff..1d49f462531 100644 --- a/lisp/x-dnd.el +++ b/lisp/x-dnd.el @@ -1,4 +1,4 @@ -;;; x-dnd.el --- drag and drop support for X +;;; x-dnd.el --- drag and drop support for X -*- lexical-binding: t; -*- ;; Copyright (C) 2004-2020 Free Software Foundation, Inc. @@ -32,7 +32,7 @@ (require 'dnd) ;;; Customizable variables -(defcustom x-dnd-test-function 'x-dnd-default-test-function +(defcustom x-dnd-test-function #'x-dnd-default-test-function "The function drag and drop uses to determine if to accept or reject a drop. The function takes three arguments, WINDOW, ACTION and TYPES. WINDOW is where the mouse is when the function is called. WINDOW may be a @@ -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))) diff --git a/lisp/xml.el b/lisp/xml.el index dc774a202cf..10ef8e2087a 100644 --- a/lisp/xml.el +++ b/lisp/xml.el @@ -1023,9 +1023,18 @@ entity references (e.g., replace each & with &). XML character data must not contain & or < characters, nor the > character under some circumstances. The XML spec does not impose restriction on \" or \\=', but we just substitute for these too -\(as is permitted by the spec)." +\(as is permitted by the spec). + +If STRING contains characters that are invalid in XML (as defined +by https://www.w3.org/TR/xml/#charsets), signal an error of type +`xml-invalid-character'." (with-temp-buffer (insert string) + (goto-char (point-min)) + (when (re-search-forward + "[^\u0009\u000A\u000D\u0020-\uD7FF\uE000-\uFFFD\U00010000-\U0010FFFF]" + nil t) + (signal 'xml-invalid-character (list (char-before) (match-beginning 0)))) (dolist (substitution '(("&" . "&") ("<" . "<") (">" . ">") @@ -1036,6 +1045,9 @@ restriction on \" or \\=', but we just substitute for these too (replace-match (cdr substitution) t t nil))) (buffer-string))) +(define-error 'xml-invalid-character "Invalid XML character" + 'wrong-type-argument) + (defun xml-debug-print-internal (xml indent-string) "Outputs the XML tree in the current buffer. The first line is indented with INDENT-STRING." diff --git a/lisp/xwidget.el b/lisp/xwidget.el index 775dddf8ef6..074320855c5 100644 --- a/lisp/xwidget.el +++ b/lisp/xwidget.el @@ -41,7 +41,10 @@ (declare-function xwidget-resize "xwidget.c" (xwidget new-width new-height)) (declare-function xwidget-webkit-execute-script "xwidget.c" (xwidget script &optional callback)) +(declare-function xwidget-webkit-uri "xwidget.c" (xwidget)) +(declare-function xwidget-webkit-title "xwidget.c" (xwidget)) (declare-function xwidget-webkit-goto-uri "xwidget.c" (xwidget uri)) +(declare-function xwidget-webkit-goto-history "xwidget.c" (xwidget rel-pos)) (declare-function xwidget-webkit-zoom "xwidget.c" (xwidget factor)) (declare-function xwidget-plist "xwidget.c" (xwidget)) (declare-function set-xwidget-plist "xwidget.c" (xwidget plist)) @@ -51,6 +54,10 @@ (declare-function get-buffer-xwidgets "xwidget.c" (buffer)) (declare-function xwidget-query-on-exit-flag "xwidget.c" (xwidget)) +(defgroup xwidget nil + "Displaying native widgets in Emacs buffers." + :group 'widgets) + (defun xwidget-insert (pos type title width height &optional args) "Insert an xwidget at position POS. Supply the xwidget's TYPE, TITLE, WIDTH, and HEIGHT. @@ -78,6 +85,8 @@ This returns the result of `make-xwidget'." ;;; webkit support (require 'browse-url) (require 'image-mode);;for some image-mode alike functionality +(require 'seq) +(require 'url-handlers) ;;;###autoload (defun xwidget-webkit-browse-url (url &optional new-session) @@ -92,10 +101,31 @@ Interactively, URL defaults to the string looking like a url around point." (or (featurep 'xwidget-internal) (user-error "Your Emacs was not compiled with xwidgets support")) (when (stringp url) + ;; If it's a "naked url", just try adding https: to it. + (unless (string-match "\\`[A-Za-z]+:" url) + (setq url (concat "https://" url))) (if new-session (xwidget-webkit-new-session url) (xwidget-webkit-goto-url url)))) +(defun xwidget-webkit-clone-and-split-below () + "Clone current URL into a new widget place in new window below. +Get the URL of current session, then browse to the URL +in `split-window-below' with a new xwidget webkit session." + (interactive) + (let ((url (xwidget-webkit-current-url))) + (with-selected-window (split-window-below) + (xwidget-webkit-new-session url)))) + +(defun xwidget-webkit-clone-and-split-right () + "Clone current URL into a new widget place in new window right. +Get the URL of current session, then browse to the URL +in `split-window-right' with a new xwidget webkit session." + (interactive) + (let ((url (xwidget-webkit-current-url))) + (with-selected-window (split-window-right) + (xwidget-webkit-new-session url)))) + ;;todo. ;; - check that the webkit support is compiled in (defvar xwidget-webkit-mode-map @@ -103,6 +133,7 @@ Interactively, URL defaults to the string looking like a url around point." (define-key map "g" 'xwidget-webkit-browse-url) (define-key map "a" 'xwidget-webkit-adjust-size-dispatch) (define-key map "b" 'xwidget-webkit-back) + (define-key map "f" 'xwidget-webkit-forward) (define-key map "r" 'xwidget-webkit-reload) (define-key map "t" (lambda () (interactive) (message "o"))) ;FIXME: ?!? (define-key map "\C-m" 'xwidget-webkit-insert-string) @@ -112,20 +143,21 @@ Interactively, URL defaults to the string looking like a url around point." ;;similar to image mode bindings (define-key map (kbd "SPC") 'xwidget-webkit-scroll-up) + (define-key map (kbd "S-SPC") 'xwidget-webkit-scroll-down) (define-key map (kbd "DEL") 'xwidget-webkit-scroll-down) - (define-key map [remap scroll-up] 'xwidget-webkit-scroll-up) + (define-key map [remap scroll-up] 'xwidget-webkit-scroll-up-line) (define-key map [remap scroll-up-command] 'xwidget-webkit-scroll-up) - (define-key map [remap scroll-down] 'xwidget-webkit-scroll-down) + (define-key map [remap scroll-down] 'xwidget-webkit-scroll-down-line) (define-key map [remap scroll-down-command] 'xwidget-webkit-scroll-down) (define-key map [remap forward-char] 'xwidget-webkit-scroll-forward) (define-key map [remap backward-char] 'xwidget-webkit-scroll-backward) (define-key map [remap right-char] 'xwidget-webkit-scroll-forward) (define-key map [remap left-char] 'xwidget-webkit-scroll-backward) - (define-key map [remap previous-line] 'xwidget-webkit-scroll-down) - (define-key map [remap next-line] 'xwidget-webkit-scroll-up) + (define-key map [remap previous-line] 'xwidget-webkit-scroll-down-line) + (define-key map [remap next-line] 'xwidget-webkit-scroll-up-line) ;; (define-key map [remap move-beginning-of-line] 'image-bol) ;; (define-key map [remap move-end-of-line] 'image-eol) @@ -144,33 +176,63 @@ Interactively, URL defaults to the string looking like a url around point." (interactive) (xwidget-webkit-zoom (xwidget-webkit-current-session) -0.1)) -(defun xwidget-webkit-scroll-up () - "Scroll webkit up." - (interactive) +(defun xwidget-webkit-scroll-up (&optional arg) + "Scroll webkit up by ARG pixels; or full window height if no ARG. +Stop if bottom of page is reached. +Interactively, ARG is the prefix numeric argument. +Negative ARG scrolls down." + (interactive "P") (xwidget-webkit-execute-script (xwidget-webkit-current-session) - "window.scrollBy(0, 50);")) - -(defun xwidget-webkit-scroll-down () - "Scroll webkit down." - (interactive) + (format "window.scrollBy(0, %d);" + (or arg (xwidget-window-inside-pixel-height (selected-window)))))) + +(defun xwidget-webkit-scroll-down (&optional arg) + "Scroll webkit down by ARG pixels; or full window height if no ARG. +Stop if top of page is reached. +Interactively, ARG is the prefix numeric argument. +Negative ARG scrolls up." + (interactive "P") (xwidget-webkit-execute-script (xwidget-webkit-current-session) - "window.scrollBy(0, -50);")) - -(defun xwidget-webkit-scroll-forward () - "Scroll webkit forwards." - (interactive) + (format "window.scrollBy(0, -%d);" + (or arg (xwidget-window-inside-pixel-height (selected-window)))))) + +(defun xwidget-webkit-scroll-up-line (&optional n) + "Scroll webkit up by N lines. +The height of line is calculated with `window-font-height'. +Stop if the bottom edge of the page is reached. +If N is omitted or nil, scroll up by one line." + (interactive "p") + (xwidget-webkit-scroll-up (* n (window-font-height)))) + +(defun xwidget-webkit-scroll-down-line (&optional n) + "Scroll webkit down by N lines. +The height of line is calculated with `window-font-height'. +Stop if the top edge of the page is reached. +If N is omitted or nil, scroll down by one line." + (interactive "p") + (xwidget-webkit-scroll-down (* n (window-font-height)))) + +(defun xwidget-webkit-scroll-forward (&optional n) + "Scroll webkit horizontally by N chars. +The width of char is calculated with `window-font-width'. +If N is ommited or nil, scroll forwards by one char." + (interactive "p") (xwidget-webkit-execute-script (xwidget-webkit-current-session) - "window.scrollBy(50, 0);")) - -(defun xwidget-webkit-scroll-backward () - "Scroll webkit backwards." - (interactive) + (format "window.scrollBy(%d, 0);" + (* n (window-font-width))))) + +(defun xwidget-webkit-scroll-backward (&optional n) + "Scroll webkit back by N chars. +The width of char is calculated with `window-font-width'. +If N is ommited or nil, scroll backwards by one char." + (interactive "p") (xwidget-webkit-execute-script (xwidget-webkit-current-session) - "window.scrollBy(-50, 0);")) + (format "window.scrollBy(-%d, 0);" + (* n (window-font-width))))) (defun xwidget-webkit-scroll-top () "Scroll webkit to the very top." @@ -184,7 +246,7 @@ Interactively, URL defaults to the string looking like a url around point." (interactive) (xwidget-webkit-execute-script (xwidget-webkit-current-session) - "window.scrollTo(pageXOffset, window.document.body.clientHeight);")) + "window.scrollTo(pageXOffset, window.document.body.scrollHeight);")) ;; The xwidget event needs to go into a higher level handler ;; since the xwidget can generate an event even if it's offscreen. @@ -204,12 +266,8 @@ Interactively, URL defaults to the string looking like a url around point." (let* ((xwidget-event-type (nth 1 last-input-event)) (xwidget (nth 2 last-input-event)) - ;;(xwidget-callback (xwidget-get xwidget 'callback)) - ;;TODO stopped working for some reason - ) - ;;(funcall xwidget-callback xwidget xwidget-event-type) - (message "xw callback %s" xwidget) - (funcall 'xwidget-webkit-callback xwidget xwidget-event-type))) + (xwidget-callback (xwidget-get xwidget 'callback))) + (funcall xwidget-callback xwidget xwidget-event-type))) (defun xwidget-webkit-callback (xwidget xwidget-event-type) "Callback for xwidgets. @@ -219,21 +277,23 @@ XWIDGET instance, XWIDGET-EVENT-TYPE depends on the originating xwidget." "error: callback called for xwidget with dead buffer") (with-current-buffer (xwidget-buffer xwidget) (cond ((eq xwidget-event-type 'load-changed) - (xwidget-webkit-execute-script - xwidget "document.title" - (lambda (title) - (xwidget-log "webkit finished loading: '%s'" title) - ;;TODO - check the native/internal scroll - ;;(xwidget-adjust-size-to-content xwidget) - (xwidget-webkit-adjust-size-to-window xwidget) - (rename-buffer (format "*xwidget webkit: %s *" title)))) - (pop-to-buffer (current-buffer))) + (let ((title (xwidget-webkit-title xwidget))) + (xwidget-log "webkit finished loading: %s" title) + ;; Do not adjust webkit size to window here, the selected window + ;; can be the mini-buffer window unwantedly. + (rename-buffer (format "*xwidget webkit: %s *" title) t))) ((eq xwidget-event-type 'decide-policy) (let ((strarg (nth 3 last-input-event))) (if (string-match ".*#\\(.*\\)" strarg) (xwidget-webkit-show-id-or-named-element xwidget (match-string 1 strarg))))) + ;; TODO: Response handling other than download. + ((eq xwidget-event-type 'download-callback) + (let ((url (nth 3 last-input-event)) + (mime-type (nth 4 last-input-event)) + (file-name (nth 5 last-input-event))) + (xwidget-webkit-save-as-file url mime-type file-name))) ((eq xwidget-event-type 'javascript-callback) (let ((proc (nth 3 last-input-event)) (arg (nth 4 last-input-event))) @@ -241,21 +301,66 @@ XWIDGET instance, XWIDGET-EVENT-TYPE depends on the originating xwidget." (t (xwidget-log "unhandled event:%s" xwidget-event-type)))))) (defvar bookmark-make-record-function) +(when (memq window-system '(mac ns)) + (defvar xwidget-webkit-enable-plugins nil + "Enable plugins for xwidget webkit. +If non-nil, plugins are enabled. Otherwise, disabled.")) + (define-derived-mode xwidget-webkit-mode - special-mode "xwidget-webkit" "Xwidget webkit view mode." - (setq buffer-read-only t) - (setq-local bookmark-make-record-function - #'xwidget-webkit-bookmark-make-record) - ;; Keep track of [vh]scroll when switching buffers - (image-mode-setup-winprops)) + special-mode "xwidget-webkit" "Xwidget webkit view mode." + (setq buffer-read-only t) + (setq-local bookmark-make-record-function + #'xwidget-webkit-bookmark-make-record) + ;; Keep track of [vh]scroll when switching buffers + (image-mode-setup-winprops)) + +;;; Download, save as file. + +(defcustom xwidget-webkit-download-dir "~/Downloads/" + "Directory where download file saved." + :version "27.1" + :type 'file) + +(defun xwidget-webkit-save-as-file (url mime-type file-name) + "For XWIDGET webkit, save URL of MIME-TYPE to location specified by user. +FILE-NAME combined with `xwidget-webkit-download-dir' is the default file name +of the prompt when reading. When the file name the user specified is a +directory, URL is saved at the specified directory as FILE-NAME." + (let ((save-name (read-file-name + (format "Save URL `%s' of type `%s' in file/directory: " + url mime-type) + xwidget-webkit-download-dir + (when file-name + (expand-file-name + file-name + xwidget-webkit-download-dir))))) + (if (file-directory-p save-name) + (setq save-name + (expand-file-name (file-name-nondirectory file-name) save-name))) + (setq xwidget-webkit-download-dir (file-name-directory save-name)) + (url-copy-file url save-name t))) + +;;; Bookmarks integration + +(defcustom xwidget-webkit-bookmark-jump-new-session nil + "Control bookmark jump to use new session or not. +If non-nil, use a new xwidget webkit session after bookmark jump. +Otherwise, it will use `xwidget-webkit-last-session'. +When you set this variable to nil, consider further customization with +`xwidget-webkit-last-session-buffer'." + :version "27.1" + :type 'boolean) (defun xwidget-webkit-bookmark-make-record () - "Integrate Emacs bookmarks with the webkit xwidget." + "Create bookmark record in webkit xwidget." (nconc (bookmark-make-record-default t t) - `((page . ,(xwidget-webkit-current-url)) - (handler . (lambda (bmk) (browse-url - (bookmark-prop-get bmk 'page))))))) + `((page . ,(xwidget-webkit-uri (xwidget-webkit-current-session))) + (handler . (lambda (bmk) + (xwidget-webkit-browse-url + (bookmark-prop-get bmk 'page) + xwidget-webkit-bookmark-jump-new-session)))))) +;;; xwidget webkit session (defvar xwidget-webkit-last-session-buffer nil) @@ -303,7 +408,7 @@ function findactiveelement(doc){ " - "javascript that finds the active element." + "Javascript that finds the active element." ;; Yes it's ugly, because: ;; - there is apparently no way to find the active frame other than recursion ;; - the js "for each" construct misbehaved on the "frames" collection @@ -313,19 +418,22 @@ function findactiveelement(doc){ ) (defun xwidget-webkit-insert-string () - "Prompt for a string and insert it in the active field in the -current webkit widget." + "Insert string into the active field in the current webkit widget." ;; Read out the string in the field first and provide for edit. (interactive) + ;; As the prompt differs on JavaScript execution results, + ;; the function must handle the prompt itself. (let ((xww (xwidget-webkit-current-session))) (xwidget-webkit-execute-script xww (concat xwidget-webkit-activeelement-js " (function () { var res = findactiveelement(document); - return [res.value, res.type]; + if (res) + return [res.value, res.type]; })();") (lambda (field) + "Prompt a string for the FIELD and insert in the active input." (let ((str (pcase field (`[,val "text"] (read-string "Text: " val)) @@ -444,11 +552,23 @@ For example, use this to display an anchor." (ignore-errors (recenter-top-bottom))) +;; Utility functions + +(defun xwidget-window-inside-pixel-width (window) + "Return Emacs WINDOW body width in pixel." + (let ((edges (window-inside-pixel-edges window))) + (- (nth 2 edges) (nth 0 edges)))) + +(defun xwidget-window-inside-pixel-height (window) + "Return Emacs WINDOW body height in pixel." + (let ((edges (window-inside-pixel-edges window))) + (- (nth 3 edges) (nth 1 edges)))) + (defun xwidget-webkit-adjust-size-to-window (xwidget &optional window) "Adjust the size of the webkit XWIDGET to fit the WINDOW." (xwidget-resize xwidget - (window-pixel-width window) - (window-pixel-height window))) + (xwidget-window-inside-pixel-width window) + (xwidget-window-inside-pixel-height window))) (defun xwidget-webkit-adjust-size (w h) "Manually set webkit size to width W, height H." @@ -478,51 +598,56 @@ For example, use this to display an anchor." (add-to-list 'window-size-change-functions 'xwidget-webkit-adjust-size-in-frame)) -(defun xwidget-webkit-new-session (url) +(defun xwidget-webkit-new-session (url &optional callback) "Create a new webkit session buffer with URL." (let* ((bufname (generate-new-buffer-name "*xwidget-webkit*")) + (callback (or callback #'xwidget-webkit-callback)) xw) (setq xwidget-webkit-last-session-buffer (switch-to-buffer (get-buffer-create bufname))) ;; The xwidget id is stored in a text property, so we need to have ;; at least character in this buffer. - (insert " ") - (setq xw (xwidget-insert 1 'webkit bufname - (window-pixel-width) - (window-pixel-height))) - (xwidget-put xw 'callback 'xwidget-webkit-callback) + ;; Insert invisible url, good default for next `g' to browse url. + (let ((start (point))) + (insert url) + (put-text-property start (+ start (length url)) 'invisible t) + (setq xw (xwidget-insert + start 'webkit bufname + (xwidget-window-inside-pixel-width (selected-window)) + (xwidget-window-inside-pixel-height (selected-window))))) + (xwidget-put xw 'callback callback) (xwidget-webkit-mode) (xwidget-webkit-goto-uri (xwidget-webkit-last-session) url))) (defun xwidget-webkit-goto-url (url) - "Goto URL." + "Goto URL with xwidget webkit." (if (xwidget-webkit-current-session) (progn (xwidget-webkit-goto-uri (xwidget-webkit-current-session) url)) (xwidget-webkit-new-session url))) (defun xwidget-webkit-back () - "Go back in history." + "Go back to previous URL in xwidget webkit buffer." (interactive) - (xwidget-webkit-execute-script (xwidget-webkit-current-session) - "history.go(-1);")) + (xwidget-webkit-goto-history (xwidget-webkit-current-session) -1)) + +(defun xwidget-webkit-forward () + "Go forward in history." + (interactive) + (xwidget-webkit-goto-history (xwidget-webkit-current-session) 1)) (defun xwidget-webkit-reload () - "Reload current url." + "Reload current URL." (interactive) - (xwidget-webkit-execute-script (xwidget-webkit-current-session) - "history.go(0);")) + (xwidget-webkit-goto-history (xwidget-webkit-current-session) 0)) (defun xwidget-webkit-current-url () - "Get the webkit url and place it on the kill-ring." + "Display the current xwidget webkit URL and place it on the `kill-ring'." (interactive) - (xwidget-webkit-execute-script - (xwidget-webkit-current-session) - "document.URL" (lambda (rv) - (let ((url (kill-new (or rv "")))) - (message "url: %s" url))))) + (let ((url (xwidget-webkit-uri (xwidget-webkit-current-session)))) + (message "URL: %s" (kill-new (or url ""))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun xwidget-webkit-get-selection (proc) @@ -533,10 +658,9 @@ For example, use this to display an anchor." proc)) (defun xwidget-webkit-copy-selection-as-kill () - "Get the webkit selection and put it on the kill-ring." + "Get the webkit selection and put it on the `kill-ring'." (interactive) - (xwidget-webkit-get-selection (lambda (selection) (kill-new selection)))) - + (xwidget-webkit-get-selection #'kill-new)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Xwidget plist management (similar to the process plist functions) |