diff options
Diffstat (limited to 'lisp')
417 files changed, 16920 insertions, 11774 deletions
diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 3e764c5a787..df9e5c36ee1 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -60,7 +60,7 @@ BYTE_COMPILE_EXTRA_FLAGS = # The example above is just for developers, it should not be used by default. # Those automatically generated autoload files that need special rules -# to build; ie not including things created via generated-autoload-file +# to build; i.e. not including things created via generated-autoload-file # (eg calc/calc-loaddefs.el). LOADDEFS = $(lisp)/calendar/cal-loaddefs.el \ $(lisp)/calendar/diary-loaddefs.el \ @@ -91,25 +91,14 @@ COMPILE_FIRST = \ $(lisp)/emacs-lisp/byte-opt.elc \ $(lisp)/emacs-lisp/bytecomp.elc ifeq ($(HAVE_NATIVE_COMP),yes) -COMPILE_FIRST += \ - $(lisp)/emacs-lisp/comp.elc \ - $(lisp)/emacs-lisp/comp-cstr.elc \ - $(lisp)/emacs-lisp/cl-macs.elc \ - $(lisp)/emacs-lisp/rx.elc \ - $(lisp)/emacs-lisp/cl-seq.elc \ - $(lisp)/help-mode.elc \ - $(lisp)/emacs-lisp/cl-extra.elc \ - $(lisp)/emacs-lisp/gv.elc \ - $(lisp)/emacs-lisp/seq.elc \ - $(lisp)/emacs-lisp/cl-lib.elc \ - $(lisp)/emacs-lisp/warnings.elc \ - $(lisp)/emacs-lisp/subr-x.elc +COMPILE_FIRST += $(lisp)/emacs-lisp/comp.elc +COMPILE_FIRST += $(lisp)/emacs-lisp/comp-cstr.elc endif COMPILE_FIRST += $(lisp)/emacs-lisp/autoload.elc # Files to compile early in compile-main. Works around bug#25556. MAIN_FIRST = ./emacs-lisp/eieio.el ./emacs-lisp/eieio-base.el \ - ./cedet/semantic/db.el + ./cedet/semantic/db.el ./emacs-lisp/cconv.el # Prevent any settings in the user environment causing problems. unexport EMACSDATA EMACSDOC EMACSPATH @@ -216,6 +205,9 @@ autoloads-force: rm -f $(lisp)/loaddefs.el $(MAKE) autoloads +ldefs-boot.el: autoloads-force + cp $(lisp)/loaddefs.el $(lisp)/ldefs-boot.el + # This is required by the bootstrap-emacs target in ../src/Makefile, so # we know that if we have an emacs executable, we also have a subdirs.el. $(lisp)/subdirs.el: @@ -346,10 +338,10 @@ endif # Compile all the Elisp files that need it. Beware: it approximates # 'no-byte-compile', so watch out for false-positives! -compile-main: gen-lisp compile-clean +compile-main: gen-lisp compile-clean main-first @(cd $(lisp) && \ els=`echo "${SUBDIRS_REL} " | sed -e 's|/\./|/|g' -e 's|/\. | |g' -e 's| |/*.el |g'`; \ - for el in ${MAIN_FIRST} $$els; do \ + for el in $$els; do \ test -f $$el || continue; \ test ! -f $${el}c && \ GREP_OPTIONS= grep '^;.*[^a-zA-Z]no-byte-compile: *t' $$el > /dev/null && \ @@ -362,6 +354,18 @@ compile-main: gen-lisp compile-clean TARGETS="$$chunk"; \ done +# Compile some important files first. +main-first: + @(cd $(lisp) && \ + for el in ${MAIN_FIRST}; do \ + echo "$${el}c"; \ + done | xargs $(XARGS_LIMIT) echo) | \ + while read chunk; do \ + $(MAKE) compile-targets \ + NATIVE_DISABLED=$(NATIVE_SKIP_NONDUMP) \ + TARGETS="$$chunk"; \ + done + .PHONY: compile-clean # Erase left-over .elc files that do not have a corresponding .el file. compile-clean: diff --git a/lisp/abbrev.el b/lisp/abbrev.el index b0e8a4fa99c..386aff16270 100644 --- a/lisp/abbrev.el +++ b/lisp/abbrev.el @@ -403,7 +403,7 @@ argument." (defun expand-region-abbrevs (start end &optional noquery) "For abbrev occurrence in the region, offer to expand it. -The user is asked to type `y' or `n' for each occurrence. +The user is asked to type \\`y' or \\`n' for each occurrence. A prefix argument means don't query; expand all abbrevs." (interactive "r\nP") (save-excursion @@ -583,6 +583,7 @@ PROPS is a property list. The following properties are special: An obsolete but still supported calling form is: \(define-abbrev TABLE NAME EXPANSION &optional HOOK COUNT SYSTEM)." + (declare (indent defun)) (when (and (consp props) (or (null (car props)) (numberp (car props)))) ;; Old-style calling convention. (setq props `(:count ,(car props) @@ -1139,7 +1140,7 @@ Properties with special meaning: - `:enable-function' can be set to a function of no argument which returns non-nil if and only if the abbrevs in this table should be used for this instance of `expand-abbrev'." - (declare (doc-string 3)) + (declare (doc-string 3) (indent defun)) ;; We used to manually add the docstring, but we also want to record this ;; location as the definition of the variable (in load-history), so we may ;; as well just use `defvar'. diff --git a/lisp/align.el b/lisp/align.el index 7ced7b70445..2fd6dcda6d7 100644 --- a/lisp/align.el +++ b/lisp/align.el @@ -553,8 +553,7 @@ The possible settings for `align-region-separate' are: (modes . align-text-modes) (repeat . t) (run-if . ,(lambda () - (and current-prefix-arg - (not (eq '- current-prefix-arg)))))) + (not (eq '- current-prefix-arg))))) ;; With a negative prefix argument, lists of dollar figures will ;; be aligned. @@ -836,11 +835,22 @@ See the variable `align-exclude-rules-list' for more details.") ;;;###autoload (defun align (beg end &optional separate rules exclude-rules) "Attempt to align a region based on a set of alignment rules. -BEG and END mark the region. If BEG and END are specifically set to -nil (this can only be done programmatically), the beginning and end of -the current alignment section will be calculated based on the location -of point, and the value of `align-region-separate' (or possibly each -rule's `separate' attribute). +Interactively, BEG and END are the mark/point of the current region. + +Many modes define specific alignment rules, and some of these +rules in some modes react to the current prefix argument. For +instance, in `text-mode', `M-x align' will align into columns +based on space delimiters, while `C-u - M-x align' will align +into columns based on the \"$\" character. See the +`align-rules-list' variable definition for the specific rules. + +Also see `align-regexp', which will guide you through various +parameters for aligning text. + +Non-interactively, if BEG and END are nil, the beginning and end +of the current alignment section will be calculated based on the +location of point, and the value of `align-region-separate' (or +possibly each rule's `separate' attribute). If SEPARATE is non-nil, it overrides the value of `align-region-separate' for all rules, except those that have their @@ -889,6 +899,15 @@ on the format of these lists." BEG and END mark the limits of the region. Interactively, this function prompts for the regular expression REGEXP to align with. +Interactively, if you specify a prefix argument, the function +will guide you through entering the full regular expression, and +then prompts for which subexpression parenthesis GROUP (default +1) within REGEXP to modify, the amount of SPACING (default +`align-default-spacing') to use, and whether or not to REPEAT the +rule throughout the line. + +See `align-rules-list' for more information about these options. + For example, let's say you had a list of phone numbers, and wanted to align them so that the opening parentheses would line up: @@ -908,15 +927,8 @@ regular expression after you enter it. Interactively, you only need to supply the characters to be lined up, and any preceding whitespace is replaced. -Non-interactively (or if you specify a prefix argument), you must -enter the full regular expression, including the subexpression. -Interactively, the function also then prompts for which -subexpression parenthesis GROUP (default 1) within REGEXP to -modify, the amount of SPACING (default `align-default-spacing') -to use, and whether or not to REPEAT the rule throughout the -line. - -See `align-rules-list' for more information about these options. +Non-interactively, you must enter the full regular expression, +including the subexpression. The non-interactive form of the previous example would look something like: (align-regexp (point-min) (point-max) \"\\\\(\\\\s-*\\\\)(\") @@ -928,7 +940,7 @@ construct a rule to pass to `align-region', which does the real work." (list (region-beginning) (region-end)) (if current-prefix-arg (list (read-string "Complex align using regexp: " - "\\(\\s-*\\)" 'align-regexp-history) + "\\(\\s-*\\) " 'align-regexp-history) (string-to-number (read-string "Parenthesis group to modify (justify if negative): " "1")) diff --git a/lisp/allout.el b/lisp/allout.el index 5102ee73412..f684751a2a4 100644 --- a/lisp/allout.el +++ b/lisp/allout.el @@ -133,15 +133,10 @@ respective `allout-mode' keybinding variables, `allout-command-prefix', (when (boundp 'allout-unprefixed-keybindings) (dolist (entry allout-unprefixed-keybindings) (define-key map (car (read-from-string (car entry))) (cadr entry)))) - (substitute-key-definition #'beginning-of-line #'allout-beginning-of-line - map global-map) - (substitute-key-definition #'move-beginning-of-line - #'allout-beginning-of-line - map global-map) - (substitute-key-definition #'end-of-line #'allout-end-of-line - map global-map) - (substitute-key-definition #'move-end-of-line #'allout-end-of-line - map global-map) + (define-key map [remap beginning-of-line] #'allout-beginning-of-line) + (define-key map [remap move-beginning-of-line] #'allout-beginning-of-line) + (define-key map [remap end-of-line] #'allout-end-of-line) + (define-key map [remap move-end-of-line] #'allout-end-of-line) (allout-institute-keymap map))) ;;;_ > allout-institute-keymap (map) (defun allout-institute-keymap (map) @@ -3079,6 +3074,8 @@ Move to buffer limit in indicated direction if headings are exhausted." (backward (if (< arg 0) (setq arg (* -1 arg)))) (step (if backward -1 1)) (progress (allout-current-bullet-pos)) + ;; Move to the next physical line. + (line-move-visual nil) prev got) (while (> arg 0) diff --git a/lisp/ansi-color.el b/lisp/ansi-color.el index b1c9cdaeca4..c962cbd4780 100644 --- a/lisp/ansi-color.el +++ b/lisp/ansi-color.el @@ -91,7 +91,7 @@ as a PDF file." :group 'processes) (defface ansi-color-bold - '((t :inherit 'bold)) + '((t :inherit bold)) "Face used to render bold text." :group 'ansi-colors :version "28.1") @@ -103,13 +103,13 @@ as a PDF file." :version "28.1") (defface ansi-color-italic - '((t :inherit 'italic)) + '((t :inherit italic)) "Face used to render italic text." :group 'ansi-colors :version "28.1") (defface ansi-color-underline - '((t :inherit 'underline)) + '((t :inherit underline)) "Face used to render underlined text." :group 'ansi-colors :version "28.1") @@ -458,11 +458,18 @@ variable, and is meant to be used in `compilation-filter-hook'." ;; Working with strings (defvar-local ansi-color-context nil "Context saved between two calls to `ansi-color-apply'. -This is a list of the form (CODES FRAGMENT) or nil. CODES +This is a list of the form (FACE-VEC FRAGMENT) or nil. FACE-VEC represents the state the last call to `ansi-color-apply' ended -with, currently a list of ansi codes, and FRAGMENT is a string -starting with an escape sequence, possibly the start of a new -escape sequence.") +with, currently a list of the form: + + (BASIC-FACES FG BG) + +BASIC-FACES is a bool-vector that specifies which basic faces +from `ansi-color-basic-faces-vector' to apply. FG and BG are +ANSI color codes for the foreground and background color. + +FRAGMENT is a string starting with an escape sequence, possibly +the start of a new escape sequence.") (defun ansi-color-filter-apply (string) "Filter out all ANSI control sequences from STRING. @@ -473,17 +480,17 @@ will be used for the next call to `ansi-color-apply'. Set `ansi-color-context' to nil if you don't want this. This function can be added to `comint-preoutput-filter-functions'." - (let ((start 0) end result) + (let ((context (ansi-color--ensure-context 'ansi-color-context nil)) + (start 0) end result) ;; if context was saved and is a string, prepend it - (if (cadr ansi-color-context) - (setq string (concat (cadr ansi-color-context) string) - ansi-color-context nil)) + (setq string (concat (cadr context) string)) + (setcar (cdr context) "") ;; find the next escape sequence (while (setq end (string-match ansi-color-control-seq-regexp string start)) (push (substring string start end) result) (setq start (match-end 0))) ;; save context, add the remainder of the string to the result - (let (fragment) + (let ((fragment "")) (push (substring string start (if (string-match "\033" string start) (let ((pos (match-beginning 0))) @@ -491,25 +498,9 @@ This function can be added to `comint-preoutput-filter-functions'." pos) nil)) result) - (setq ansi-color-context (if fragment (list nil fragment)))) + (setcar (cdr context) fragment)) (apply #'concat (nreverse result)))) -(defun ansi-color--find-face (codes) - "Return the face corresponding to CODES." - ;; Sort the codes in ascending order to guarantee that "bold" comes before - ;; any of the colors. This ensures that `ansi-color-bold-is-bright' is - ;; applied correctly. - (let (faces bright (codes (sort (copy-sequence codes) #'<))) - (while codes - (when-let ((face (ansi-color-get-face-1 (pop codes) bright))) - (when (and ansi-color-bold-is-bright (eq face 'ansi-color-bold)) - (setq bright t)) - (push face faces))) - ;; Avoid some long-lived conses in the common case. - (if (cdr faces) - (nreverse faces) - (car faces)))) - (defun ansi-color-apply (string) "Translates SGR control sequences into text properties. Delete all other control sequences without processing them. @@ -524,49 +515,157 @@ This information will be used for the next call to `ansi-color-apply'. Set `ansi-color-context' to nil if you don't want this. This function can be added to `comint-preoutput-filter-functions'." - (let ((codes (car ansi-color-context)) - (start 0) end result) + (let* ((context + (ansi-color--ensure-context 'ansi-color-context nil)) + (face-vec (car context)) + (start 0) + end result) ;; If context was saved and is a string, prepend it. - (if (cadr ansi-color-context) - (setq string (concat (cadr ansi-color-context) string) - ansi-color-context nil)) + (setq string (concat (cadr context) string)) + (setcar (cdr context) "") ;; Find the next escape sequence. (while (setq end (string-match ansi-color-control-seq-regexp string start)) (let ((esc-end (match-end 0))) ;; Colorize the old block from start to end using old face. - (when codes + (when-let ((face (ansi-color--face-vec-face face-vec))) (put-text-property start end 'font-lock-face - (ansi-color--find-face codes) string)) + face string)) (push (substring string start end) result) (setq start (match-end 0)) ;; If this is a color escape sequence, (when (eq (aref string (1- esc-end)) ?m) ;; create a new face from it. - (setq codes (ansi-color-apply-sequence - (substring string end esc-end) codes))))) + (let ((cur-pos end)) + (ansi-color--update-face-vec + face-vec + (lambda () + (when (string-match ansi-color-parameter-regexp + string cur-pos) + (setq cur-pos (match-end 0)) + (when (<= cur-pos esc-end) + (string-to-number (match-string 1 string)))))))))) ;; if the rest of the string should have a face, put it there - (when codes + (when-let ((face (ansi-color--face-vec-face face-vec))) (put-text-property start (length string) - 'font-lock-face (ansi-color--find-face codes) string)) + 'font-lock-face face string)) ;; save context, add the remainder of the string to the result - (let (fragment) - (if (string-match "\033" string start) - (let ((pos (match-beginning 0))) - (setq fragment (substring string pos)) - (push (substring string start pos) result)) - (push (substring string start) result)) - (setq ansi-color-context (if (or codes fragment) (list codes fragment)))) + (if (string-match "\033" string start) + (let ((pos (match-beginning 0))) + (setcar (cdr context) (substring string pos)) + (push (substring string start pos) result)) + (push (substring string start) result)) (apply 'concat (nreverse result)))) +(defun ansi-color--ensure-context (context-sym position) + "Return CONTEXT-SYM's value as a valid context. +If it is nil, set CONTEXT-SYM's value to a new context and return +it. Context is a list of the form as described in +`ansi-color-context' if POSITION is nil, or +`ansi-color-context-region' if POSITION is non-nil. + +If CONTEXT-SYM's value is already non-nil, return it. If its +marker doesn't point anywhere yet, position it before character +number POSITION, if non-nil." + (let ((context (symbol-value context-sym))) + (if context + (if position + (let ((marker (cadr context))) + (unless (marker-position marker) + (set-marker marker position)) + context) + context) + (set context-sym + (list (list (make-bool-vector 8 nil) + nil nil) + (if position + (copy-marker position) + "")))))) + +(defun ansi-color--face-vec-face (face-vec) + "Return the face corresponding to FACE-VEC. +FACE-VEC is a list containing information about the ANSI sequence +code. It is usually stored as the car of the variable +`ansi-color-context-region'." + (let* ((basic-faces (car face-vec)) + (colors (cdr face-vec)) + (bright (and ansi-color-bold-is-bright (aref basic-faces 1))) + (faces nil)) + + (when-let ((fg (car colors))) + (push + `(:foreground + ,(or (ansi-color--code-as-hex fg) + (face-foreground + (aref (if (or bright (>= fg 8)) + ansi-color-bright-colors-vector + ansi-color-normal-colors-vector) + (mod fg 8)) + nil 'default))) + faces)) + (when-let ((bg (cadr colors))) + (push + `(:background + ,(or (ansi-color--code-as-hex bg) + (face-background + (aref (if (or bright (>= bg 8)) + ansi-color-bright-colors-vector + ansi-color-normal-colors-vector) + (mod bg 8)) + nil 'default))) + faces)) + + (let ((i 8)) + (while (> i 0) + (setq i (1- i)) + (when (aref basic-faces i) + (push (aref ansi-color-basic-faces-vector i) faces)))) + ;; Avoid some long-lived conses in the common case. + (if (cdr faces) + faces + (car faces)))) + +(defun ansi-color--code-as-hex (color) + "Convert COLOR to hexadecimal string representation. +COLOR is an ANSI color code. If it is between 16 and 255 +inclusive, it corresponds to a color from an 8-bit color cube. +If it is greater or equal than 256, it is subtracted by 256 to +directly specify a 24-bit color. + +Return a hexadecimal string, specifying the color, or nil, if +COLOR is less than 16." + (cond + ((< color 16) nil) + ((>= color 256) (format "#%06X" (- color 256))) + ((>= color 232) ;; Grayscale + (format "#%06X" (* #x010101 (+ 8 (* 10 (- color 232)))))) + (t ;; 6x6x6 color cube + (setq color (- color 16)) + (let ((res 0) + (frac (* 6 6))) + (while (<= 1 frac) ; Repeat 3 times + (setq res (* res #x000100)) + (let ((color-num (mod (/ color frac) 6))) + (unless (zerop color-num) + (setq res (+ res #x37 (* #x28 color-num))))) + (setq frac (/ frac 6))) + (format "#%06X" res))))) + ;; Working with regions (defvar-local ansi-color-context-region nil "Context saved between two calls to `ansi-color-apply-on-region'. -This is a list of the form (CODES MARKER) or nil. CODES +This is a list of the form (FACE-VEC MARKER) or nil. FACE-VEC represents the state the last call to `ansi-color-apply-on-region' -ended with, currently a list of ansi codes, and MARKER is a -buffer position within an escape sequence or the last position -processed.") +ended with, currently a list of the form: + + (BASIC-FACES FG BG). + +BASIC-FACES is a bool-vector that specifies which basic faces +from `ansi-color-basic-faces-vector' to apply. FG and BG are +ANSI color codes for the foreground and background color. + +MARKER is a buffer position within an escape sequence or the last +position processed.") (defun ansi-color-filter-region (begin end) "Filter out all ANSI control sequences from region BEGIN to END. @@ -576,8 +675,10 @@ Every call to this function will set and use the buffer-local variable used for the next call to `ansi-color-apply-on-region'. Specifically, it will override BEGIN, the start of the region. Set `ansi-color-context-region' to nil if you don't want this." - (let ((end-marker (copy-marker end)) - (start (or (cadr ansi-color-context-region) begin))) + (let* ((end-marker (copy-marker end)) + (context (ansi-color--ensure-context + 'ansi-color-context-region begin)) + (start (cadr context))) (save-excursion (goto-char start) ;; Delete escape sequences. @@ -585,8 +686,8 @@ it will override BEGIN, the start of the region. Set (delete-region (match-beginning 0) (match-end 0))) ;; save context, add the remainder of the string to the result (if (re-search-forward "\033" end-marker t) - (setq ansi-color-context-region (list nil (match-beginning 0))) - (setq ansi-color-context-region nil))))) + (set-marker start (match-beginning 0)) + (set-marker start nil))))) (defun ansi-color-apply-on-region (begin end &optional preserve-sequences) "Translates SGR control sequences into overlays or extents. @@ -608,58 +709,58 @@ this. If PRESERVE-SEQUENCES is t, the sequences are hidden instead of being deleted." - (let ((codes (car ansi-color-context-region)) - (start-marker (or (cadr ansi-color-context-region) - (copy-marker begin))) - (end-marker (copy-marker end))) + (let* ((context (ansi-color--ensure-context + 'ansi-color-context-region begin)) + (face-vec (car context)) + (start-marker (cadr context)) + (end-marker (copy-marker end))) (save-excursion (goto-char start-marker) ;; Find the next escape sequence. (while (re-search-forward ansi-color-control-seq-regexp end-marker t) ;; Extract escape sequence. - (let ((esc-seq (buffer-substring - (match-beginning 0) (point)))) - (if preserve-sequences - ;; Make the escape sequence transparent. - (overlay-put (make-overlay (match-beginning 0) (point)) - 'invisible t) - ;; Otherwise, strip. - (delete-region (match-beginning 0) (point))) - + (let ((esc-beg (match-beginning 0)) + (esc-end (point))) ;; Colorize the old block from start to end using old face. (funcall ansi-color-apply-face-function (prog1 (marker-position start-marker) ;; Store new start position. - (set-marker start-marker (point))) - (match-beginning 0) (ansi-color--find-face codes)) + (set-marker start-marker esc-end)) + esc-beg (ansi-color--face-vec-face face-vec)) ;; If this is a color sequence, - (when (eq (aref esc-seq (1- (length esc-seq))) ?m) - ;; update the list of ansi codes. - (setq codes (ansi-color-apply-sequence esc-seq codes))))) + (when (eq (char-before esc-end) ?m) + (goto-char esc-beg) + (ansi-color--update-face-vec + face-vec (lambda () + (when (re-search-forward ansi-color-parameter-regexp + esc-end t) + (string-to-number (match-string 1)))))) + + (if preserve-sequences + ;; Make the escape sequence transparent. + (overlay-put (make-overlay esc-beg esc-end) 'invisible t) + ;; Otherwise, strip. + (delete-region esc-beg esc-end)))) ;; search for the possible start of a new escape sequence (if (re-search-forward "\033" end-marker t) - (progn - ;; if the rest of the region should have a face, put it there - (funcall ansi-color-apply-face-function - start-marker (point) (ansi-color--find-face codes)) - ;; save codes and point - (setq ansi-color-context-region - (list codes (copy-marker (match-beginning 0))))) - ;; if the rest of the region should have a face, put it there - (funcall ansi-color-apply-face-function - start-marker end-marker (ansi-color--find-face codes)) - ;; Save a restart position when there are codes active. It's - ;; convenient for man.el's process filter to pass `begin' - ;; positions that overlap regions previously colored; these - ;; `codes' should not be applied to that overlap, so we need - ;; to know where they should really start. - (setq ansi-color-context-region - (if codes (list codes (copy-marker (point))))))) - ;; Clean up our temporary markers. - (unless (eq start-marker (cadr ansi-color-context-region)) - (set-marker start-marker nil)) - (unless (eq end-marker (cadr ansi-color-context-region)) - (set-marker end-marker nil)))) + (progn + (while (re-search-forward "\033" end-marker t)) + (backward-char) + (funcall ansi-color-apply-face-function + start-marker (point) + (ansi-color--face-vec-face face-vec)) + (set-marker start-marker (point))) + (let ((faces (ansi-color--face-vec-face face-vec))) + (funcall ansi-color-apply-face-function + start-marker end-marker faces) + ;; Save a restart position when there are codes active. It's + ;; convenient for man.el's process filter to pass `begin' + ;; positions that overlap regions previously colored; these + ;; `codes' should not be applied to that overlap, so we need + ;; to know where they should really start. + (set-marker start-marker (when faces end-marker))))) + ;; Clean up our temporary marker. + (set-marker end-marker nil))) (defun ansi-color-apply-overlay-face (beg end face) "Make an overlay from BEG to END, and apply face FACE. @@ -767,6 +868,7 @@ the foreground color code is replaced or added resp. deleted; if it is 40-47 (or 100-107) resp. 49, the background color code is replaced or added resp. deleted; any other code is discarded together with the old codes. Finally, the so changed list of codes is returned." + (declare (obsolete ansi-color--update-face-vec "29.1")) (let ((new-codes (ansi-color-parse-sequence escape-sequence))) (while new-codes (let* ((new (pop new-codes)) @@ -795,6 +897,72 @@ old codes. Finally, the so changed list of codes is returned." (_ nil))))) codes)) +(defun ansi-color--update-face-vec (face-vec iterator) + "Apply escape sequences to FACE-VEC. + +Destructively modify FACE-VEC, which should be a list containing +face information. It is described in +`ansi-color-context-region'. ITERATOR is a function which is +called repeatedly with zero arguments and should return either +the next ANSI code in the current sequence as a number or nil if +there are no more ANSI codes left. + +For each new code, the following happens: if it is 1-7, set the +corresponding properties; if it is 21-25 or 27, unset appropriate +properties; if it is 30-37 (or 90-97) or resp. 39, set the +foreground color or resp. unset it; if it is 40-47 (or 100-107) +resp. 49, set the background color or resp. unset it; if it is 38 +or 48, the following codes are used to set the foreground or +background color and the correct color mode; any other code will +unset all properties and colors." + (let ((basic-faces (car face-vec)) + (colors (cdr face-vec)) + new q do-clear) + (while (setq new (funcall iterator)) + (setq q (/ new 10)) + (pcase q + (0 (if (memq new '(0 8 9)) + (setq do-clear t) + (aset basic-faces new t))) + (2 (if (memq new '(20 26 28 29)) + (setq do-clear t) + ;; The standard says `21 doubly underlined' while + ;; https://en.wikipedia.org/wiki/ANSI_escape_code claims + ;; `21 Bright/Bold: off or Underline: Double'. + (aset basic-faces (- new 20) nil) + (aset basic-faces (pcase new (22 1) (25 6) (_ 0)) nil))) + ((or 3 4 9 10) + (let ((r (mod new 10)) + (cell (if (memq q '(3 9)) colors (cdr colors)))) + (pcase r + (8 + (pcase (funcall iterator) + (5 (setq new (setcar cell (funcall iterator))) + (setq do-clear (or (null new) (>= new 256)))) + (2 + (let ((red (funcall iterator)) + (green (funcall iterator)) + (blue (funcall iterator))) + (if (and red green blue + (progn + (setq new (+ (* #x010000 red) + (* #x000100 green) + (* #x000001 blue))) + (<= new #xFFFFFF))) + (setcar cell (+ 256 new)) + (setq do-clear t)))) + (_ (setq do-clear t)))) + (9 (setcar cell nil)) + (_ (setcar cell (+ (if (memq q '(3 4)) 0 8) r)))))) + (_ (setq do-clear t))) + + (when do-clear + (setq do-clear nil) + ;; Zero out our bool vector without any allocation. + (bool-vector-intersection basic-faces #&8"\0" basic-faces) + (setcar colors nil) + (setcar (cdr colors) nil))))) + (defun ansi-color-make-color-map () "Create a vector of face definitions and return it. @@ -859,6 +1027,7 @@ This function is obsolete, and no longer needed to use ansi-color." "Get face definition for ANSI-CODE. BRIGHT, if non-nil, requests \"bright\" ANSI colors, even if ANSI-CODE is a normal-intensity color." + (declare (obsolete ansi-color--face-vec-face "29.1")) (when (and bright (<= 30 ansi-code 49)) (setq ansi-code (+ ansi-code 60))) (cond ((<= 0 ansi-code 7) diff --git a/lisp/apropos.el b/lisp/apropos.el index fc15cd3e011..66a594d588d 100644 --- a/lisp/apropos.el +++ b/lisp/apropos.el @@ -515,9 +515,9 @@ variables, not just user options." current-prefix-arg)) (apropos-command pattern nil (if (or do-all apropos-do-all) - #'(lambda (symbol) - (and (boundp symbol) - (get symbol 'variable-documentation))) + (lambda (symbol) + (and (boundp symbol) + (get symbol 'variable-documentation))) #'custom-variable-p))) ;;;###autoload @@ -1322,17 +1322,18 @@ as a heading." (defun apropos-describe-plist (symbol) "Display a pretty listing of SYMBOL's plist." - (help-setup-xref (list 'apropos-describe-plist symbol) - (called-interactively-p 'interactive)) - (with-help-window (help-buffer) - (set-buffer standard-output) - (princ "Symbol ") - (prin1 symbol) - (princ (substitute-command-keys "'s plist is\n (")) - (put-text-property (+ (point-min) 7) (- (point) 14) - 'face 'apropos-symbol) - (insert (apropos-format-plist symbol "\n ")) - (princ ")"))) + (let ((help-buffer-under-preparation t)) + (help-setup-xref (list 'apropos-describe-plist symbol) + (called-interactively-p 'interactive)) + (with-help-window (help-buffer) + (set-buffer standard-output) + (princ "Symbol ") + (prin1 symbol) + (princ (substitute-command-keys "'s plist is\n (")) + (put-text-property (+ (point-min) 7) (- (point) 14) + 'face 'apropos-symbol) + (insert (apropos-format-plist symbol "\n ")) + (princ ")")))) (provide 'apropos) diff --git a/lisp/arc-mode.el b/lisp/arc-mode.el index 5576ae35053..1fd1d66c360 100644 --- a/lisp/arc-mode.el +++ b/lisp/arc-mode.el @@ -431,12 +431,8 @@ be added." ;; Let mouse-1 follow the link. (define-key map [follow-link] 'mouse-face) - (if (fboundp 'command-remapping) - (progn - (define-key map [remap advertised-undo] 'archive-undo) - (define-key map [remap undo] 'archive-undo)) - (substitute-key-definition 'advertised-undo 'archive-undo map global-map) - (substitute-key-definition 'undo 'archive-undo map global-map)) + (define-key map [remap advertised-undo] #'archive-undo) + (define-key map [remap undo] #'archive-undo) (define-key map [mouse-2] 'archive-extract) diff --git a/lisp/autoinsert.el b/lisp/autoinsert.el index 063d0a14d63..b448c0f8da9 100644 --- a/lisp/autoinsert.el +++ b/lisp/autoinsert.el @@ -415,6 +415,7 @@ Matches the visited file name against the elements of `auto-insert-alist'." "Associate CONDITION with (additional) ACTION in `auto-insert-alist'. Optional AFTER means to insert action after all existing actions for CONDITION, or if CONDITION had no actions, after all other CONDITIONs." + (declare (indent defun)) (let ((elt (assoc condition auto-insert-alist))) (if elt (setcdr elt diff --git a/lisp/bindings.el b/lisp/bindings.el index 121e484a0ee..ba3bf81b3e3 100644 --- a/lisp/bindings.el +++ b/lisp/bindings.el @@ -288,7 +288,7 @@ mnemonics of the following coding systems: Value is used for `mode-line-frame-identification', which see." (if (or (null window-system) (eq window-system 'pc)) - "-%F " + " %F " " ")) ;; We need to defer the call to mode-line-frame-control to the time @@ -501,8 +501,9 @@ mouse-1: Display Line and Column Mode Menu")) (defvar mode-line-position `((:propertize - mode-line-percent-position + (" " mode-line-percent-position) local-map ,mode-line-column-line-number-mode-map + display (min-width (5.0)) mouse-face mode-line-highlight ;; XXX needs better description help-echo "Window Scroll Percentage @@ -521,26 +522,31 @@ mouse-1: Display Line and Column Mode Menu"))) (10 (:propertize mode-line-position-column-line-format + display (min-width (10.0)) ,@mode-line-position--column-line-properties)) (10 (:propertize (:eval (string-replace "%c" "%C" (car mode-line-position-column-line-format))) + display (min-width (10.0)) ,@mode-line-position--column-line-properties))) (6 (:propertize mode-line-position-line-format + display (min-width (6.0)) ,@mode-line-position--column-line-properties)))) (column-number-mode (column-number-indicator-zero-based (6 (:propertize mode-line-position-column-format + display (min-width (6.0)) (,@mode-line-position--column-line-properties))) (6 (:propertize (:eval (string-replace "%c" "%C" (car mode-line-position-column-format))) + display (min-width (6.0)) ,@mode-line-position--column-line-properties)))))) "Mode line construct for displaying the position in the buffer. Normally displays the buffer percentage and, optionally, the @@ -597,10 +603,14 @@ By default, this shows the information specified by `global-mode-string'.") (let ((standard-mode-line-format (list "%e" 'mode-line-front-space - 'mode-line-mule-info - 'mode-line-client - 'mode-line-modified - 'mode-line-remote + (list + :propertize + (list "" + 'mode-line-mule-info + 'mode-line-client + 'mode-line-modified + 'mode-line-remote) + 'display '(min-width (5.0))) 'mode-line-frame-identification 'mode-line-buffer-identification " " @@ -1251,6 +1261,8 @@ if `inhibit-field-text-motion' is non-nil." ;; (define-key global-map [kp-9] 'function-key-error) ;; (define-key global-map [kp-equal] 'function-key-error) +(define-key global-map [touch-end] 'ignore) + ;; X11 distinguishes these keys from the non-kp keys. ;; Make them behave like the non-kp keys unless otherwise bound. ;; FIXME: rather than list such mappings for every modifier-combination, diff --git a/lisp/bookmark.el b/lisp/bookmark.el index 623f0acd28a..f35cbc1a5ec 100644 --- a/lisp/bookmark.el +++ b/lisp/bookmark.el @@ -214,31 +214,28 @@ A non-nil value may result in truncated bookmark names." ;;;###autoload (define-key ctl-x-r-map "l" 'bookmark-bmenu-list) ;;;###autoload -(defvar bookmark-map - (let ((map (make-sparse-keymap))) - ;; Read the help on all of these functions for details... - (define-key map "x" 'bookmark-set) - (define-key map "m" 'bookmark-set) ;"m"ark - (define-key map "M" 'bookmark-set-no-overwrite) ;"M"aybe mark - (define-key map "j" 'bookmark-jump) - (define-key map "g" 'bookmark-jump) ;"g"o - (define-key map "o" 'bookmark-jump-other-window) - (define-key map "5" 'bookmark-jump-other-frame) - (define-key map "i" 'bookmark-insert) - (define-key map "e" 'edit-bookmarks) - (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) - map) - "Keymap containing bindings to bookmark functions. +(defvar-keymap bookmark-map + :doc "Keymap containing bindings to bookmark functions. It is not bound to any key by default: to bind it so that you have a bookmark prefix, just use `global-set-key' and bind a key of your choice to variable `bookmark-map'. All interactive bookmark -functions have a binding in this keymap.") +functions have a binding in this keymap." + "x" #'bookmark-set + "m" #'bookmark-set ;"m"ark + "M" #'bookmark-set-no-overwrite ;"M"aybe mark + "j" #'bookmark-jump + "g" #'bookmark-jump ;"g"o + "o" #'bookmark-jump-other-window + "5" #'bookmark-jump-other-frame + "i" #'bookmark-insert + "e" #'edit-bookmarks + "f" #'bookmark-insert-location ;"f"ind + "r" #'bookmark-rename + "d" #'bookmark-delete + "D" #'bookmark-delete-all + "l" #'bookmark-load + "w" #'bookmark-write + "s" #'bookmark-save) ;;;###autoload (fset 'bookmark-map bookmark-map) @@ -501,11 +498,8 @@ If DEFAULT is nil then return empty string for empty input." 'string-lessp) (bookmark-all-names))) (let* ((completion-ignore-case bookmark-completion-ignore-case) - (default (unless (equal "" default) default)) - (prompt (concat prompt (if default - (format " (%s): " default) - ": ")))) - (completing-read prompt + (default (unless (equal "" default) default))) + (completing-read (format-prompt prompt default) (lambda (string pred action) (if (eq action 'metadata) '(metadata (category . bookmark)) @@ -516,8 +510,9 @@ If DEFAULT is nil then return empty string for empty input." (defmacro bookmark-maybe-historicize-string (string) "Put STRING into the bookmark prompt history, if caller non-interactive. -We need this because sometimes bookmark functions are invoked from -menus, so `completing-read' never gets a chance to set `bookmark-history'." +We need this because sometimes bookmark functions are invoked +from other commands that pass in the bookmark name, so +`completing-read' never gets a chance to set `bookmark-history'." `(or (called-interactively-p 'interactive) (setq bookmark-history (cons ,string bookmark-history)))) @@ -816,11 +811,9 @@ CODING is the symbol of the coding-system in which the file is encoded." (define-obsolete-function-alias 'bookmark-maybe-message 'message "27.1") -(defvar bookmark-minibuffer-read-name-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map minibuffer-local-map) - (define-key map "\C-w" 'bookmark-yank-word) - map)) +(defvar-keymap bookmark-minibuffer-read-name-map + :parent minibuffer-local-map + "C-w" #'bookmark-yank-word) (defun bookmark-set-internal (prompt name overwrite-or-push) "Set a bookmark using specified NAME or prompting with PROMPT. @@ -924,7 +917,7 @@ it removes only the first instance of a bookmark with that name from the list of bookmarks.)" (interactive (list nil current-prefix-arg)) (let ((prompt - (if no-overwrite "Set bookmark" "Set bookmark unconditionally"))) + (if no-overwrite "Append bookmark named" "Set bookmark named"))) (bookmark-set-internal prompt name (if no-overwrite 'push 'overwrite)))) ;;;###autoload @@ -995,12 +988,10 @@ annotations." "Function to return default text to use for a bookmark annotation. It takes one argument, the name of the bookmark, as a string.") -(defvar bookmark-edit-annotation-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map text-mode-map) - (define-key map "\C-c\C-c" 'bookmark-send-edited-annotation) - map) - "Keymap for editing an annotation of a bookmark.") +(defvar-keymap bookmark-edit-annotation-mode-map + :doc "Keymap for editing an annotation of a bookmark." + :parent text-mode-map + "C-c C-c" #'bookmark-send-edited-annotation) (defun bookmark-insert-annotation (bookmark-name-or-record) "Insert annotation for BOOKMARK-NAME-OR-RECORD at point." @@ -1703,44 +1694,42 @@ unique numeric suffixes \"<2>\", \"<3>\", etc." (defvar bookmark-bmenu-hidden-bookmarks ()) - -(defvar bookmark-bmenu-mode-map - (let ((map (make-keymap))) - (set-keymap-parent map tabulated-list-mode-map) - (define-key map "v" 'bookmark-bmenu-select) - (define-key map "w" 'bookmark-bmenu-locate) - (define-key map "5" 'bookmark-bmenu-other-frame) - (define-key map "2" 'bookmark-bmenu-2-window) - (define-key map "1" 'bookmark-bmenu-1-window) - (define-key map "j" 'bookmark-bmenu-this-window) - (define-key map "\C-c\C-c" 'bookmark-bmenu-this-window) - (define-key map "f" 'bookmark-bmenu-this-window) - (define-key map "\C-m" 'bookmark-bmenu-this-window) - (define-key map "o" 'bookmark-bmenu-other-window) - (define-key map "\C-o" 'bookmark-bmenu-switch-other-window) - (define-key map "s" 'bookmark-bmenu-save) - (define-key map "\C-x\C-s" 'bookmark-bmenu-save) - (define-key map "k" 'bookmark-bmenu-delete) - (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 "\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) - (define-key map "t" 'bookmark-bmenu-toggle-filenames) - (define-key map "a" 'bookmark-bmenu-show-annotation) - (define-key map "A" 'bookmark-bmenu-show-all-annotations) - (define-key map "e" 'bookmark-bmenu-edit-annotation) - (define-key map "/" 'bookmark-bmenu-search) - (define-key map [mouse-2] 'bookmark-bmenu-other-window-with-mouse) - map)) +(defvar-keymap bookmark-bmenu-mode-map + :doc "Keymap for `bookmark-bmenu-mode'." + :parent tabulated-list-mode-map + "v" #'bookmark-bmenu-select + "w" #'bookmark-bmenu-locate + "5" #'bookmark-bmenu-other-frame + "2" #'bookmark-bmenu-2-window + "1" #'bookmark-bmenu-1-window + "j" #'bookmark-bmenu-this-window + "C-c C-c" #'bookmark-bmenu-this-window + "f" #'bookmark-bmenu-this-window + "C-m" #'bookmark-bmenu-this-window + "o" #'bookmark-bmenu-other-window + "C-o" #'bookmark-bmenu-switch-other-window + "s" #'bookmark-bmenu-save + "C-x C-s" #'bookmark-bmenu-save + "k" #'bookmark-bmenu-delete + "C-d" #'bookmark-bmenu-delete-backwards + "x" #'bookmark-bmenu-execute-deletions + "d" #'bookmark-bmenu-delete + "D" #'bookmark-bmenu-delete-all + "SPC" #'next-line + "DEL" #'bookmark-bmenu-backup-unmark + "u" #'bookmark-bmenu-unmark + "U" #'bookmark-bmenu-unmark-all + "m" #'bookmark-bmenu-mark + "M" #'bookmark-bmenu-mark-all + "l" #'bookmark-bmenu-load + "r" #'bookmark-bmenu-rename + "R" #'bookmark-bmenu-relocate + "t" #'bookmark-bmenu-toggle-filenames + "a" #'bookmark-bmenu-show-annotation + "A" #'bookmark-bmenu-show-all-annotations + "e" #'bookmark-bmenu-edit-annotation + "/" #'bookmark-bmenu-search + "<mouse-2>" #'bookmark-bmenu-other-window-with-mouse) (easy-menu-define bookmark-menu bookmark-bmenu-mode-map "Menu for `bookmark-bmenu'." @@ -2320,10 +2309,10 @@ Prompt with completion for the new path." (lambda () (setq timer (run-with-idle-timer bookmark-search-delay 'repeat - #'(lambda (buf) - (with-current-buffer buf - (bookmark-bmenu-filter-alist-by-regexp - (minibuffer-contents)))) + (lambda (buf) + (with-current-buffer buf + (bookmark-bmenu-filter-alist-by-regexp + (minibuffer-contents)))) (current-buffer)))) (read-string "Pattern: ") (when timer (cancel-timer timer) (setq timer nil))) diff --git a/lisp/button.el b/lisp/button.el index aedd07b762d..dd5a71d116a 100644 --- a/lisp/button.el +++ b/lisp/button.el @@ -130,6 +130,7 @@ In addition, the keyword argument :supertype may be used to specify a `button-type' from which NAME inherits its default property values (however, the inheritance happens only when NAME is defined; subsequent changes to a supertype are not reflected in its subtypes)." + (declare (indent defun)) (let ((catsym (make-symbol (concat (symbol-name name) "-button"))) (super-catsym (button-category-symbol @@ -603,7 +604,8 @@ 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) + (let* ((help-buffer-under-preparation t) + (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))) @@ -615,13 +617,19 @@ button at point is the button to describe." (button--describe props) t))) -(defun button-buttonize (string callback &optional data) +(define-obsolete-function-alias 'button-buttonize #'buttonize "29.1") + +(defun buttonize (string callback &optional data help-echo) "Make STRING into a button and return it. When clicked, CALLBACK will be called with the DATA as the function argument. If DATA isn't present (or is nil), the button -itself will be used instead as the function argument." +itself will be used instead as the function argument. + +If HELP-ECHO, use that as the `help-echo' property." (propertize string 'face 'button + 'mouse-face 'highlight + 'help-echo help-echo 'button t 'follow-link t 'category t diff --git a/lisp/calc/calc-ext.el b/lisp/calc/calc-ext.el index dbe2f689d85..93ba8c4b6bb 100644 --- a/lisp/calc/calc-ext.el +++ b/lisp/calc/calc-ext.el @@ -1266,27 +1266,23 @@ calc-kill calc-kill-region calc-yank)))) (math-normalize val))))) -(defvar calc-help-map nil) - -(if calc-help-map - nil - (setq calc-help-map (make-keymap)) - (define-key calc-help-map "b" 'calc-describe-bindings) - (define-key calc-help-map "c" 'calc-describe-key-briefly) - (define-key calc-help-map "f" 'calc-describe-function) - (define-key calc-help-map "h" 'calc-full-help) - (define-key calc-help-map "i" 'calc-info) - (define-key calc-help-map "k" 'calc-describe-key) - (define-key calc-help-map "n" 'calc-view-news) - (define-key calc-help-map "s" 'calc-info-summary) - (define-key calc-help-map "t" 'calc-tutorial) - (define-key calc-help-map "v" 'calc-describe-variable) - (define-key calc-help-map "\C-c" 'calc-describe-copying) - (define-key calc-help-map "\C-d" 'calc-describe-distribution) - (define-key calc-help-map "\C-n" 'calc-view-news) - (define-key calc-help-map "\C-w" 'calc-describe-no-warranty) - (define-key calc-help-map "?" 'calc-help-for-help) - (define-key calc-help-map "\C-h" 'calc-help-for-help)) +(defvar-keymap calc-help-map + "b" 'calc-describe-bindings + "c" 'calc-describe-key-briefly + "f" 'calc-describe-function + "h" 'calc-full-help + "i" 'calc-info + "k" 'calc-describe-key + "n" 'calc-view-news + "s" 'calc-info-summary + "t" 'calc-tutorial + "v" 'calc-describe-variable + "C-c" 'calc-describe-copying + "C-d" 'calc-describe-distribution + "C-n" 'calc-view-news + "C-w" 'calc-describe-no-warranty + "?" 'calc-help-for-help + "C-h" 'calc-help-for-help) (defvar calc-prefix-help-retry nil) (defvar calc-prefix-help-phase 0) diff --git a/lisp/calc/calc-graph.el b/lisp/calc/calc-graph.el index 7891e35c40f..b6ee124a72f 100644 --- a/lisp/calc/calc-graph.el +++ b/lisp/calc/calc-graph.el @@ -969,7 +969,8 @@ This \"dumb\" driver will be present in Gnuplot 3.0." (define-key calc-dumb-map "\C-c\C-c" 'exit-recursive-edit))) (use-local-map calc-dumb-map) (setq truncate-lines t) - (message "Type `q' or `C-c C-c' to return to Calc") + (message (substitute-command-keys + "Type \\`q' or \\`C-c C-c' to return to Calc")) (recursive-edit) (bury-buffer "*Gnuplot Trail*"))) diff --git a/lisp/calc/calc-help.el b/lisp/calc/calc-help.el index dd5063f27d5..2633d64fe42 100644 --- a/lisp/calc/calc-help.el +++ b/lisp/calc/calc-help.el @@ -50,25 +50,25 @@ (beep)))) (defun calc-help-for-help (arg) - "You have typed `h', the Calc help character. Type a Help option: + "You have typed \\`h', the Calc help character. Type a Help option: -B calc-describe-bindings. Display a table of all key bindings. -H calc-full-help. Display all `?' key messages at once. +\\`B' calc-describe-bindings. Display a table of all key bindings. +\\`H' calc-full-help. Display all \\`?' key messages at once. -I calc-info. Read the Calc manual using the Info system. -T calc-tutorial. Read the Calc tutorial using the Info system. -S calc-info-summary. Read the Calc summary using the Info system. +\\`I' calc-info. Read the Calc manual using the Info system. +\\`T' calc-tutorial. Read the Calc tutorial using the Info system. +\\`S' calc-info-summary. Read the Calc summary using the Info system. -C calc-describe-key-briefly. Look up the command name for a given key. -K calc-describe-key. Look up a key's documentation in the manual. -F calc-describe-function. Look up a function's documentation in the manual. -V calc-describe-variable. Look up a variable's documentation in the manual. +\\`C' calc-describe-key-briefly. Look up the command name for a given key. +\\`K' calc-describe-key. Look up a key's documentation in the manual. +\\`F' calc-describe-function. Look up a function's documentation in the manual. +\\`V' calc-describe-variable. Look up a variable's documentation in the manual. -N calc-view-news. Display Calc history of changes. +\\`N' calc-view-news. Display Calc history of changes. -C-c Describe conditions for copying Calc. -C-d Describe how you can get a new copy of Calc or report a bug. -C-w Describe how there is no warranty for Calc." +\\`C-c' Describe conditions for copying Calc. +\\`C-d' Describe how you can get a new copy of Calc or report a bug. +\\`C-w' Describe how there is no warranty for Calc." (interactive "P") (if calc-dispatch-help (let (key) @@ -111,9 +111,6 @@ C-w Describe how there is no warranty for Calc." (with-current-buffer "*Help*" (let ((inhibit-read-only t)) (goto-char (point-min)) - (when (search-forward "Major Mode Bindings:" nil t) - (delete-region (point-min) (point)) - (insert "Calc Mode Bindings:")) (when (search-forward "Global bindings:" nil t) (forward-line -1) (delete-region (point) (point-max))) diff --git a/lisp/calc/calc-math.el b/lisp/calc/calc-math.el index 1c2e7bcf2bc..ba2b6b2ca9c 100644 --- a/lisp/calc/calc-math.el +++ b/lisp/calc/calc-math.el @@ -618,8 +618,9 @@ If this can't be done, return NIL." (defun math-nth-root-float (a nrf-n &optional guess) (math-inexact-result) (math-with-extra-prec 1 - (let ((math-nrf-nf (math-float nrf-n)) - (math-nrf-nfm1 (math-float (1- nrf-n)))) + (let ((math-nrf-n nrf-n) + (math-nrf-nf (math-float nrf-n)) + (math-nrf-nfm1 (math-float (1- nrf-n)))) (math-nth-root-float-iter a (or guess (math-make-float 1 (/ (+ (math-numdigs (nth 1 a)) diff --git a/lisp/calc/calc-misc.el b/lisp/calc/calc-misc.el index c8394e8c2fa..1c4438e7f7a 100644 --- a/lisp/calc/calc-misc.el +++ b/lisp/calc/calc-misc.el @@ -216,26 +216,28 @@ Calc user interface as before (either C-x * C or C-x * K; initially C-x * C)." (defun calc-help () (interactive) (let ((msgs - '("Press `h' for complete help; press `?' repeatedly for a summary" - "Letter keys: Negate; Precision; Yank; Why; Xtended cmd; Quit" - "Letter keys: SHIFT + Undo, reDo; Inverse, Hyperbolic, Option" - "Letter keys: SHIFT + sQrt; Sin, Cos, Tan; Exp, Ln, logB" - "Letter keys: SHIFT + Floor, Round; Abs, conJ, arG; Pi" - "Letter keys: SHIFT + Num-eval; More-recn; eXec-kbd-macro; Keep-args" - "Other keys: +, -, *, /, ^, \\ (int div), : (frac div)" - "Other keys: & (1/x), | (concat), % (modulo), ! (factorial)" - "Other keys: \\=' (alg-entry), = (eval), \\=` (edit); M-RET (last-args)" - "Other keys: SPC/RET (enter/dup), LFD (over); < > (scroll horiz)" - "Other keys: DEL (drop), M-DEL (drop-above); { } (scroll vert)" - "Other keys: TAB (swap/roll-dn), M-TAB (roll-up)" - "Other keys: [ , ; ] (vector), ( , ) (complex), ( ; ) (polar)" - "Prefix keys: Algebra, Binary/business, Convert, Display" - "Prefix keys: Functions, Graphics, Help, J (select)" - "Prefix keys: Kombinatorics/statistics, Modes, Store/recall" - "Prefix keys: Trail/time, Units/statistics, Vector/matrix" - "Prefix keys: Z (user), SHIFT + Z (define)" - "Prefix keys: prefix + ? gives further help for that prefix" - " Calc by Dave Gillespie, daveg@synaptics.com"))) + ;; FIXME: Change these to `substitute-command-keys' syntax. + (mapcar #'substitute-command-keys + '("Press \\`h' for complete help; press \\`?' repeatedly for a summary" + "Letter keys: Negate; Precision; Yank; Why; Xtended cmd; Quit" + "Letter keys: SHIFT + Undo, reDo; Inverse, Hyperbolic, Option" + "Letter keys: SHIFT + sQrt; Sin, Cos, Tan; Exp, Ln, logB" + "Letter keys: SHIFT + Floor, Round; Abs, conJ, arG; Pi" + "Letter keys: SHIFT + Num-eval; More-recn; eXec-kbd-macro; Keep-args" + "Other keys: +, -, *, /, ^, \\ (int div), : (frac div)" + "Other keys: & (1/x), | (concat), % (modulo), ! (factorial)" + "Other keys: \\=' (alg-entry), = (eval), \\=` (edit); M-RET (last-args)" + "Other keys: \\`SPC'/\\`RET' (enter/dup), LFD (over); < > (scroll horiz)" + "Other keys: \\`DEL' (drop), \\`M-DEL' (drop-above); { } (scroll vert)" + "Other keys: \\`TAB' (swap/roll-dn), \\`M-TAB' (roll-up)" + "Other keys: [ , ; ] (vector), ( , ) (complex), ( ; ) (polar)" + "Prefix keys: Algebra, Binary/business, Convert, Display" + "Prefix keys: Functions, Graphics, Help, J (select)" + "Prefix keys: Kombinatorics/statistics, Modes, Store/recall" + "Prefix keys: Trail/time, Units/statistics, Vector/matrix" + "Prefix keys: Z (user), SHIFT + Z (define)" + "Prefix keys: prefix + ? gives further help for that prefix" + " Calc by Dave Gillespie, daveg@synaptics.com")))) (if calc-full-help-flag msgs (if (or calc-inverse-flag calc-hyperbolic-flag) diff --git a/lisp/calc/calc-mode.el b/lisp/calc/calc-mode.el index 68c8b90ac3b..211b8e661fd 100644 --- a/lisp/calc/calc-mode.el +++ b/lisp/calc/calc-mode.el @@ -109,11 +109,14 @@ (setq n (and (not (eq calc-auto-why t)) (if calc-auto-why t 1)))) (calc-change-mode 'calc-auto-why n nil) (cond ((null n) - (message "User must press `w' to explain unsimplified results")) + (message (substitute-command-keys + "User must press \\`w' to explain unsimplified results"))) ((eq n t) - (message "Automatically doing `w' to explain unsimplified results")) + (message (substitute-command-keys + "Automatically doing \\`w' to explain unsimplified results"))) (t - (message "Automatically doing `w' only for unusual messages"))))) + (message (substitute-command-keys + "Automatically doing \\`w' only for unusual messages")))))) (defun calc-group-digits (n) (interactive "P") diff --git a/lisp/calc/calc-prog.el b/lisp/calc/calc-prog.el index 3492b6d831b..b381f8afcf9 100644 --- a/lisp/calc/calc-prog.el +++ b/lisp/calc/calc-prog.el @@ -205,9 +205,8 @@ (progn (setq cmd-base-default (concat "User-" keyname)) (setq cmd (completing-read - (concat "Define M-x command name (default calc-" - cmd-base-default - "): ") + (format-prompt "Define M-x command name" + (concat "calc-" cmd-base-default)) obarray 'commandp nil (if (and odef (symbolp (cdr odef))) (symbol-name (cdr odef)) @@ -241,8 +240,8 @@ (setq func (concat "calcFunc-" (completing-read - (concat "Define algebraic function name (default " - cmd-base-default "): ") + (format-prompt "Define algebraic function name" + cmd-base-default) (mapcar (lambda (x) (substring x 9)) (all-completions "calcFunc-" obarray)) diff --git a/lisp/calc/calc-store.el b/lisp/calc/calc-store.el index ee29c440fe4..817b50951dd 100644 --- a/lisp/calc/calc-store.el +++ b/lisp/calc/calc-store.el @@ -163,19 +163,19 @@ tag (and (not val) 1)) (message "Variable \"%s\" changed" (calc-var-name var))))))) -(defvar calc-var-name-map nil "Keymap for reading Calc variable names.") -(if calc-var-name-map - () - (setq calc-var-name-map (copy-keymap minibuffer-local-completion-map)) - (define-key calc-var-name-map " " 'self-insert-command) - (mapc (lambda (x) - (define-key calc-var-name-map (char-to-string x) - 'calcVar-digit)) - "0123456789") - (mapc (lambda (x) - (define-key calc-var-name-map (char-to-string x) - 'calcVar-oper)) - "+-*/^|")) +(defvar calc-var-name-map + (let ((map (copy-keymap minibuffer-local-completion-map))) + (define-key map " " #'self-insert-command) + (mapc (lambda (x) + (define-key map (char-to-string x) + #'calcVar-digit)) + "0123456789") + (mapc (lambda (x) + (define-key map (char-to-string x) + #'calcVar-oper)) + "+-*/^|") + map) + "Keymap for reading Calc variable names.") (defvar calc-store-opers) @@ -188,12 +188,15 @@ (let* ((calc-store-opers store-opers) (var (concat "var-" - (let ((minibuffer-completion-table - (mapcar (lambda (x) (substring x 4)) - (all-completions "var-" obarray))) - (minibuffer-completion-predicate - (lambda (x) (boundp (intern (concat "var-" x))))) - (minibuffer-completion-confirm t)) + (minibuffer-with-setup-hook + (lambda () + (setq-local minibuffer-completion-table + (mapcar (lambda (x) (substring x 4)) + (all-completions "var-" obarray))) + (setq-local minibuffer-completion-predicate + (lambda (x) + (boundp (intern (concat "var-" x))))) + (setq-local minibuffer-completion-confirm t)) (read-from-minibuffer prompt nil calc-var-name-map nil 'calc-read-var-name-history))))) @@ -586,7 +589,7 @@ (defun calc-permanent-variable (&optional var) (interactive) (calc-wrapper - (or var (setq var (calc-read-var-name "Save variable (default all): "))) + (or var (setq var (calc-read-var-name (format-prompt "Save variable" "all")))) (let (calc-pv-pos) (and var (or (and (boundp var) (symbol-value var)) (error "No such variable"))) diff --git a/lisp/calc/calc-units.el b/lisp/calc/calc-units.el index fd6f3a7b67b..f6d749db117 100644 --- a/lisp/calc/calc-units.el +++ b/lisp/calc/calc-units.el @@ -486,18 +486,13 @@ If COMP or STD is non-nil, put that in the units table instead." (setq defunits (math-get-default-units expr)) (unless new-units (setq new-units - (read-string (concat + (read-string (format-prompt (if (and uoldname (not nouold)) (concat "Old units: " uoldname ", new units") "New units") - (if defunits - (concat - " (default " - defunits - "): ") - ": ")))) + defunits))) (if (and (string= new-units "") defunits) @@ -533,14 +528,7 @@ If COMP or STD is non-nil, put that in the units table instead." (let* ((old-units (math-extract-units expr)) (defunits (math-get-default-units expr)) units - (new-units - (read-string (concat "New units" - (if defunits - (concat - " (default " - defunits - "): ") - ": "))))) + (new-units (read-string (format-prompt "New units" defunits)))) (if (and (string= new-units "") defunits) @@ -596,19 +584,14 @@ If COMP or STD is non-nil, put that in the units table instead." (setq expr (math-mul expr uold))) (setq defunits (math-get-default-units expr)) (setq unew (or new-units - (completing-read - (concat - (if uoldname - (concat "Old temperature units: " - uoldname - ", new units") - "New temperature units") - (if defunits - (concat " (default " - defunits - "): ") - ": ")) - tempunits))) + (completing-read (format-prompt + (if uoldname + (concat "Old temperature units: " + uoldname + ", new units") + "New temperature units") + defunits) + tempunits))) (setq unew (math-read-expr (if (string= unew "") defunits unew))) (when (eq (car-safe unew) 'error) (error "Bad format in units expression: %s" (nth 2 unew))) diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el index e97315165b3..d426e2829f8 100644 --- a/lisp/calc/calc.el +++ b/lisp/calc/calc.el @@ -494,7 +494,7 @@ This setting only applies to floats in normal display mode.") (defmacro defcalcmodevar (var defval &optional doc) "Declare VAR as a Calc variable, with default value DEFVAL and doc-string DOC. The variable VAR will be added to `calc-mode-var-list'." - (declare (doc-string 3)) + (declare (doc-string 3) (indent defun)) `(progn (defvar ,var ,defval ,doc) (add-to-list 'calc-mode-var-list (list (quote ,var) ,defval)))) @@ -1621,7 +1621,8 @@ See calc-keypad for details." (stringp (nth 1 err)) (string-match "max-specpdl-size\\|max-lisp-eval-depth" (nth 1 err))) - (error "Computation got stuck or ran too long. Type `M' to increase the limit") + (error (substitute-command-keys + "Computation got stuck or ran too long. Type \\`M' to increase the limit")) (setq calc-aborted-prefix nil) (signal (car err) (cdr err))))) (when calc-aborted-prefix @@ -3439,7 +3440,7 @@ The prefix `calcFunc-' is added to the specified name to get the actual Lisp function name. See Info node `(calc)Defining Functions'." - (declare (doc-string 3)) ;; FIXME: Edebug spec? + (declare (doc-string 3) (indent defun)) ;; FIXME: Edebug spec? (require 'calc-ext) (math-do-defmath func args body)) diff --git a/lisp/calculator.el b/lisp/calculator.el index 6bcea2d885e..0c255c0cf9d 100644 --- a/lisp/calculator.el +++ b/lisp/calculator.el @@ -593,15 +593,15 @@ except when using a non-decimal radix mode for input (in this case `e' will be the hexadecimal digit). Here are the editing keys: -* `RET' `=' evaluate the current expression -* `C-insert' copy the whole current expression to the `kill-ring' -* `C-return' evaluate, save result the `kill-ring' and exit -* `insert' paste a number if the one was copied (normally) -* `delete' `C-d' clear last argument or whole expression (hit twice) -* `backspace' delete a digit or a previous expression element -* `h' `?' pop-up a quick reference help -* `ESC' `q' exit (`ESC' can be used if `calculator-bind-escape' is - non-nil, otherwise use three consecutive `ESC's) +* \\`RET' \\`=' evaluate the current expression +* \\`C-<insert>' copy the whole current expression to the `kill-ring' +* \\`C-<return>' evaluate, save result the `kill-ring' and exit +* \\`<insert>' paste a number if the one was copied (normally) +* \\`<delete>' \\`C-d' clear last argument or whole expression (hit twice) +* \\`<backspace>' delete a digit or a previous expression element +* \\`h' \\`?' pop-up a quick reference help +* \\`ESC' \\`q' exit (\\`ESC' can be used if `calculator-bind-escape' is + non-nil, otherwise use three consecutive \\`ESC's) These operators are pre-defined: * `+' `-' `*' `/' the common binary operators @@ -623,10 +623,10 @@ argument. hex/oct/bin modes can be set for input and for display separately. Another toggle-able mode is for using degrees instead of radians for trigonometric functions. -The keys to switch modes are (both `H' and `X' are for hex): -* `D' switch to all-decimal mode, or toggle degrees/radians -* `B' `O' `H' `X' binary/octal/hexadecimal modes for input & display -* `i' `o' followed by one of `D' `B' `O' `H' `X' (case +The keys to switch modes are (both \\`H' and \\`X' are for hex): +* \\`D' switch to all-decimal mode, or toggle degrees/radians +* \\`B' \\`O' \\`H' \\`X' binary/octal/hexadecimal modes for input & display +* \\`i' \\`o' followed by one of \\`D' \\`B' \\`O' \\`H' \\`X' (case insensitive) sets only the input or display radix mode The prompt indicates the current modes: * \"==\": decimal mode (using radians); @@ -649,17 +649,17 @@ collected data. It is possible to navigate in this list, and if the value shown is the current one on the list, an indication is displayed as \"[N]\" if this is the last number and there are N numbers, or \"[M/N]\" if the M-th value is shown. -* `SPC' evaluate the current value as usual, but also adds +* \\`SPC' evaluate the current value as usual, but also adds the result to the list of saved values -* `l' `v' computes total / average of saved values -* `up' `C-p' browse to the previous value in the list -* `down' `C-n' browse to the next value in the list -* `delete' `C-d' remove current value from the list (if it is on it) -* `C-delete' `C-c' delete the whole list +* \\`l' \\`v' computes total / average of saved values +* \\`<up>' \\`C-p' browse to the previous value in the list +* \\`<down>' \\`C-n' browse to the next value in the list +* \\`<delete>' \\`C-d' remove current value from the list (if it is on it) +* \\`C-<delete>' \\`C-c' delete the whole list Registers are variable-like place-holders for values: -* `s' followed by a character attach the current value to that character -* `g' followed by a character fetches the attached value +* \\`s' followed by a character attach the current value to that character +* \\`g' followed by a character fetches the attached value There are many variables that can be used to customize the calculator. Some interesting customization variables are: diff --git a/lisp/calendar/icalendar.el b/lisp/calendar/icalendar.el index 2d31101e50e..7a483d40627 100644 --- a/lisp/calendar/icalendar.el +++ b/lisp/calendar/icalendar.el @@ -644,13 +644,13 @@ FIXME: multiple comma-separated values should be allowed!" ;; seconds present (setq second (read (substring isodatetimestring 13 15)))) ;; FIXME: Support subseconds. - (when (and (> (length isodatetimestring) 15) - ;; UTC specifier present - (char-equal ?Z (aref isodatetimestring 15))) - (setq source-zone t - ;; decode to local time unless result-zone is explicitly given, - ;; i.e. do not decode to UTC, i.e. do not (setq result-zone t) - )) + (when (> (length isodatetimestring) 15) + (cl-case (aref isodatetimestring 15) + (?Z + (setq source-zone t)) + ((?- ?+) + (setq source-zone + (concat "UTC" (substring isodatetimestring 15)))))) ;; shift if necessary (if day-shift (let ((mdy (calendar-gregorian-from-absolute diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el index 0aa38166bc1..b36171259c0 100644 --- a/lisp/calendar/time-date.el +++ b/lisp/calendar/time-date.el @@ -69,7 +69,7 @@ list (HIGH LOW MICRO PICO)." (pop elt))) (time-value (car elt)) (gensym (make-symbol "time"))) - `(let* ,(append `((,gensym (or ,time-value (current-time))) + `(let* ,(append `((,gensym (or ,time-value (time-convert nil 'list))) (,gensym (cond ((integerp ,gensym) @@ -154,7 +154,10 @@ it is assumed that PICO was omitted and should be treated as zero." DATE should be in one of the forms recognized by `parse-time-string'. If DATE lacks timezone information, GMT is assumed." (condition-case err - (encode-time (parse-time-string date)) + (let ((parsed (parse-time-string date))) + (when (decoded-time-year parsed) + (decoded-time-set-defaults parsed)) + (encode-time parsed)) (error (let ((overflow-error '(error "Specified time is not representable"))) (if (equal err overflow-error) @@ -406,7 +409,11 @@ entries only for the values that should be altered. For instance, if you want to \"add two months\" to TIME, then leave all other fields but the month field in DELTA nil, and make -the month field 2. The values in DELTA can be negative. +the month field 2. For instance: + + (decoded-time-add (decode-time) (make-decoded-time :month 2)) + +The values in DELTA can be negative. If applying a month/year delta leaves the time spec invalid, it is decreased to be valid (\"add one month\" to January 31st 2019 diff --git a/lisp/cedet/mode-local.el b/lisp/cedet/mode-local.el index 18fb05e7eb4..e0717fbfe5a 100644 --- a/lisp/cedet/mode-local.el +++ b/lisp/cedet/mode-local.el @@ -156,7 +156,7 @@ local variables have been defined." DOCSTRING is optional and not used. To work properly, this should be put after PARENT mode local variables definition." - (declare (obsolete define-derived-mode "27.1")) + (declare (obsolete define-derived-mode "27.1") (indent 2)) `(mode-local--set-parent ',mode ',parent)) (defun mode-local-use-bindings-p (this-mode desired-mode) @@ -567,6 +567,7 @@ appropriate arguments deduced from ARGS. OVERARGS is a list of arguments passed to the override and `NAME-default' function, in place of those deduced from ARGS." (declare (doc-string 3) + (indent defun) (debug (&define name lambda-list stringp def-body))) `(eval-and-compile (defun ,name ,args @@ -595,6 +596,7 @@ DOCSTRING is the documentation string. BODY is the implementation of this function." ;; FIXME: Make this obsolete and use cl-defmethod with &context instead. (declare (doc-string 4) + (indent defun) (debug (&define name symbolp lambda-list stringp def-body))) (let ((newname (intern (format "%s-%s" name mode)))) `(progn diff --git a/lisp/cedet/semantic/bovine/c.el b/lisp/cedet/semantic/bovine/c.el index c7d59def1f1..19e2fee2bac 100644 --- a/lisp/cedet/semantic/bovine/c.el +++ b/lisp/cedet/semantic/bovine/c.el @@ -1466,36 +1466,32 @@ Override function for `semantic-tag-protection'." (prot nil)) ;; Check the modifiers for protection if we are not a child ;; of some class type. - (when (or (not parent) (not (eq (semantic-tag-class parent) 'type))) - (while (and (not prot) mods) - (if (stringp (car mods)) - (let ((s (car mods))) - ;; A few silly defaults to get things started. - (cond ((or (string= s "extern") - (string= s "export")) - 'public) - ((string= s "static") - 'private)))) - (setq mods (cdr mods)))) - ;; If we have a typed parent, look for :public style labels. - (when (and parent (eq (semantic-tag-class parent) 'type)) + (if (not (and parent (eq (semantic-tag-class parent) 'type))) + (while (and (not prot) mods) + (if (stringp (car mods)) + (let ((s (car mods))) + ;; A few silly defaults to get things started. + (setq prot (pcase s + ((or "extern" "export") 'public) + ("static" 'private))))) + (setq mods (cdr mods))) + ;; If we have a typed parent, look for :public style labels. (let ((pp (semantic-tag-type-members parent))) (while (and pp (not (semantic-equivalent-tag-p (car pp) tag))) (when (eq (semantic-tag-class (car pp)) 'label) (setq prot - (cond ((string= (semantic-tag-name (car pp)) "public") - 'public) - ((string= (semantic-tag-name (car pp)) "private") - 'private) - ((string= (semantic-tag-name (car pp)) "protected") - 'protected))) + (pcase (semantic-tag-name (car pp)) + ("public" 'public) + ("private" 'private) + ("protected" 'protected))) ) (setq pp (cdr pp))))) (when (and (not prot) (eq (semantic-tag-class parent) 'type)) (setq prot - (cond ((string= (semantic-tag-type parent) "class") 'private) - ((string= (semantic-tag-type parent) "struct") 'public) - (t 'unknown)))) + (pcase (semantic-tag-type parent) + ("class" 'private) + ("struct" 'public) + (_ 'unknown)))) (or prot (if (and parent (semantic-tag-of-class-p parent 'type)) 'public diff --git a/lisp/cedet/semantic/complete.el b/lisp/cedet/semantic/complete.el index 6cfbdd5f03f..375b97a7a5d 100644 --- a/lisp/cedet/semantic/complete.el +++ b/lisp/cedet/semantic/complete.el @@ -224,11 +224,10 @@ HISTORY is a symbol representing a variable to story the history in." ;; @todo - move from () to into the editable area (if (string-match ":" prompt) - (setq prompt (concat - (substring prompt 0 (match-beginning 0)) - " (default " default-as-string ")" - (substring prompt (match-beginning 0)))) - (setq prompt (concat prompt " (" default-as-string "): ")))) + (setq prompt (format-prompt + (substring prompt 0 (match-beginning 0)) + default-as-string)) + (setq prompt (format-prompt prompt default-as-string)))) ;; ;; Perform the Completion ;; diff --git a/lisp/cedet/semantic/decorate/mode.el b/lisp/cedet/semantic/decorate/mode.el index 6271fb1ced6..0a234b3000d 100644 --- a/lisp/cedet/semantic/decorate/mode.el +++ b/lisp/cedet/semantic/decorate/mode.el @@ -391,6 +391,7 @@ etc., found in the semantic-decorate library. To add other kind of decorations on a tag, `NAME-highlight' must use `semantic-decorate-tag', and other functions of the semantic decoration API found in this library." + (declare (indent 1)) (let ((predicate (semantic-decorate-style-predicate name)) (highlighter (semantic-decorate-style-highlighter name)) (predicatedef (semantic-decorate-style-predicate-default name)) diff --git a/lisp/cedet/semantic/dep.el b/lisp/cedet/semantic/dep.el index 0694b9c2329..cae38e6f111 100644 --- a/lisp/cedet/semantic/dep.el +++ b/lisp/cedet/semantic/dep.el @@ -82,6 +82,7 @@ users will customize. Creates a customizable variable users can customize that will keep semantic data structures up to date." + (declare (indent defun)) `(progn ;; Create a variable users can customize. (defcustom ,name ,value diff --git a/lisp/cedet/semantic/fw.el b/lisp/cedet/semantic/fw.el index 16e8ce8de95..3502cda500e 100644 --- a/lisp/cedet/semantic/fw.el +++ b/lisp/cedet/semantic/fw.el @@ -66,8 +66,6 @@ (defalias 'semantic-mode-line-update #'force-mode-line-update) -;; Since Emacs 22 major mode functions should use `run-mode-hooks' to -;; run major mode hooks. (define-obsolete-function-alias 'semantic-run-mode-hooks #'run-mode-hooks "28.1") ;; Fancy compat usage now handled in cedet-compat diff --git a/lisp/cedet/semantic/grm-wy-boot.el b/lisp/cedet/semantic/grm-wy-boot.el index a6bf211713a..ce63421fb37 100644 --- a/lisp/cedet/semantic/grm-wy-boot.el +++ b/lisp/cedet/semantic/grm-wy-boot.el @@ -149,10 +149,10 @@ ((type_decl)) ((use_macros_decl))) (default_prec_decl - ((DEFAULT-PREC) - `(wisent-raw-tag - (semantic-tag "default-prec" 'assoc :value - '("t"))))) + ((DEFAULT-PREC) + `(wisent-raw-tag + (semantic-tag "default-prec" 'assoc :value + '("t"))))) (no_default_prec_decl ((NO-DEFAULT-PREC) `(wisent-raw-tag diff --git a/lisp/cedet/semantic/lex-spp.el b/lisp/cedet/semantic/lex-spp.el index 8073640a8bd..3297367db90 100644 --- a/lisp/cedet/semantic/lex-spp.el +++ b/lisp/cedet/semantic/lex-spp.el @@ -1165,7 +1165,8 @@ of type `spp-macro-def' is to be created. VALFORM are forms that return the value to be saved for this macro, or nil. When implementing a macro, you can use `semantic-lex-spp-stream-for-macro' to convert text into a lexical stream for storage in the macro." - (declare (debug (&define name stringp stringp form def-body))) + (declare (debug (&define name stringp stringp form def-body)) + (indent 1)) (let ((start (make-symbol "start")) (end (make-symbol "end")) (val (make-symbol "val")) @@ -1199,7 +1200,8 @@ REGEXP is a regular expression for the analyzer to match. See `define-lex-regex-analyzer' for more on regexp. TOKIDX is an index into REGEXP for which a new lexical token of type `spp-macro-undef' is to be created." - (declare (debug (&define name stringp stringp form))) + (declare (debug (&define name stringp stringp form)) + (indent 1)) (let ((start (make-symbol "start")) (end (make-symbol "end"))) `(define-lex-regex-analyzer ,name @@ -1260,7 +1262,8 @@ type of include. The return value should be of the form: (NAME . TYPE) where NAME is the name of the include, and TYPE is the type of the include, where a valid symbol is `system', or nil." - (declare (debug (&define name stringp stringp form def-body))) + (declare (debug (&define name stringp stringp form def-body)) + (indent 1)) (let ((start (make-symbol "start")) (end (make-symbol "end")) (val (make-symbol "val")) diff --git a/lisp/cedet/semantic/lex.el b/lisp/cedet/semantic/lex.el index 69f20deeb76..d524b733db5 100644 --- a/lisp/cedet/semantic/lex.el +++ b/lisp/cedet/semantic/lex.el @@ -760,7 +760,7 @@ If two analyzers can match the same text, it is important to order the analyzers so that the one you want to match first occurs first. For example, it is good to put a number analyzer in front of a symbol analyzer which might mistake a number for a symbol." - (declare (debug (&define name stringp (&rest symbolp)))) + (declare (debug (&define name stringp (&rest symbolp))) (indent 1)) `(defun ,name (start end &optional depth length) ,(concat doc "\nSee `semantic-lex' for more information.") ;; Make sure the state of block parsing starts over. @@ -1096,7 +1096,7 @@ Proper action in FORMS is to move the value of `semantic-lex-end-point' to after the location of the analyzed entry, and to add any discovered tokens at the beginning of `semantic-lex-token-stream'. This can be done by using `semantic-lex-push-token'." - (declare (debug (&define name stringp form def-body))) + (declare (debug (&define name stringp form def-body)) (indent 1)) `(eval-and-compile ;; This is the real info used by `define-lex' (via semantic-lex-one-token). (defconst ,name '(,condition ,@forms) ,doc) @@ -1118,7 +1118,7 @@ This can be done by using `semantic-lex-push-token'." "Create a lexical analyzer with NAME and DOC that will match REGEXP. FORMS are evaluated upon a successful match. See `define-lex-analyzer' for more about analyzers." - (declare (debug (&define name stringp form def-body))) + (declare (debug (&define name stringp form def-body)) (indent 1)) `(define-lex-analyzer ,name ,doc (looking-at ,regexp) @@ -1137,7 +1137,8 @@ FORMS are evaluated upon a successful match BEFORE the new token is created. It is valid to ignore FORMS. See `define-lex-analyzer' for more about analyzers." (declare (debug - (&define name stringp form symbolp [ &optional form ] def-body))) + (&define name stringp form symbolp [ &optional form ] def-body)) + (indent 1)) `(define-lex-analyzer ,name ,doc (looking-at ,regexp) @@ -1162,7 +1163,8 @@ where BLOCK-SYM is the symbol returned in a block token. OPEN-DELIM and CLOSE-DELIM are respectively the open and close delimiters identifying a block. OPEN-SYM and CLOSE-SYM are respectively the symbols returned in open and close tokens." - (declare (debug (&define name stringp form (&rest form)))) + (declare (debug (&define name stringp form (&rest form))) + (indent 1)) (let ((specs (cons spec1 specs)) spec open olist clist) (while specs @@ -1471,6 +1473,7 @@ syntax as specified by the syntax table." (defmacro define-lex-keyword-type-analyzer (name doc syntax) "Define a keyword type analyzer NAME with DOC string. SYNTAX is the regexp that matches a keyword syntactic expression." + (declare (indent 1)) (let ((key (make-symbol "key"))) `(define-lex-analyzer ,name ,doc @@ -1486,6 +1489,7 @@ SYNTAX is the regexp that matches a keyword syntactic expression." "Define a sexp type analyzer NAME with DOC string. SYNTAX is the regexp that matches the beginning of the s-expression. TOKEN is the lexical token returned when SYNTAX matches." + (declare (indent 1)) `(define-lex-regex-analyzer ,name ,doc ,syntax @@ -1504,6 +1508,7 @@ SYNTAX is the regexp that matches a syntactic expression. MATCHES is an alist of lexical elements used to refine the syntactic expression. DEFAULT is the default lexical token returned when no MATCHES." + (declare (indent 1)) (if matches (let* ((val (make-symbol "val")) (lst (make-symbol "lst")) @@ -1536,6 +1541,7 @@ SYNTAX is the regexp that matches a syntactic expression. MATCHES is an alist of lexical elements used to refine the syntactic expression. DEFAULT is the default lexical token returned when no MATCHES." + (declare (indent 1)) (if matches (let* ((val (make-symbol "val")) (lst (make-symbol "lst")) @@ -1633,6 +1639,7 @@ When the lexer encounters the open-paren delimiter \"(\": - If the maximum depth of parenthesis tracking is reached (current depth >= max depth), it returns the whole parenthesis block as a (PAREN_BLOCK start . end) token." + (declare (indent 1)) (let* ((val (make-symbol "val")) (lst (make-symbol "lst")) (elt (make-symbol "elt"))) diff --git a/lisp/cedet/semantic/wisent.el b/lisp/cedet/semantic/wisent.el index f5f381d4079..afcdd142822 100644 --- a/lisp/cedet/semantic/wisent.el +++ b/lisp/cedet/semantic/wisent.el @@ -66,7 +66,7 @@ Returned tokens must have the form: (TOKSYM VALUE START . END) where VALUE is the buffer substring between START and END positions." - (declare (debug (&define name stringp def-body))) + (declare (debug (&define name stringp def-body)) (indent 1)) `(defun ,name () ,doc (cond diff --git a/lisp/char-fold.el b/lisp/char-fold.el index e3ab7d5b64c..b8e3d2f6791 100644 --- a/lisp/char-fold.el +++ b/lisp/char-fold.el @@ -26,6 +26,7 @@ (eval-and-compile (put 'char-fold-table 'char-table-extra-slots 1) + (defconst char-fold--default-override nil) (defconst char-fold--default-include '((?\" "＂" "“" "”" "”" "„" "⹂" "〞" "‟" "‟" "❞" "❝" "❠" "“" "„" "〝" "〟" "🙷" "🙶" "🙸" "«" "»") (?' "❟" "❛" "❜" "‘" "’" "‚" "‛" "‚" "" "❮" "❯" "‹" "›") @@ -40,7 +41,8 @@ )) (defconst char-fold--default-symmetric nil) (defvar char-fold--previous - (list char-fold--default-include + (list char-fold--default-override + char-fold--default-include char-fold--default-exclude char-fold--default-symmetric))) @@ -67,48 +69,50 @@ ;; - A single char of the decomp might be allowed to match the ;; character. ;; Some examples in the comments below. - (map-char-table - (lambda (char decomp) - (when (consp decomp) - ;; Skip trivial cases like ?a decomposing to (?a). - (unless (and (not (cdr decomp)) - (eq char (car decomp))) - (if (symbolp (car decomp)) - ;; Discard a possible formatting tag. - (setq decomp (cdr decomp)) - ;; If there's no formatting tag, ensure that char matches - ;; its decomp exactly. This is because we want 'ä' to - ;; match 'ä', but we don't want '¹' to match '1'. - (aset equiv char - (cons (apply #'string decomp) - (aref equiv char)))) - - ;; Allow the entire decomp to match char. If decomp has - ;; multiple characters, this is done by adding an entry - ;; to the alist of the first character in decomp. This - ;; allows 'ff' to match 'ff', 'ä' to match 'ä', and '1' to - ;; match '¹'. - (let ((make-decomp-match-char - (lambda (decomp char) - (if (cdr decomp) - (aset equiv-multi (car decomp) - (cons (cons (apply #'string (cdr decomp)) - (regexp-quote (string char))) - (aref equiv-multi (car decomp)))) - (aset equiv (car decomp) - (cons (char-to-string char) - (aref equiv (car decomp)))))))) - (funcall make-decomp-match-char decomp char) - ;; Check to see if the first char of the decomposition - ;; has a further decomposition. If so, add a mapping - ;; back from that second decomposition to the original - ;; character. This allows e.g. 'ι' (GREEK SMALL LETTER - ;; IOTA) to match both the Basic Greek block and - ;; Extended Greek block variants of IOTA + - ;; diacritical(s). Repeat until there are no more - ;; decompositions. - (let ((dec decomp) - next-decomp) + (unless (or (bound-and-true-p char-fold-override) + char-fold--default-override) + (map-char-table + (lambda (char decomp) + (when (consp decomp) + ;; Skip trivial cases like ?a decomposing to (?a). + (unless (and (not (cdr decomp)) + (eq char (car decomp))) + (if (symbolp (car decomp)) + ;; Discard a possible formatting tag. + (setq decomp (cdr decomp)) + ;; If there's no formatting tag, ensure that char matches + ;; its decomp exactly. This is because we want 'ä' to + ;; match 'ä', but we don't want '¹' to match '1'. + (aset equiv char + (cons (apply #'string decomp) + (aref equiv char)))) + + ;; Allow the entire decomp to match char. If decomp has + ;; multiple characters, this is done by adding an entry + ;; to the alist of the first character in decomp. This + ;; allows 'ff' to match 'ff', 'ä' to match 'ä', and '1' to + ;; match '¹'. + (let ((make-decomp-match-char + (lambda (decomp char) + (if (cdr decomp) + (aset equiv-multi (car decomp) + (cons (cons (apply #'string (cdr decomp)) + (regexp-quote (string char))) + (aref equiv-multi (car decomp)))) + (aset equiv (car decomp) + (cons (char-to-string char) + (aref equiv (car decomp)))))))) + (funcall make-decomp-match-char decomp char) + ;; Check to see if the first char of the decomposition + ;; has a further decomposition. If so, add a mapping + ;; back from that second decomposition to the original + ;; character. This allows e.g. 'ι' (GREEK SMALL LETTER + ;; IOTA) to match both the Basic Greek block and + ;; Extended Greek block variants of IOTA + + ;; diacritical(s). Repeat until there are no more + ;; decompositions. + (let ((dec decomp) + next-decomp) (while dec (setq next-decomp (char-table-range table (car dec))) (when (consp next-decomp) @@ -118,24 +122,24 @@ (car next-decomp))) (funcall make-decomp-match-char (list (car next-decomp)) char))) (setq dec next-decomp))) - ;; Do it again, without the non-spacing characters. - ;; This allows 'a' to match 'ä'. - (let ((simpler-decomp nil) - (found-one nil)) - (dolist (c decomp) - (if (> (get-char-code-property c 'canonical-combining-class) 0) - (setq found-one t) - (push c simpler-decomp))) - (when (and simpler-decomp found-one) - (funcall make-decomp-match-char simpler-decomp char) - ;; Finally, if the decomp only had one spacing - ;; character, we allow this character to match the - ;; decomp. This is to let 'a' match 'ä'. - (unless (cdr simpler-decomp) - (aset equiv (car simpler-decomp) - (cons (apply #'string decomp) - (aref equiv (car simpler-decomp))))))))))) - table) + ;; Do it again, without the non-spacing characters. + ;; This allows 'a' to match 'ä'. + (let ((simpler-decomp nil) + (found-one nil)) + (dolist (c decomp) + (if (> (get-char-code-property c 'canonical-combining-class) 0) + (setq found-one t) + (push c simpler-decomp))) + (when (and simpler-decomp found-one) + (funcall make-decomp-match-char simpler-decomp char) + ;; Finally, if the decomp only had one spacing + ;; character, we allow this character to match the + ;; decomp. This is to let 'a' match 'ä'. + (unless (cdr simpler-decomp) + (aset equiv (car simpler-decomp) + (cons (apply #'string decomp) + (aref equiv (car simpler-decomp))))))))))) + table)) ;; Add some entries to default decomposition (dolist (it (or (bound-and-true-p char-fold-include) @@ -232,7 +236,9 @@ Exceptionally for the space character (32), ALIST is ignored.") (defun char-fold-update-table () "Update char-fold-table only when one of the options changes its value." - (let ((new (list (or (bound-and-true-p char-fold-include) + (let ((new (list (or (bound-and-true-p char-fold-override) + char-fold--default-override) + (or (bound-and-true-p char-fold-include) char-fold--default-include) (or (bound-and-true-p char-fold-exclude) char-fold--default-exclude) @@ -242,6 +248,22 @@ Exceptionally for the space character (32), ALIST is ignored.") (setq char-fold-table (char-fold--make-table) char-fold--previous new)))) +(defcustom char-fold-override char-fold--default-override + "Non-nil means to override the default definitions of equivalent characters. +When nil (the default), the table of character equivalences used +for character-folding is populated with the default set of equivalent +characters; customize `char-fold-exclude' to remove unneeded equivalences, +and `char-fold-include' to add your own. +When this variable is non-nil, the table of equivalences starts empty, +and you can add your own equivalences by customizing `char-fold-include'." + :type 'boolean + :initialize #'custom-initialize-default + :set (lambda (sym val) + (custom-set-default sym val) + (char-fold-update-table)) + :group 'isearch + :version "29.1") + (defcustom char-fold-include char-fold--default-include "Additional character foldings to include. Each entry is a list of a character and the strings that fold into it." diff --git a/lisp/cmuscheme.el b/lisp/cmuscheme.el index e197069d6b8..47113ad8c2e 100644 --- a/lisp/cmuscheme.el +++ b/lisp/cmuscheme.el @@ -245,7 +245,8 @@ Search in the directories \"~\" and `user-emacs-directory', in this order. Return nil if no start file found." (let* ((progname (file-name-nondirectory prog)) (start-file (concat "~/.emacs_" progname)) - (alt-start-file (concat user-emacs-directory "init_" progname ".scm"))) + (alt-start-file (locate-user-emacs-file + (concat "init_" progname ".scm")))) (if (file-exists-p start-file) start-file (and (file-exists-p alt-start-file) alt-start-file)))) diff --git a/lisp/comint.el b/lisp/comint.el index a0873c0b6a1..5f99f560cf3 100644 --- a/lisp/comint.el +++ b/lisp/comint.el @@ -385,10 +385,12 @@ This variable is buffer-local." "\\(?: [[:alpha:]]+ .+\\)?[[:blank:]]*[:：៖][[:space:]]*\\'" ;; The ccrypt encryption dialogue doesn't end with a colon, so ;; treat it specially. - "\\|^Enter encryption key: (repeat) *\\'") + "\\|^Enter encryption key: (repeat) *\\'" + ;; openssh-8.6p1 format: "(user@host) Password:". + "\\|^([^)@ \t\n]+@[^)@ \t\n]+) Password: *\\'") "Regexp matching prompts for passwords in the inferior process. This is used by `comint-watch-for-password-prompt'." - :version "28.1" + :version "29.1" :type 'regexp :group 'comint) @@ -728,6 +730,8 @@ Entry to this mode runs the hooks on `comint-mode-hook'." (or (file-remote-p default-directory) "")) (setq-local comint-accum-marker (make-marker)) (setq-local font-lock-defaults '(nil t)) + (add-function :filter-return (local 'filter-buffer-substring-function) + #'comint--unmark-string-as-output) (add-hook 'change-major-mode-hook 'font-lock-defontify nil t) (add-hook 'isearch-mode-hook 'comint-history-isearch-setup nil t) (add-hook 'completion-at-point-functions 'comint-completion-at-point nil t) @@ -889,12 +893,13 @@ series of processes in the same Comint buffer. The hook ;; and there is no way for us to define it here. ;; Some programs that use terminfo get very confused ;; if TERM is not a valid terminal type. - (if (and (boundp 'system-uses-terminfo) system-uses-terminfo) - (list (format "TERM=%s" comint-terminfo-terminal) - "TERMCAP=" - (format "COLUMNS=%d" (window-width))) - (list "TERM=emacs" - (format "TERMCAP=emacs:co#%d:tc=unknown:" (window-width))))) + (with-connection-local-variables + (if system-uses-terminfo + (list (format "TERM=%s" comint-terminfo-terminal) + "TERMCAP=" + (format "COLUMNS=%d" (window-width))) + (list "TERM=emacs" + (format "TERMCAP=emacs:co#%d:tc=unknown:" (window-width)))))) (defun comint-nonblank-p (str) "Return non-nil if STR contains non-whitespace syntax." @@ -1812,7 +1817,8 @@ Ignore duplicates if `comint-input-ignoredups' is non-nil." (ring-insert comint-input-ring cmd))) (defconst comint--prompt-rear-nonsticky - '(field inhibit-line-move-field-capture read-only font-lock-face) + '( field inhibit-line-move-field-capture read-only font-lock-face + insert-in-front-hooks) "Text properties we set on the prompt and don't want to leak past it.") (defun comint-send-input (&optional no-newline artificial) @@ -1904,6 +1910,14 @@ Similarly for Soar, Scheme, etc." (delete-region pmark start) copy)))) + ;; Delete and reinsert input. This seems like a no-op, except + ;; for the resulting entries in the undo list: undoing this + ;; insertion will delete the region, moving the process mark + ;; back to its original position. + (let ((inhibit-read-only t)) + (delete-region pmark (point)) + (insert input)) + (unless no-newline (insert ?\n)) @@ -1947,7 +1961,7 @@ Similarly for Soar, Scheme, etc." ;; in case we get output amidst sending the input. (set-marker comint-last-input-start pmark) (set-marker comint-last-input-end (point)) - (set-marker (process-mark proc) (point)) + (set-marker pmark (point)) ;; clear the "accumulation" marker (set-marker comint-accum-marker nil) (let ((comint-input-sender-no-newline no-newline)) @@ -2141,14 +2155,7 @@ Make backspaces delete the previous character." (goto-char (process-mark process)) ; In case a filter moved it. (unless comint-use-prompt-regexp - (with-silent-modifications - (add-text-properties comint-last-output-start (point) - `(rear-nonsticky - ,comint--prompt-rear-nonsticky - front-sticky - (field inhibit-line-move-field-capture) - field output - inhibit-line-move-field-capture t)))) + (comint--mark-as-output comint-last-output-start (point))) ;; Highlight the prompt, where we define `prompt' to mean ;; the most recent output that doesn't end with a newline. @@ -2180,6 +2187,46 @@ Make backspaces delete the previous character." ,comint--prompt-rear-nonsticky))) (goto-char saved-point))))))) +(defun comint--mark-as-output (beg end) + (with-silent-modifications + (add-text-properties + beg end + `(rear-nonsticky + ,comint--prompt-rear-nonsticky + front-sticky + (field inhibit-line-move-field-capture) + field output + inhibit-line-move-field-capture t + ;; Text inserted by a user in the middle of process output + ;; should be marked as output. This is needed for commands + ;; such as `yank' or `just-one-space' which don't use + ;; `insert-and-inherit' and thus bypass default text property + ;; inheritance. + insert-in-front-hooks + (,#'comint--mark-as-output ,#'comint--mark-yanked-as-output))))) + +(defun comint--mark-yanked-as-output (beg end) + ;; `yank' removes the field text property from the text it inserts + ;; due to `yank-excluded-properties', so arrange for this text + ;; property to be reapplied in the `after-change-functions'. + (let (fun) + (setq + fun + (lambda (beg1 end1 _len1) + (remove-hook 'after-change-functions fun t) + (when (and (= beg beg1) + (= end end1)) + (comint--mark-as-output beg1 end1)))) + (add-hook 'after-change-functions fun nil t))) + +(defun comint--unmark-string-as-output (string) + (remove-list-of-text-properties + 0 (length string) + '( rear-nonsticky front-sticky field + inhibit-line-move-field-capture insert-in-front-hooks) + string) + string) + (defun comint-preinput-scroll-to-bottom () "Go to the end of buffer in all windows showing it. Movement occurs if point in the selected window is not after the process mark, @@ -2455,11 +2502,19 @@ This function could be in the list `comint-output-filter-functions'." (when (let ((case-fold-search t)) (string-match comint-password-prompt-regexp (string-replace "\r" "" string))) - (let ((comint--prompt-recursion-depth (1+ comint--prompt-recursion-depth))) - (if (> comint--prompt-recursion-depth 10) - (message "Password prompt recursion too deep") - (comint-send-invisible - (string-trim string "[ \n\r\t\v\f\b\a]+" "\n+")))))) + ;; Use `run-at-time' in order not to pause execution of the + ;; process filter with a minibuffer + (run-at-time + 0 nil + (lambda (current-buf) + (with-current-buffer current-buf + (let ((comint--prompt-recursion-depth + (1+ comint--prompt-recursion-depth))) + (if (> comint--prompt-recursion-depth 10) + (message "Password prompt recursion too deep") + (comint-send-invisible + (string-trim string "[ \n\r\t\v\f\b\a]+" "\n+")))))) + (current-buffer)))) ;; Low-level process communication @@ -3509,6 +3564,20 @@ to send all the accumulated input, at once. The entire accumulated text becomes one item in the input history when you send it." (interactive) + (when-let* ((proc (get-buffer-process (current-buffer))) + (pmark (process-mark proc)) + ((or (marker-position comint-accum-marker) + (set-marker comint-accum-marker pmark) + t)) + ((>= (point) comint-accum-marker pmark))) + ;; Delete and reinsert input. This seems like a no-op, except for + ;; the resulting entries in the undo list: undoing this insertion + ;; will delete the region, moving the accumulation marker back to + ;; its original position. + (let ((text (buffer-substring comint-accum-marker (point))) + (inhibit-read-only t)) + (delete-region comint-accum-marker (point)) + (insert text))) (insert "\n") (set-marker comint-accum-marker (point)) (if comint-input-ring-index diff --git a/lisp/completion.el b/lisp/completion.el index 643f2da0d21..a77cccde643 100644 --- a/lisp/completion.el +++ b/lisp/completion.el @@ -492,7 +492,7 @@ Used to decide whether to save completions.") table)) ;; Old name, non-namespace-clean. -(defvaralias 'cmpl-syntax-table 'completion-syntax-table) +(define-obsolete-variable-alias 'cmpl-syntax-table 'completion-syntax-table "29.1") (defvar-local completion-syntax-table completion-standard-syntax-table "This variable holds the current completion syntax table.") @@ -2220,7 +2220,7 @@ TYPE is the type of the wrapper to be added. Can be :before or :under." (completion-def-wrapper 'delete-backward-char-untabify :backward) ;; Old name, non-namespace-clean. -(defalias 'initialize-completions #'completion-initialize) +(define-obsolete-function-alias 'initialize-completions #'completion-initialize "29.1") (provide 'completion) diff --git a/lisp/composite.el b/lisp/composite.el index 99f528a0779..c2289e8998f 100644 --- a/lisp/composite.el +++ b/lisp/composite.el @@ -901,6 +901,4 @@ For more information on Auto Composition mode, see (provide 'composite) - - ;;; composite.el ends here diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index 5c4448ae71a..b7c53a4dfed 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -1133,7 +1133,7 @@ for the MODE to customize." (defun customize-read-group () (let ((completion-ignore-case t)) - (completing-read "Customize group (default emacs): " + (completing-read (format-prompt "Customize group" "emacs") obarray (lambda (symbol) (or (and (get symbol 'custom-loads) @@ -1205,7 +1205,7 @@ Show the buffer in another window, but don't select it." (unless (eq symbol basevar) (message "`%s' is an alias for `%s'" symbol basevar)))) -(defvar customize-changed-options-previous-release "27.2" +(defvar customize-changed-options-previous-release "28.1" "Version for `customize-changed' to refer back to by default.") ;; Packages will update this variable, so make it available. @@ -2176,7 +2176,7 @@ and `face'." ;;; The `custom' Widget. (defface custom-button - '((((type x w32 ns) (class color)) ; Like default mode line + '((((type x w32 ns haiku) (class color)) ; Like default mode line :box (:line-width 2 :style released-button) :background "lightgrey" :foreground "black")) "Face for custom buffer buttons if `custom-raised-buttons' is non-nil." @@ -2184,7 +2184,7 @@ and `face'." :group 'custom-faces) (defface custom-button-mouse - '((((type x w32 ns) (class color)) + '((((type x w32 ns haiku) (class color)) :box (:line-width 2 :style released-button) :background "grey90" :foreground "black") (t @@ -2209,7 +2209,7 @@ and `face'." (if custom-raised-buttons 'custom-button-mouse 'highlight)) (defface custom-button-pressed - '((((type x w32 ns) (class color)) + '((((type x w32 ns haiku) (class color)) :box (:line-width 2 :style pressed-button) :background "lightgrey" :foreground "black") (t :inverse-video t)) diff --git a/lisp/cus-face.el b/lisp/cus-face.el index 6c0052bf860..c78a327fdfa 100644 --- a/lisp/cus-face.el +++ b/lisp/cus-face.el @@ -31,6 +31,9 @@ (defun custom-declare-face (face spec doc &rest args) "Like `defface', but with FACE evaluated as a normal argument." + (when (and doc + (not (stringp doc))) + (error "Invalid (or missing) doc string %S" doc)) (unless (get face 'face-defface-spec) (face-spec-set face (purecopy spec) 'face-defface-spec) (push (cons 'defface face) current-load-list) @@ -51,6 +54,7 @@ (string :tag "Font Foundry" :help-echo "Font foundry name.")) + ;; The width, weight, and slant should be in sync with font.c. (:width (choice :tag "Width" :help-echo "Font width." @@ -60,15 +64,21 @@ (const :tag "demiexpanded" semi-expanded) (const :tag "expanded" expanded) (const :tag "extracondensed" extra-condensed) + (const :tag "extra-condensed" extra-condensed) (const :tag "extraexpanded" extra-expanded) - (const :tag "medium" normal) + (const :tag "extra-expanded" extra-expanded) (const :tag "narrow" condensed) (const :tag "normal" normal) + (const :tag "medium" normal) (const :tag "regular" normal) (const :tag "semicondensed" semi-condensed) + (const :tag "demicondensed" semi-condensed) + (const :tag "semi-condensed" semi-condensed) (const :tag "semiexpanded" semi-expanded) (const :tag "ultracondensed" ultra-condensed) + (const :tag "ultra-condensed" ultra-condensed) (const :tag "ultraexpanded" ultra-expanded) + (const :tag "ultra-expanded" ultra-expanded) (const :tag "wide" extra-expanded))) (:height @@ -82,22 +92,32 @@ (choice :tag "Weight" :help-echo "Font weight." :value normal ; default + (const :tag "thin" thin) (const :tag "ultralight" ultra-light) - (const :tag "extralight" extra-light) + (const :tag "ultra-light" ultra-light) + (const :tag "extralight" ultra-light) + (const :tag "extra-light" ultra-light) (const :tag "light" light) - (const :tag "thin" thin) (const :tag "semilight" semi-light) - (const :tag "book" semi-light) + (const :tag "semi-light" semi-light) + (const :tag "demilight" semi-light) (const :tag "normal" normal) - (const :tag "regular" normal) - (const :tag "medium" normal) + (const :tag "regular" regular) + (const :tag "book" normal) + (const :tag "medium" medium) (const :tag "semibold" semi-bold) + (const :tag "semi-bold" semi-bold) (const :tag "demibold" semi-bold) + (const :tag "demi-bold" semi-bold) (const :tag "bold" bold) (const :tag "extrabold" extra-bold) - (const :tag "heavy" extra-bold) - (const :tag "ultrabold" ultra-bold) - (const :tag "black" ultra-bold))) + (const :tag "extra-bold" extra-bold) + (const :tag "ultrabold" extra-bold) + (const :tag "ultra-bold" extra-bold) + (const :tag "heavy" heavy) + (const :tag "black" heavy) + (const :tag "ultra-heavy" ultra-heavy) + (const :tag "ultraheavy" ultra-heavy))) (:slant (choice :tag "Slant" diff --git a/lisp/cus-start.el b/lisp/cus-start.el index 1a3e5682bba..579beae123f 100644 --- a/lisp/cus-start.el +++ b/lisp/cus-start.el @@ -386,7 +386,7 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of (const :tag "When sent SIGUSR1" sigusr1) (const :tag "When sent SIGUSR2" sigusr2)) "24.1") - + (translate-upper-case-key-bindings keyboard boolean "29.1") ;; This is not good news because it will use the wrong ;; version-specific directories when you upgrade. We need ;; customization of the front of the list, maintaining the @@ -572,8 +572,10 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of (ns-use-native-fullscreen ns boolean "24.4") (ns-use-fullscreen-animation ns boolean "25.1") (ns-use-srgb-colorspace ns boolean "24.4") + (ns-scroll-event-delta-factor ns float "29.1") ;; process.c (delete-exited-processes processes-basics boolean) + (process-error-pause-time processes-basics integer "29.1") ;; syntax.c (parse-sexp-ignore-comments editing-basics boolean) (words-include-escapes editing-basics boolean) @@ -826,10 +828,15 @@ since it could result in memory overflow and make Emacs crash." (x-underline-at-descent-line display boolean "22.1") (x-stretch-cursor display boolean "21.1") (scroll-bar-adjust-thumb-portion windows boolean "24.4") + (x-scroll-event-delta-factor mouse float "29.1") ;; xselect.c (x-select-enable-clipboard-manager killing boolean "24.1") ;; xsettings.c - (font-use-system-font font-selection boolean "23.2"))) + (font-use-system-font font-selection boolean "23.2") + ;; haikuterm.c + (haiku-debug-on-fatal-error debug boolean "29.1") + ;; haikufns.c + (haiku-use-system-tooltips tooltip boolean "29.1"))) (setq ;; If we did not specify any standard value expression above, ;; use the current value as the standard value. standard (if (setq prop (memq :standard rest)) @@ -846,10 +853,17 @@ since it could result in memory overflow and make Emacs crash." (eq system-type 'windows-nt)) ((string-match "\\`ns-" (symbol-name symbol)) (featurep 'ns)) + ((string-match "\\`haiku-" (symbol-name symbol)) + (featurep 'haiku)) ((string-match "\\`x-.*gtk" (symbol-name symbol)) (featurep 'gtk)) ((string-match "clipboard-manager" (symbol-name symbol)) (boundp 'x-select-enable-clipboard-manager)) + ((or (equal "scroll-bar-adjust-thumb-portion" + (symbol-name symbol)) + (equal "x-scroll-event-delta-factor" + (symbol-name symbol))) + (featurep 'x)) ((string-match "\\`x-" (symbol-name symbol)) (fboundp 'x-create-frame)) ((string-match "selection" (symbol-name symbol)) @@ -870,9 +884,6 @@ since it could result in memory overflow and make Emacs crash." (symbol-name symbol)) ;; Any function from fontset.c will do. (fboundp 'new-fontset)) - ((equal "scroll-bar-adjust-thumb-portion" - (symbol-name symbol)) - (featurep 'x)) (t t)))) (if (not (boundp symbol)) ;; If variables are removed from C code, give an error here! diff --git a/lisp/cus-theme.el b/lisp/cus-theme.el index 07881e9b74e..f618e3341cb 100644 --- a/lisp/cus-theme.el +++ b/lisp/cus-theme.el @@ -627,22 +627,24 @@ Theme files are named *-theme.el in `")) (let ((help-echo "mouse-2: Enable this theme for this session") widget) (dolist (theme (custom-available-themes)) - (setq widget (widget-create 'checkbox - :value (custom-theme-enabled-p theme) - :theme-name theme - :help-echo help-echo - :action #'custom-theme-checkbox-toggle)) - (push (cons theme widget) custom--listed-themes) - (widget-create-child-and-convert widget 'push-button - :button-face-get 'ignore - :mouse-face-get 'ignore - :value (format " %s" theme) - :action #'widget-parent-action - :help-echo help-echo) - (widget-insert " -- " - (propertize (custom-theme-summary theme) - 'face 'shadow) - ?\n))) + ;; Don't list obsolete themes. + (unless (get theme 'byte-obsolete-info) + (setq widget (widget-create 'checkbox + :value (custom-theme-enabled-p theme) + :theme-name theme + :help-echo help-echo + :action #'custom-theme-checkbox-toggle)) + (push (cons theme widget) custom--listed-themes) + (widget-create-child-and-convert widget 'push-button + :button-face-get 'ignore + :mouse-face-get 'ignore + :value (format " %s" theme) + :action #'widget-parent-action + :help-echo help-echo) + (widget-insert " -- " + (propertize (custom-theme-summary theme) + 'face 'shadow) + ?\n)))) (goto-char (point-min)) (widget-setup)) diff --git a/lisp/custom.el b/lisp/custom.el index cc817403871..9252e80411f 100644 --- a/lisp/custom.el +++ b/lisp/custom.el @@ -364,7 +364,8 @@ call that function directly. See Info node `(elisp) Customization' in the Emacs Lisp manual for more information." - (declare (doc-string 3) (debug (name body))) + (declare (doc-string 3) (debug (name body)) + (indent defun)) ;; It is better not to use backquote in this file, ;; because that makes a bootstrapping problem ;; if you need to recompile all the Lisp files using interpreted code. @@ -447,7 +448,7 @@ In the ATTS property list, possible attributes are `:family', See Info node `(elisp) Faces' in the Emacs Lisp manual for more information." - (declare (doc-string 3)) + (declare (doc-string 3) (indent defun)) ;; It is better not to use backquote in this file, ;; because that makes a bootstrapping problem ;; if you need to recompile all the Lisp files using interpreted code. @@ -515,7 +516,7 @@ non-nil. See Info node `(elisp) Customization' in the Emacs Lisp manual for more information." - (declare (doc-string 3)) + (declare (doc-string 3) (indent defun)) ;; It is better not to use backquote in this file, ;; because that makes a bootstrapping problem ;; if you need to recompile all the Lisp files using interpreted code. @@ -1135,29 +1136,24 @@ list, in which A occurs before B if B was defined with a ;; (provide-theme 'THEME) -;; The IGNORED arguments to deftheme come from the XEmacs theme code, where -;; they were used to supply keyword-value pairs like `:immediate', -;; `:variable-reset-string', etc. We don't use any of these, so ignore them. - -(defmacro deftheme (theme &optional doc &rest _ignored) +(defmacro deftheme (theme &optional doc) "Declare THEME to be a Custom theme. The optional argument DOC is a doc string describing the theme. Any theme `foo' should be defined in a file called `foo-theme.el'; see `custom-make-theme-feature' for more information." (declare (doc-string 2) - (advertised-calling-convention (theme &optional doc) "22.1")) + (indent 1)) (let ((feature (custom-make-theme-feature theme))) ;; It is better not to use backquote in this file, ;; because that makes a bootstrapping problem ;; if you need to recompile all the Lisp files using interpreted code. (list 'custom-declare-theme (list 'quote theme) (list 'quote feature) doc))) -(defun custom-declare-theme (theme feature &optional doc &rest _ignored) +(defun custom-declare-theme (theme feature &optional doc) "Like `deftheme', but THEME is evaluated as a normal argument. FEATURE is the feature this theme provides. Normally, this is a symbol created from THEME by `custom-make-theme-feature'." - (declare (advertised-calling-convention (theme feature &optional doc) "22.1")) (unless (custom-theme-name-valid-p theme) (error "Custom theme cannot be named %S" theme)) (unless (memq theme custom-known-themes) @@ -1335,6 +1331,13 @@ Return t if THEME was successfully loaded, nil otherwise." t)))) (t (error "Unable to load theme `%s'" theme)))) + (when-let ((obs (get theme 'byte-obsolete-info))) + (display-warning 'initialization + (format "The `%s' theme is obsolete%s" + theme + (if (nth 2 obs) + (format " since Emacs %s" (nth 2 obs)) + "")))) ;; Optimization: if the theme changes the `default' face, put that ;; entry first. This avoids some `frame-set-background-mode' rigmarole ;; by assigning the new background immediately. diff --git a/lisp/descr-text.el b/lisp/descr-text.el index 98871164f2a..2a239f81002 100644 --- a/lisp/descr-text.el +++ b/lisp/descr-text.el @@ -417,6 +417,7 @@ The character information includes: (display-table (or (window-display-table) buffer-display-table standard-display-table)) + (composition-string nil) (disp-vector (and display-table (aref display-table char))) (multibyte-p enable-multibyte-characters) (overlays (mapcar (lambda (o) (overlay-properties o)) @@ -538,7 +539,8 @@ The character information includes: (setcar composition nil))) (setcar (cdr composition) (format "composed to form \"%s\" (see below)" - (buffer-substring from to))))) + (setq composition-string + (buffer-substring from to)))))) (setq composition nil))) (setq item-list @@ -682,6 +684,11 @@ The character information includes: (if display (format "terminal code %s" display) "not encodable for terminal")))))) + ,@(when-let ((composition-name + (and composition-string + (eq (aref char-script-table char) 'emoji) + (emoji-describe composition-string)))) + (list (list "composition name" composition-name))) ,@(let ((face (if (not (or disp-vector composition)) (cond diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index 8adda9a2727..5301a3a27ff 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -444,10 +444,10 @@ List has a form of (file-name full-file-name (attribute-list))." ((eq op-symbol 'chgrp) (file-attribute-group-id (file-attributes default-file 'string)))))) - (prompt (concat "Change " attribute-name " of %s to" - (if (eq op-symbol 'touch) - " (default now): " - ": "))) + (prompt (format-prompt "Change %s of %%s to" + (when (eq op-symbol 'touch) + "now") + attribute-name)) (new-attribute (dired-mark-read-string prompt nil op-symbol arg files default (cond ((eq op-symbol 'chown) @@ -1009,6 +1009,7 @@ the offending ARGUMENTS or PROGRAM if no ARGUMENTS were provided." (erase-buffer) (setq default-directory dir ; caller's default-directory err (not (eq 0 (apply #'process-file program nil t nil arguments)))) + (dired-uncache dir) (if err (progn (dired-log (concat program " " (prin1-to-string arguments) "\n")) @@ -1034,6 +1035,7 @@ Return the result of `process-file' - zero for success." nil shell-command-switch cmd))) + (dired-uncache dir) (unless (zerop res) (pop-to-buffer out-buffer)) res)))) @@ -1282,9 +1284,9 @@ Return nil if no change in files." (prog1 (setq newname (file-name-as-directory newname)) (dired-shell-command (replace-regexp-in-string - "%o" (shell-quote-argument newname) + "%o" (shell-quote-argument (file-local-name newname)) (replace-regexp-in-string - "%i" (shell-quote-argument file) + "%i" (shell-quote-argument (file-local-name file)) command nil t) nil t))) @@ -1295,10 +1297,10 @@ Return nil if no change in files." (dired-check-process msg (substring command 0 match) (substring command (1+ match)) - file) + (file-local-name file)) (dired-check-process msg command - file)) + (file-local-name file))) newname)))) (t ;; We don't recognize the file as compressed, so compress it. @@ -1316,7 +1318,8 @@ Return nil if no change in files." (default-directory (file-name-directory file))) (dired-shell-command (replace-regexp-in-string - "%o" (shell-quote-argument out-name) + "%o" (shell-quote-argument + (file-local-name out-name)) (replace-regexp-in-string "%i" (shell-quote-argument (file-name-nondirectory file)) @@ -1346,9 +1349,10 @@ see `dired-compress-file-alist' for the supported suffixes list" out-name))) (dired-shell-command (replace-regexp-in-string - "%o" (shell-quote-argument out-name) + "%o" (shell-quote-argument + (file-local-name out-name)) (replace-regexp-in-string - "%i" (shell-quote-argument file) + "%i" (shell-quote-argument (file-local-name file)) (cdr rule) nil t) nil t)) @@ -1363,7 +1367,8 @@ see `dired-compress-file-alist' for the supported suffixes list" out-name))))) (file-error (if (not (dired-check-process (concat "Compressing " file) - "compress" "-f" file)) + "compress" "-f" + (file-local-name file))) ;; Don't use NEWNAME with `compress'. (concat file ".Z")))))))) @@ -1784,13 +1789,46 @@ Special value `always' suppresses confirmation." "Whether Dired should create destination dirs when copying/removing files. If nil, don't create them. If `always', create them without asking. -If `ask', ask for user confirmation." +If `ask', ask for user confirmation. + +Also see `dired-create-destination-dirs-on-trailing-dirsep'." :type '(choice (const :tag "Never create non-existent dirs" nil) (const :tag "Always create non-existent dirs" always) (const :tag "Ask for user confirmation" ask)) :group 'dired :version "27.1") +(defcustom dired-create-destination-dirs-on-trailing-dirsep nil + "If non-nil, treat a trailing slash at queried destination dir specially. + +If this variable is non-nil and a single destination filename is +queried which ends in a directory separator (/), it will be +treated as a non-existent directory and acted on according to +`dired-create-destination-dirs'. + +This option is only relevant if `dired-create-destination-dirs' +is non-nil, too. + +For example, if both `dired-create-destination-dirs' and this +option are non-nil, renaming a directory named `old_name' to +`new_name/' (note the trailing directory separator) where +`new_name' does not exists already, it will be created and +`old_name' be moved into it. If only `new_name' (without the +trailing /) is given or this option or +`dired-create-destination-dirs' is `nil', `old_name' will be +renamed to `new_name'." + :type '(choice + (const :tag + (concat "Do not treat destination dirs with a " + "trailing directory separator specially") + nil) + (const :tag + (concat "Treat destination dirs with trailing " + "directory separator specially") + t)) + :group 'dired + :version "29.1") + (defun dired-maybe-create-dirs (dir) "Create DIR if doesn't exist according to `dired-create-destination-dirs'." (when (and dired-create-destination-dirs (not (file-exists-p dir))) @@ -1986,11 +2024,12 @@ or with the current marker character if MARKER-CHAR is t." (let* ((overwrite (file-exists-p to)) (dired-overwrite-confirmed ; for dired-handle-overwrite (and overwrite - (let ((help-form (format-message "\ -Type SPC or `y' to overwrite file `%s', -DEL or `n' to skip to next, -ESC or `q' to not overwrite any of the remaining files, -`!' to overwrite all remaining files with no more questions." to))) + (let ((help-form (format-message + (substitute-command-keys "\ +Type \\`SPC' or \\`y' to overwrite file `%s', +\\`DEL' or \\`n' to skip to next, +\\`ESC' or \\`q' to not overwrite any of the remaining files, +\\`!' to overwrite all remaining files with no more questions.") to))) (dired-query 'overwrite-query "Overwrite `%s'?" to)))) ;; must determine if FROM is marked before file-creator @@ -2159,7 +2198,12 @@ Optional arg HOW-TO determines how to treat the target. target-dir op-symbol arg rfn-list default)))) (into-dir (progn - (unless dired-one-file (dired-maybe-create-dirs target)) + (when + (or + (not dired-one-file) + (and dired-create-destination-dirs-on-trailing-dirsep + (directory-name-p target))) + (dired-maybe-create-dirs target)) (cond ((null how-to) ;; Allow users to change the letter case of ;; a directory on a case-insensitive @@ -2483,11 +2527,12 @@ Also see `dired-do-revert-buffer'." ;; Optional arg MARKER-CHAR as in dired-create-files. (let* ((fn-list (dired-get-marked-files nil arg)) (operation-prompt (concat operation " `%s' to `%s'?")) - (rename-regexp-help-form (format-message "\ -Type SPC or `y' to %s one match, DEL or `n' to skip to next, -`!' to %s all remaining matches with no more questions." - (downcase operation) - (downcase operation))) + (rename-regexp-help-form (format-message + (substitute-command-keys "\ +Type \\`SPC' or \\`y' to %s one match, \\`DEL' or \\`n' to skip to next, +\\`!' to %s all remaining matches with no more questions.") + (downcase operation) + (downcase operation))) (regexp-name-constructor ;; Function to construct new filename using REGEXP and NEWNAME: (if whole-name ; easy (but rare) case @@ -2608,11 +2653,12 @@ See function `dired-do-rename-regexp' for more info." (let ((to (concat (file-name-directory from) (funcall basename-constructor (file-name-nondirectory from))))) - (and (let ((help-form (format-message "\ -Type SPC or `y' to %s one file, DEL or `n' to skip to next, -`!' to %s all remaining matches with no more questions." - (downcase operation) - (downcase operation)))) + (and (let ((help-form (format-message + (substitute-command-keys "\ +Type \\`SPC' or \\`y' to %s one file, \\`DEL' or \\`n' to skip to next, +\\`!' to %s all remaining matches with no more questions.") + (downcase operation) + (downcase operation)))) (dired-query 'rename-non-directory-query (concat operation " `%s' to `%s'") (dired-make-relative from) @@ -2862,8 +2908,8 @@ of marked files. If KILL-ROOT is non-nil, kill DIRNAME as well." ;; if dired-actual-switches contained t. (setq dir1 (file-name-as-directory dir1) dir2 (file-name-as-directory dir2)) - (let ((components-1 (dired-split "/" dir1)) - (components-2 (dired-split "/" dir2))) + (let ((components-1 (split-string dir1 "/")) + (components-2 (split-string dir2 "/"))) (while (and components-1 components-2 (equal (car components-1) (car components-2))) @@ -2882,7 +2928,6 @@ of marked files. If KILL-ROOT is non-nil, kill DIRNAME as well." nil) (t (error "This can't happen")))))) -;; There should be a builtin split function - inverse to mapconcat. (defun dired-split (pat str &optional limit) "Splitting on regexp PAT, turn string STR into a list of substrings. Optional third arg LIMIT (>= 1) is a limit to the length of the @@ -2892,6 +2937,7 @@ Thus, if SEP is a regexp that only matches itself, (mapconcat #'identity (dired-split SEP STRING) SEP) is always equal to STRING." + (declare (obsolete split-string "29.1")) (let* ((start (string-match pat str)) (result (list (substring str 0 start))) (count 1) diff --git a/lisp/dired-x.el b/lisp/dired-x.el index 7c6f49f2ae4..38d8a954a83 100644 --- a/lisp/dired-x.el +++ b/lisp/dired-x.el @@ -554,7 +554,7 @@ 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): " + (format-prompt "Mark unmarked files matching regexp" "all") nil 'dired-regexp-history) nil current-prefix-arg nil)) (let ((dired-marker-char (if unflag-p ?\s dired-marker-char))) @@ -580,23 +580,24 @@ files in the active region if `dired-mark-region' is non-nil." (defalias 'virtual-dired 'dired-virtual) (defun dired-virtual (dirname &optional switches) - "Put this Dired buffer into Virtual Dired mode. + "Treat the current buffer as a Dired buffer showing directory DIRNAME. +Interactively, prompt for DIRNAME. -In Virtual Dired mode, all commands that do not actually consult the -filesystem will work. +This command is rarely useful, but may be convenient if you want +to peruse and move around in the output you got from \"ls +-lR\" (or something similar), without having access to the actual +file system. -This is useful if you want to peruse and move around in an ls -lR -output file, for example one you got from an ftp server. With -ange-ftp, you can even Dired a directory containing an ls-lR file, -visit that file and turn on Virtual Dired mode. But don't try to save -this file, as `dired-virtual' indents the listing and thus changes the -buffer. +Most Dired commands that don't consult the file system will work +as advertised, but commands that try to alter the file system +will usually fail. (However, if the output is from the current +system, most of those commands will work fine.) If you have saved a Dired buffer in a file you can use \\[dired-virtual] to resume it in a later session. Type \\<dired-mode-map>\\[revert-buffer] \ -in the Virtual Dired buffer and answer `y' to convert +in the Virtual Dired buffer and answer \\`y' to convert the virtual to a real Dired buffer again. You don't have to do this, though: you can relist single subdirs using \\[dired-do-redisplay]." @@ -1264,13 +1265,21 @@ sure that a trailing letter in STR is one of BKkMGTPEZY." (let* ((val (string-to-number str)) (u (unless (zerop val) (aref str (1- (length str)))))) - (when (and u (> u ?9)) - (when (= u ?k) - (setq u ?K)) - (let ((units '(?B ?K ?M ?G ?T ?P ?E ?Z ?Y))) - (while (and units (/= (pop units) u)) - (setq val (* 1024.0 val))))) - val)) + ;; If we don't have a unit at the end, but we have some + ;; non-numeric strings in the string, then the string may be + ;; something like "4.134" or "4,134" meant to represent 4134 + ;; (seen in some locales). + (if (and u + (<= ?0 u ?9) + (string-match-p "[^0-9]" str)) + (string-to-number (replace-regexp-in-string "[^0-9]+" "" str)) + (when (and u (> u ?9)) + (when (= u ?k) + (setq u ?K)) + (let ((units '(?B ?K ?M ?G ?T ?P ?E ?Z ?Y))) + (while (and units (/= (pop units) u)) + (setq val (* 1024.0 val))))) + val))) (defun dired-mark-sexp (predicate &optional unflag-p) "Mark files for which PREDICATE returns non-nil. @@ -1478,12 +1487,12 @@ a prefix argument, when it offers the filename near point as a default." ;;; Internal functions -;; Fixme: This should probably use `thing-at-point'. -- fx (define-obsolete-function-alias 'dired-filename-at-point #'dired-x-guess-file-name-at-point "28.1") (defun dired-x-guess-file-name-at-point () "Return the filename closest to point, expanded. Point should be in or after a filename." + (declare (obsolete "use (thing-at-point 'filename) instead." "29.1")) (save-excursion ;; First see if just past a filename. (or (eobp) ; why? @@ -1515,7 +1524,7 @@ Point should be in or after a filename." "Return filename prompting with PROMPT with completion. If `current-prefix-arg' is non-nil, uses name at point as guess." (if current-prefix-arg - (let ((guess (dired-x-guess-file-name-at-point))) + (let ((guess (thing-at-point 'filename))) (read-file-name prompt (file-name-directory guess) guess diff --git a/lisp/dired.el b/lisp/dired.el index 46525891224..b964fd9c181 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -35,6 +35,7 @@ ;;; Code: (eval-when-compile (require 'subr-x)) +(eval-when-compile (require 'cl-lib)) ;; When bootstrapping dired-loaddefs has not been generated. (require 'dired-loaddefs nil t) @@ -208,6 +209,18 @@ If a character, new links are unconditionally marked with that character." (character :tag "Mark")) :group 'dired-mark) +(defcustom dired-free-space 'first + "Whether and how to display the amount of free disk space in Dired buffers. +If nil, don't display. +If `separate', display on a separate line (along with used count). +If `first', display only the free disk space on the first line, +following the directory name." + :type '(choice (const :tag "On a separate line" separate) + (const :tag "On the first line, after directory name" first) + (const :tag "Don't display" nil)) + :version "29.1" + :group 'dired) + (defcustom dired-dwim-target nil "If non-nil, Dired tries to guess a default target directory. This means: if there is a Dired buffer displayed in some window, @@ -281,6 +294,11 @@ with the buffer narrowed to the listing." ;; Note this can't simply be run inside function `dired-ls' as the hook ;; functions probably depend on the dired-subdir-alist to be OK. +(defcustom dired-make-directory-clickable t + "When non-nil, make the directory at the start of the dired buffer clickable." + :version "29.1" + :type 'boolean) + (defcustom dired-initial-position-hook nil "This hook is used to position the point. It is run by the function `dired-initial-position'." @@ -339,11 +357,11 @@ 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 +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. +used to select the region, for example \\`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 @@ -1247,8 +1265,7 @@ The return value is the target column for the file names." ;; Don't try to find a wildcard as a subdirectory. (string-equal dirname (file-name-directory dirname))) (let* ((cur-buf (current-buffer)) - (buffers (nreverse - (dired-buffers-for-dir (expand-file-name dirname)))) + (buffers (nreverse (dired-buffers-for-dir dirname))) (cur-buf-matches (and (memq cur-buf buffers) ;; Wildcards must match, too: (equal dired-directory dirname)))) @@ -1326,6 +1343,8 @@ wildcards, erases the buffer, and builds the subdir-alist anew (set-visited-file-modtime (file-attribute-modification-time attributes)))) (set-buffer-modified-p nil) + (when dired-make-directory-clickable + (dired--make-directory-clickable)) ;; No need to narrow since the whole buffer contains just ;; dired-readin's output, nothing else. The hook can ;; successfully use dired functions (e.g. dired-get-filename) @@ -1606,15 +1625,55 @@ see `dired-use-ls-dired' for more details.") ;; by its expansion, so it does not matter whether what we insert ;; here is fully expanded, but it should be absolute. (insert " " (or (car-safe (insert-directory-wildcard-in-dir-p dir)) - (directory-file-name (file-name-directory dir))) ":\n") + (directory-file-name (file-name-directory dir))) + ":\n") (setq content-point (point))) (when wildcard ;; Insert "wildcard" line where "total" line would be for a full dir. (insert " wildcard " (or (cdr-safe (insert-directory-wildcard-in-dir-p dir)) (file-name-nondirectory dir)) - "\n"))) + "\n")) + (setq content-point (dired--insert-disk-space opoint dir))) (dired-insert-set-properties content-point (point))))) +(defun dired--insert-disk-space (beg file) + ;; Try to insert the amount of free space. + (save-excursion + (goto-char beg) + ;; First find the line to put it on. + (if (not (re-search-forward "^ *\\(total\\)" nil t)) + beg + (if (or (not dired-free-space) + (eq dired-free-space 'first)) + (delete-region (match-beginning 0) (line-beginning-position 2)) + ;; Replace "total" with "total used in directory" to + ;; avoid confusion. + (replace-match "total used in directory" nil nil nil 1)) + (if-let ((available (get-free-disk-space file))) + (cond + ((eq dired-free-space 'separate) + (end-of-line) + (insert " available " available) + (forward-line 1) + (point)) + ((eq dired-free-space 'first) + (goto-char beg) + (when (and (looking-at + (if (memq system-type '(windows-nt ms-dos)) + " *[A-Za-z]:/" + " */")) + (progn + (end-of-line) + (eq (char-after (1- (point))) ?:))) + (put-text-property (1- (point)) (point) + 'display + (concat ": (" available " available)"))) + (forward-line 1) + (point)) + (t + beg)) + beg)))) + (defun dired-insert-set-properties (beg end) "Add various text properties to the lines in the region, from BEG to END." (save-excursion @@ -1643,6 +1702,32 @@ see `dired-use-ls-dired' for more details.") 'invisible 'dired-hide-details-link)))) (forward-line 1)))) +(defun dired--make-directory-clickable () + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "^ /" nil t 1) + (let ((bound (line-end-position)) + (segment-start (point)) + (inhibit-read-only t) + (dir "/")) + (while (search-forward "/" bound t 1) + (setq dir (concat dir (buffer-substring segment-start (point)))) + (add-text-properties + segment-start (1- (point)) + `( mouse-face highlight + help-echo "mouse-1: goto this directory" + keymap ,(let* ((current-dir dir) + (click (lambda () + (interactive) + (if (assoc current-dir dired-subdir-alist) + (dired-goto-subdir current-dir) + (dired current-dir))))) + (define-keymap + "<mouse-2>" click + "<follow-link>" 'mouse-face + "RET" click)))) + (setq segment-start (point))))))) + ;;; Reverting a dired buffer @@ -1981,12 +2066,6 @@ Do so according to the former subdir alist OLD-SUBDIR-ALIST." (define-key map ":v" 'epa-dired-do-verify) (define-key map ":s" 'epa-dired-do-sign) (define-key map ":e" 'epa-dired-do-encrypt) - - ;; No need to do this, now that top-level items are fewer. - ;;;; - ;; Get rid of the Edit menu bar item to save space. - ;;(define-key map [menu-bar edit] 'undefined) - map) "Local keymap for Dired mode buffers.") @@ -2415,7 +2494,9 @@ directory in another window." file-name (if (file-symlink-p file-name) (error "File is a symlink to a nonexistent target") - (error "File no longer exists; type `g' to update Dired buffer"))))) + (error (substitute-command-keys + (concat "File no longer exists; type \\<dired-mode-map>" + "\\[revert-buffer] to update Dired buffer"))))))) ;; Force C-m keybinding rather than `f' or `e' in the mode doc: (define-obsolete-function-alias 'dired-advertised-find-file @@ -2879,7 +2960,7 @@ directories below DIR. The list is in reverse order of buffer creation, most recent last. As a side effect, killed dired buffers for DIR are removed from `dired-buffers'." - (setq dir (file-name-as-directory dir)) + (setq dir (file-name-as-directory (expand-file-name dir))) (let (result buf) (dolist (elt dired-buffers) (setq buf (cdr elt)) @@ -3430,7 +3511,7 @@ If the buffer has a wildcard pattern, check that it matches FILE. FILE may be nil, in which case ignore it. Return list of buffers where FUN succeeded (i.e., returned non-nil)." (let (success-list) - (dolist (buf (dired-buffers-for-dir (expand-file-name directory) file)) + (dolist (buf (dired-buffers-for-dir directory file)) (with-current-buffer buf (when (apply fun args) (push (buffer-name buf) success-list)))) @@ -3479,8 +3560,7 @@ confirmation. To disable the confirmation, see (file-name-nondirectory fn)))) (not dired-clean-confirm-killing-deleted-buffers)) (kill-buffer buf))) - (let ((buf-list (dired-buffers-for-dir (expand-file-name fn) - nil 'subdirs))) + (let ((buf-list (dired-buffers-for-dir fn nil 'subdirs))) (and buf-list (or (and dired-clean-confirm-killing-deleted-buffers (y-or-n-p @@ -4066,9 +4146,9 @@ Type \\[help-command] at that time for help." (inhibit-read-only t) case-fold-search dired-unmark-all-files-query (string (format "\n%c" mark)) - (help-form "\ -Type SPC or `y' to unmark one file, DEL or `n' to skip to next, -`!' to unmark all remaining files with no more questions.")) + (help-form (substitute-command-keys "\ +Type \\`SPC' or \\`y' to unmark one file, \\`DEL' or \\`n' to skip to next, +\\`!' to unmark all remaining files with no more questions."))) (goto-char (point-min)) (while (if (eq mark ?\r) (re-search-forward dired-re-mark nil t) diff --git a/lisp/doc-view.el b/lisp/doc-view.el index 088ca5bfeae..11559bf2f50 100644 --- a/lisp/doc-view.el +++ b/lisp/doc-view.el @@ -493,24 +493,69 @@ Typically \"page-%s.png\".") (easy-menu-define doc-view-menu doc-view-mode-map "Menu for Doc View mode." '("DocView" - ["Toggle display" doc-view-toggle-display] - ("Continuous" + ["Next page" doc-view-next-page + :help "Go to the next page"] + ["Previous page" doc-view-previous-page + :help "Go to the previous page"] + ("Other Navigation" + ["Go to page..." doc-view-goto-page + :help "Go to specific page"] + "---" + ["First page" doc-view-first-page + :help "View the first page"] + ["Last page" doc-view-last-page + :help "View the last page"] + "---" + ["Move forward" doc-view-scroll-up-or-next-page + :help "Scroll page up or go to next page"] + ["Move backward" doc-view-scroll-down-or-previous-page + :help "Scroll page down or go to previous page"]) + ("Continuous Scrolling" ["Off" (setq doc-view-continuous nil) - :style radio :selected (eq doc-view-continuous nil)] + :style radio :selected (eq doc-view-continuous nil) + :help "Scrolling stops at page beginning and end"] ["On" (setq doc-view-continuous t) - :style radio :selected (eq doc-view-continuous t)] + :style radio :selected (eq doc-view-continuous t) + :help "Scrolling continues to next or previous page"] "---" - ["Save as Default" - (customize-save-variable 'doc-view-continuous doc-view-continuous) t] + ["Save as Default" (customize-save-variable 'doc-view-continuous doc-view-continuous) + :help "Save current continuous scrolling option as default"] ) "---" - ["Set Slice" doc-view-set-slice-using-mouse] - ["Set Slice (BoundingBox)" doc-view-set-slice-from-bounding-box] - ["Set Slice (manual)" doc-view-set-slice] - ["Reset Slice" doc-view-reset-slice] + ("Toggle edit/display" + ["Edit document" doc-view-toggle-display + :style radio :selected (eq major-mode 'doc-view--text-view-mode)] + ["Display document" (lambda ()) ; ignore but show no keybinding + :style radio :selected (eq major-mode 'doc-view-mode)]) + ("Adjust Display" + ["Fit to window" doc-view-fit-page-to-window + :help "Fit the image to the window"] + ["Fit width" doc-view-fit-width-to-window + :help "Fit the image width to the window width"] + ["Fit height" doc-view-fit-height-to-window + :help "Fit the image height to the window height"] + "---" + ["Enlarge" doc-view-enlarge + :help "Enlarge the document"] + ["Shrink" doc-view-shrink + :help "Shrink the document"] + "---" + ["Set Slice" doc-view-set-slice-using-mouse + :help "Set the slice of the images that should be displayed"] + ["Set Slice (BoundingBox)" doc-view-set-slice-from-bounding-box + :help "Set the slice from the document's BoundingBox information"] + ["Set Slice (manual)" doc-view-set-slice + :help "Set the slice of the images that should be displayed"] + ["Reset Slice" doc-view-reset-slice + :help "Reset the current slice" + :enabled (image-mode-window-get 'slice)]) "---" - ["Search" doc-view-search] - ["Search Backwards" doc-view-search-backward] + ["New Search" (doc-view-search t) + :help "Initiate a new search"] + ["Search Forward" doc-view-search + :help "Jump to the next match or initiate a new search"] + ["Search Backward" doc-view-search-backward + :help "Jump to the previous match or initiate a new search"] )) (defvar doc-view-minor-mode-map @@ -520,6 +565,16 @@ Typically \"page-%s.png\".") map) "Keymap used by `doc-view-minor-mode'.") +(easy-menu-define doc-view-minor-mode-menu doc-view-minor-mode-map + "Menu for Doc View minor mode." + '("DocView (edit)" + ("Toggle edit/display" + ["Edit document" (lambda ()) ; ignore but show no keybinding + :style radio :selected (eq major-mode 'doc-view--text-view-mode)] + ["Display document" doc-view-toggle-display + :style radio :selected (eq major-mode 'doc-view-mode)]) + ["Exit DocView Mode" doc-view-minor-mode])) + ;;;; Navigation Commands ;; FIXME: The doc-view-current-* definitions below are macros because they @@ -756,9 +811,10 @@ OpenDocument format)." (and doc-view-dvipdfm-program (executable-find doc-view-dvipdfm-program))))) ((memq type '(postscript ps eps pdf)) - ;; FIXME: allow mupdf here - (and doc-view-ghostscript-program - (executable-find doc-view-ghostscript-program))) + (or (and doc-view-ghostscript-program + (executable-find doc-view-ghostscript-program)) + (and doc-view-pdfdraw-program + (executable-find doc-view-pdfdraw-program)))) ((eq type 'odf) (and doc-view-odf->pdf-converter-program (executable-find doc-view-odf->pdf-converter-program) @@ -1530,16 +1586,16 @@ have the page we want to view." (overlay-put (doc-view-current-overlay) 'display (concat (propertize "Welcome to DocView!" 'face 'bold) "\n" - " + (substitute-command-keys " If you see this buffer it means that the document you want to view is being converted to PNG and the conversion of the first page hasn't finished yet or `doc-view-conversion-refresh-interval' is set to nil. For now these keys are useful: - -`q' : Bury this buffer. Conversion will go on in background. -`k' : Kill the conversion process and this buffer. -`K' : Kill the conversion process.\n")))) +\\<doc-view-mode-map> +\\[quit-window] : Bury this buffer. Conversion will go on in background. +\\[image-kill-buffer] : Kill the conversion process and this buffer. +\\[doc-view-kill-proc] : Kill the conversion process.\n"))))) (declare-function tooltip-show "tooltip" (text &optional use-echo-area)) diff --git a/lisp/edmacro.el b/lisp/edmacro.el index 42c164a0881..29900a9595c 100644 --- a/lisp/edmacro.el +++ b/lisp/edmacro.el @@ -610,6 +610,12 @@ This function assumes that the events can be stored in a string." (defun edmacro-fix-menu-commands (macro &optional noerror) (if (vectorp macro) (let (result) + ;; Not preloaded in without-x builds. + (require 'mwheel) + (defvar mouse-wheel-down-event) + (defvar mouse-wheel-left-event) + (defvar mouse-wheel-right-event) + (defvar mouse-wheel-up-event) ;; Make a list of the elements. (setq macro (append macro nil)) (dolist (ev macro) @@ -640,101 +646,10 @@ This function assumes that the events can be stored in a string." ;;; Parsing a human-readable keyboard macro. (defun edmacro-parse-keys (string &optional need-vector) - (let ((case-fold-search nil) - (len (length string)) ; We won't alter string in the loop below. - (pos 0) - (res [])) - (while (and (< pos len) - (string-match "[^ \t\n\f]+" string pos)) - (let* ((word-beg (match-beginning 0)) - (word-end (match-end 0)) - (word (substring string word-beg len)) - (times 1) - key) - ;; Try to catch events of the form "<as df>". - (if (string-match "\\`<[^ <>\t\n\f][^>\t\n\f]*>" word) - (setq word (match-string 0 word) - pos (+ word-beg (match-end 0))) - (setq word (substring string word-beg word-end) - pos word-end)) - (when (string-match "\\([0-9]+\\)\\*." word) - (setq times (string-to-number (substring word 0 (match-end 1)))) - (setq word (substring word (1+ (match-end 1))))) - (cond ((string-match "^<<.+>>$" word) - (setq key (vconcat (if (eq (key-binding [?\M-x]) - 'execute-extended-command) - [?\M-x] - (or (car (where-is-internal - 'execute-extended-command)) - [?\M-x])) - (substring word 2 -2) "\r"))) - ((and (string-match "^\\(\\([ACHMsS]-\\)*\\)<\\(.+\\)>$" word) - (progn - (setq word (concat (match-string 1 word) - (match-string 3 word))) - (not (string-match - "\\<\\(NUL\\|RET\\|LFD\\|ESC\\|SPC\\|DEL\\)$" - word)))) - (setq key (list (intern word)))) - ((or (equal word "REM") (string-match "^;;" word)) - (setq pos (string-match "$" string pos))) - (t - (let ((orig-word word) (prefix 0) (bits 0)) - (while (string-match "^[ACHMsS]-." word) - (cl-incf bits (cdr (assq (aref word 0) - '((?A . ?\A-\^@) (?C . ?\C-\^@) - (?H . ?\H-\^@) (?M . ?\M-\^@) - (?s . ?\s-\^@) (?S . ?\S-\^@))))) - (cl-incf prefix 2) - (cl-callf substring word 2)) - (when (string-match "^\\^.$" word) - (cl-incf bits ?\C-\^@) - (cl-incf prefix) - (cl-callf substring word 1)) - (let ((found (assoc word '(("NUL" . "\0") ("RET" . "\r") - ("LFD" . "\n") ("TAB" . "\t") - ("ESC" . "\e") ("SPC" . " ") - ("DEL" . "\177"))))) - (when found (setq word (cdr found)))) - (when (string-match "^\\\\[0-7]+$" word) - (cl-loop for ch across word - for n = 0 then (+ (* n 8) ch -48) - finally do (setq word (vector n)))) - (cond ((= bits 0) - (setq key word)) - ((and (= bits ?\M-\^@) (stringp word) - (string-match "^-?[0-9]+$" word)) - (setq key (cl-loop for x across word - collect (+ x bits)))) - ((/= (length word) 1) - (error "%s must prefix a single character, not %s" - (substring orig-word 0 prefix) word)) - ((and (/= (logand bits ?\C-\^@) 0) (stringp word) - ;; We used to accept . and ? here, - ;; but . is simply wrong, - ;; and C-? is not used (we use DEL instead). - (string-match "[@-_a-z]" word)) - (setq key (list (+ bits (- ?\C-\^@) - (logand (aref word 0) 31))))) - (t - (setq key (list (+ bits (aref word 0))))))))) - (when key - (cl-loop repeat times do (cl-callf vconcat res key))))) - (when (and (>= (length res) 4) - (eq (aref res 0) ?\C-x) - (eq (aref res 1) ?\() - (eq (aref res (- (length res) 2)) ?\C-x) - (eq (aref res (- (length res) 1)) ?\))) - (setq res (cl-subseq res 2 -2))) - (if (and (not need-vector) - (cl-loop for ch across res - always (and (characterp ch) - (let ((ch2 (logand ch (lognot ?\M-\^@)))) - (and (>= ch2 0) (<= ch2 127)))))) - (concat (cl-loop for ch across res - collect (if (= (logand ch ?\M-\^@) 0) - ch (+ ch 128)))) - res))) + (let ((result (kbd string))) + (if (and need-vector (stringp result)) + (seq-into result 'vector) + result))) (provide 'edmacro) diff --git a/lisp/elec-pair.el b/lisp/elec-pair.el index ba88c819133..f907bba4c6e 100644 --- a/lisp/elec-pair.el +++ b/lisp/elec-pair.el @@ -308,51 +308,51 @@ If point is not enclosed by any lists, return ((t) . (t))." ;; called when `scan-sexps' ran perfectly, when it found ;; a parenthesis pointing in the direction of travel. ;; Also when travel started inside a comment and exited it. - #'(lambda () - (setq outermost (list t)) - (unless innermost - (setq innermost (list t))))) + (lambda () + (setq outermost (list t)) + (unless innermost + (setq innermost (list t))))) (ended-prematurely-fn ;; called when `scan-sexps' crashed against a parenthesis ;; pointing opposite the direction of travel. After ;; traversing that character, the idea is to travel one sexp ;; in the opposite direction looking for a matching ;; delimiter. - #'(lambda () - (let* ((pos (point)) - (matched - (save-excursion - (cond ((< direction 0) - (condition-case nil - (eq (char-after pos) - (electric-pair--with-uncached-syntax - (table) - (matching-paren - (char-before - (scan-sexps (point) 1))))) - (scan-error nil))) - (t - ;; In this case, no need to use - ;; `scan-sexps', we can use some - ;; `electric-pair--syntax-ppss' in this - ;; case (which uses the quicker - ;; `syntax-ppss' in some cases) - (let* ((ppss (electric-pair--syntax-ppss - (1- (point)))) - (start (car (last (nth 9 ppss)))) - (opener (char-after start))) - (and start - (eq (char-before pos) - (or (with-syntax-table table - (matching-paren opener)) - opener)))))))) - (actual-pair (if (> direction 0) - (char-before (point)) - (char-after (point))))) - (unless innermost - (setq innermost (cons matched actual-pair))) - (unless matched - (setq outermost (cons matched actual-pair))))))) + (lambda () + (let* ((pos (point)) + (matched + (save-excursion + (cond ((< direction 0) + (condition-case nil + (eq (char-after pos) + (electric-pair--with-uncached-syntax + (table) + (matching-paren + (char-before + (scan-sexps (point) 1))))) + (scan-error nil))) + (t + ;; In this case, no need to use + ;; `scan-sexps', we can use some + ;; `electric-pair--syntax-ppss' in this + ;; case (which uses the quicker + ;; `syntax-ppss' in some cases) + (let* ((ppss (electric-pair--syntax-ppss + (1- (point)))) + (start (car (last (nth 9 ppss)))) + (opener (char-after start))) + (and start + (eq (char-before pos) + (or (with-syntax-table table + (matching-paren opener)) + opener)))))))) + (actual-pair (if (> direction 0) + (char-before (point)) + (char-after (point))))) + (unless innermost + (setq innermost (cons matched actual-pair))) + (unless matched + (setq outermost (cons matched actual-pair))))))) (save-excursion (while (not outermost) (condition-case err diff --git a/lisp/electric.el b/lisp/electric.el index 4394fae4366..a2f24ca05c6 100644 --- a/lisp/electric.el +++ b/lisp/electric.el @@ -506,11 +506,11 @@ This list's members correspond to left single quote, right single quote, left double quote, and right double quote, respectively." :version "26.1" :type '(list character character character character) - :safe #'(lambda (x) - (pcase x - (`(,(pred characterp) ,(pred characterp) - ,(pred characterp) ,(pred characterp)) - t))) + :safe (lambda (x) + (pcase x + (`(,(pred characterp) ,(pred characterp) + ,(pred characterp) ,(pred characterp)) + t))) :group 'electricity) (defcustom electric-quote-paragraph t diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index aaacba2c8e5..d8b4c1f8850 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -32,7 +32,7 @@ (require 'lisp-mode) ;for `doc-string-elt' properties. (require 'lisp-mnt) -(eval-when-compile (require 'cl-lib)) +(require 'cl-lib) (defvar generated-autoload-file nil "File into which to write autoload definitions. @@ -393,6 +393,8 @@ FILE's name." (concat ";;; " basename " --- automatically extracted " (or type "autoloads") " -*- lexical-binding: t -*-\n" + (when (string-match "/lisp/loaddefs\\.el\\'" file) + ";; This file will be copied to ldefs-boot.el and checked in periodically.\n") ";;\n" ";;; Code:\n\n" (if lp @@ -1194,9 +1196,17 @@ directory or directories specified." (goto-char (point-max)) (search-backward "\f" nil t) (autoload-insert-section-header - (current-buffer) nil nil no-autoloads (if autoload-timestamps - no-autoloads-time - autoload--non-timestamp)) + (current-buffer) nil nil + ;; Filter out the other loaddefs files, because it makes + ;; the list unstable (and leads to spurious changes in + ;; ldefs-boot.el) since the loaddef files can be created in + ;; any order. + (seq-filter (lambda (file) + (not (string-match-p "[/-]loaddefs.el" file))) + no-autoloads) + (if autoload-timestamps + no-autoloads-time + autoload--non-timestamp)) (insert generate-autoload-section-trailer))) ;; Don't modify the file if its content has not been changed, so `make' diff --git a/lisp/emacs-lisp/backtrace.el b/lisp/emacs-lisp/backtrace.el index a5721aa3193..a8b484aee0b 100644 --- a/lisp/emacs-lisp/backtrace.el +++ b/lisp/emacs-lisp/backtrace.el @@ -55,9 +55,9 @@ order to debug the code that does fontification." (defcustom backtrace-line-length 5000 "Target length for lines in Backtrace buffers. Backtrace mode will attempt to abbreviate printing of backtrace -frames to make them shorter than this, but success is not -guaranteed. If set to nil or zero, Backtrace mode will not -abbreviate the forms it prints." +frames by setting `print-level' and `print-length' to make them +shorter than this, but success is not guaranteed. If set to nil +or zero, backtrace mode will not abbreviate the forms it prints." :type 'integer :group 'backtrace :version "27.1") @@ -751,6 +751,13 @@ property for use by navigation." (insert (make-string (- backtrace--flags-width (- (point) beg)) ?\s)) (put-text-property beg (point) 'backtrace-section 'func))) +(defun backtrace--line-length-or-nil () + "Return `backtrace-line-length' if valid, nil else." + ;; mirror the logic in `cl-print-to-string-with-limits' + (and (natnump backtrace-line-length) + (not (zerop backtrace-line-length)) + backtrace-line-length)) + (defun backtrace--print-func-and-args (frame _view) "Print the function, arguments and buffer position of a backtrace FRAME. Format it according to VIEW." @@ -769,11 +776,16 @@ Format it according to VIEW." (if (atom fun) (funcall backtrace-print-function fun) (insert - (backtrace--print-to-string fun (when args (/ backtrace-line-length 2))))) + (backtrace--print-to-string + fun + (when (and args (backtrace--line-length-or-nil)) + (/ backtrace-line-length 2))))) (if args (insert (backtrace--print-to-string - args (max (truncate (/ backtrace-line-length 5)) - (- backtrace-line-length (- (point) beg))))) + args + (if (backtrace--line-length-or-nil) + (max (truncate (/ backtrace-line-length 5)) + (- backtrace-line-length (- (point) beg)))))) ;; The backtrace-form property is so that backtrace-multi-line ;; will find it. backtrace-multi-line doesn't do anything ;; useful with it, just being consistent. diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index c8990f23531..2bdf1f55111 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -342,8 +342,12 @@ for speeding up processing.") (numberp expr) (stringp expr) (and (consp expr) - (memq (car expr) '(quote function)) - (symbolp (cadr expr))) + (or (and (memq (car expr) '(quote function)) + (symbolp (cadr expr))) + ;; (internal-get-closed-var N) can be considered constant for + ;; const-prop purposes. + (and (eq (car expr) 'internal-get-closed-var) + (integerp (cadr expr))))) (keywordp expr))) (defmacro byte-optimize--pcase (exp &rest cases) @@ -1261,7 +1265,7 @@ See Info node `(elisp) Integer Basics'." (list 'or (car (car clauses)) (byte-optimize-cond (cons (car form) (cdr (cdr form))))) - form)) + (and clauses form))) form)) (defun byte-optimize-if (form) diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index da86fa5cecf..2ce2efd2aa7 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -134,6 +134,7 @@ The return value of this function is not used." :autoload-end (eval-and-compile (defun ,cfname (,@(car data) ,@args) + (ignore ,@(delq '&rest (delq '&optional (copy-sequence args)))) ,@(cdr data)))))))) (defalias 'byte-run--set-doc-string @@ -380,7 +381,7 @@ You don't need this. (See bytecomp.el commentary for more details.) "Define an inline function. The syntax is just like that of `defun'. \(fn NAME ARGLIST &optional DOCSTRING DECL &rest BODY)" - (declare (debug defun) (doc-string 3)) + (declare (debug defun) (doc-string 3) (indent 2)) (or (memq (get name 'byte-optimizer) '(nil byte-compile-inline-expand)) (error "`%s' is a primitive" name)) @@ -434,7 +435,7 @@ WHEN should be a string indicating when the function was first made obsolete, for example a date or a release number. See the docstrings of `defalias' and `make-obsolete' for more details." - (declare (doc-string 4)) + (declare (doc-string 4) (indent defun)) `(progn (defalias ,obsolete-name ,current-name ,docstring) (make-obsolete ,obsolete-name ,current-name ,when))) @@ -483,7 +484,7 @@ For the benefit of Customize, if OBSOLETE-NAME has any of the following properties, they are copied to CURRENT-NAME, if it does not already have them: `saved-value', `saved-variable-comment'." - (declare (doc-string 4)) + (declare (doc-string 4) (indent defun)) `(progn (defvaralias ,obsolete-name ,current-name ,docstring) ;; See Bug#4706. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 3f050d1b799..644d9f1a470 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -299,7 +299,7 @@ The information is logged to `byte-compile-log-buffer'." '(redefine callargs free-vars unresolved obsolete noruntime interactive-only make-local mapcar constants suspicious lexical lexical-dynamic - docstrings) + docstrings not-unused) "The list of warning types used when `byte-compile-warnings' is t.") (defcustom byte-compile-warnings t "List of warnings that the byte-compiler should issue (t for all). @@ -321,6 +321,7 @@ Elements of the list may be: lexically bound variable declared dynamic elsewhere make-local calls to `make-variable-buffer-local' that may be incorrect. mapcar mapcar called for effect. + not-unused warning about using variables with symbol names starting with _. constants let-binding of, or assignment to, constants/nonvariables. docstrings docstrings that are too wide (longer than `byte-compile-docstring-max-column' or @@ -343,6 +344,7 @@ suppress. For example, (not mapcar) will suppress warnings about mapcar." (or (symbolp v) (null (delq nil (mapcar (lambda (x) (not (symbolp x))) v)))))) +;;;###autoload (defun byte-compile-warning-enabled-p (warning &optional symbol) "Return non-nil if WARNING is enabled, according to `byte-compile-warnings'." (let ((suppress nil)) @@ -1671,9 +1673,14 @@ URLs." ;; known at compile time. So instead, we assume that these ;; substitutions are of some length N. (replace-regexp-in-string - (rx "\\" (or (seq "[" (* (not "]")) "]"))) + (rx "\\[" (* (not "]")) "]") (make-string byte-compile--wide-docstring-substitution-len ?x) - docstring)))) + ;; For literal key sequence substitutions (e.g. "\\`C-h'"), just + ;; remove the markup as `substitute-command-keys' would. + (replace-regexp-in-string + (rx "\\`" (group (* (not "'"))) "'") + "\\1" + docstring))))) (defcustom byte-compile-docstring-max-column 80 "Recommended maximum width of doc string lines. @@ -1705,10 +1712,10 @@ It is too wide if it has any lines longer than the largest of (nth 2 form))))) (when (and (consp name) (eq (car name) 'quote)) (setq name (cadr name))) - (setq name (if name (format " `%s'" name) "")) + (setq name (if name (format " `%s' " name) "")) (when (and kind docs (stringp docs) (byte-compile--wide-docstring-p docs col)) - (byte-compile-warn "%s%s docstring wider than %s characters" + (byte-compile-warn "%s%sdocstring wider than %s characters" kind name col)))) form) @@ -2223,8 +2230,7 @@ With argument ARG, insert value in current buffer after the form." (byte-compile-depth 0) (byte-compile-maxdepth 0) (byte-compile-output nil) - ;; This allows us to get the positions of symbols read; it's - ;; new in Emacs 22.1. + ;; This allows us to get the positions of symbols read. (read-with-symbol-positions inbuffer) (read-symbol-positions-list nil) ;; #### This is bound in b-c-close-variables. @@ -5042,6 +5048,8 @@ binding slots have been popped." nil)) (_ (byte-compile-keep-pending form)))) + + ;;; tags diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 0a6b04b4c1f..7cec91bfa82 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -304,6 +304,25 @@ of converted forms." `(,@(nreverse special-forms) ,@(macroexp-unprogn body)))) funcbody))) +(defun cconv--lifted-arg (var env) + "The argument to use for VAR in λ-lifted calls according to ENV. +This is used when VAR is being shadowed; we may still need its value for +such calls." + (let ((mapping (cdr (assq var env)))) + (pcase-exhaustive mapping + (`(internal-get-closed-var . ,_) + ;; The variable is captured. + mapping) + (`(car-safe ,exp) + ;; The variable is mutably captured; skip + ;; the indirection step because the variable is + ;; passed "by reference" to the λ-lifted function. + exp) + (_ + ;; The variable is not captured; use the (shadowed) variable value. + ;; (If the mapping is `(car-safe SYMBOL)', SYMBOL is always VAR. + var)))) + (defun cconv-convert (form env extend) ;; This function actually rewrites the tree. "Return FORM with all its lambdas changed so they are closed. @@ -428,10 +447,11 @@ places where they originally did not directly appear." ;; One of the lambda-lifted vars is shadowed, so add ;; a reference to the outside binding and arrange to use ;; that reference. - (let ((closedsym (make-symbol (format "closed-%s" var)))) + (let ((var-def (cconv--lifted-arg var env)) + (closedsym (make-symbol (format "closed-%s" var)))) (setq new-env (cconv--remap-llv new-env var closedsym)) (setq new-extend (cons closedsym (remq var new-extend))) - (push `(,closedsym ,var) binders-new))) + (push `(,closedsym ,var-def) binders-new))) ;; We push the element after redefined free variables are ;; processed. This is important to avoid the bug when free @@ -449,14 +469,13 @@ places where they originally did not directly appear." ;; before we know that the var will be in `new-extend' (bug#24171). (dolist (binder binders-new) (when (memq (car-safe binder) new-extend) - ;; One of the lambda-lifted vars is shadowed, so add - ;; a reference to the outside binding and arrange to use - ;; that reference. + ;; One of the lambda-lifted vars is shadowed. (let* ((var (car-safe binder)) + (var-def (cconv--lifted-arg var env)) (closedsym (make-symbol (format "closed-%s" var)))) (setq new-env (cconv--remap-llv new-env var closedsym)) (setq new-extend (cons closedsym (remq var new-extend))) - (push `(,closedsym ,var) binders-new))))) + (push `(,closedsym ,var-def) binders-new))))) `(,letsym ,(nreverse binders-new) . ,(mapcar (lambda (form) @@ -608,10 +627,9 @@ FORM is the parent form that binds this var." (`((,(and var (guard (eq ?_ (aref (symbol-name var) 0)))) . ,_) ,_ ,_ ,_ ,_) ;; FIXME: Convert this warning to use `macroexp--warn-wrap' - ;; so as to give better position information and obey - ;; `byte-compile-warnings'. - (byte-compile-warn - "%s `%S' not left unused" varkind var)) + ;; so as to give better position information. + (when (byte-compile-warning-enabled-p 'not-unused var) + (byte-compile-warn "%s `%S' not left unused" varkind var))) ((and (let (or 'let* 'let) (car form)) `((,var) ;; (or `(,var nil) : Too many false positives: bug#47080 t nil ,_ ,_)) diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index e03ddc4c666..ab2f34c3104 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -339,6 +339,7 @@ See Info node `(elisp) Documentation Tips' for background." ;; (setq checkdoc--argument-missing-flag nil) ; optional ;; (setq checkdoc--disambiguate-symbol-flag nil) ; optional ;; (setq checkdoc--interactive-docstring-flag nil) ; optional +;; (setq checkdoc-verb-check-experimental-flag nil) ;; Then use `M-x find-dired' ("-name '*.el'") and `M-x checkdoc-dired' (defvar checkdoc--argument-missing-flag t @@ -493,6 +494,9 @@ be re-created.") (defconst checkdoc--help-buffer "*Checkdoc Help*" "Name of buffer used for Checkdoc Help.") +(defvar checkdoc-commentary-header-string "\n;;; Commentary:\n;; \n\n" + "String inserted as commentary marker in `checkdoc-file-comments-engine'.") + ;;; User level commands ;; ;;;###autoload @@ -1112,6 +1116,7 @@ space at the end of each line." ";;; lisp/trampver.el. Generated from trampver.el.in by configure.")) "Regexp that when it matches tells `checkdoc-dired' to skip a file.") +;;;###autoload (defun checkdoc-dired (files) "In Dired, run `checkdoc' on marked files. Skip anything that doesn't have the Emacs Lisp library file @@ -2125,13 +2130,11 @@ Examples of recognized abbreviations: \"e.g.\", \"i.e.\", \"cf.\"." ;; a part of a list. (rx letter ".") (rx (or - ;; The abbreviations: + ;; The abbreviations (a trailing dot is added below). (seq (any "cC") "f") ; cf. (seq (any "eE") ".g") ; e.g. (seq (any "iI") "." (any "eE")) ; i.e. - "a.k.a" ; a.k.a. - "etc" ; etc. - "vs" ; vs. + "a.k.a" "etc" "vs" "N.B" ;; Some non-standard or less common ones that we ;; might as well accept. "Inc" "Univ" "misc" "resp") @@ -2410,7 +2413,7 @@ Code:, and others referenced in the style guide." nil nil t))) (if (checkdoc-y-or-n-p "You should have a \";;; Commentary:\", add one?") - (insert "\n;;; Commentary:\n;; \n\n") + (insert checkdoc-commentary-header-string) (checkdoc-create-error "You should have a section marked \";;; Commentary:\"" nil nil t))) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 4834fb13c6a..9de47e4987d 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -86,6 +86,14 @@ ;;; Code: +;; We provide a mechanism to define new specializers. +;; Related work can be found in: +;; - http://www.p-cos.net/documents/filtered-dispatch.pdf +;; - Generalizers: New metaobjects for generalized dispatch +;; http://research.gold.ac.uk/9924/1/els-specializers.pdf +;; This second one is closely related to what we do here (and that's +;; the name "generalizer" comes from). + ;; The autoloads.el mechanism which adds package--builtin-versions ;; maintenance to loaddefs.el doesn't work for preloaded packages (such ;; as this one), so we have to do it by hand! @@ -100,6 +108,7 @@ (eval-when-compile (require 'cl-lib)) (eval-when-compile (require 'cl-macs)) ;For cl--find-class. (eval-when-compile (require 'pcase)) +(eval-when-compile (require 'subr-x)) (cl-defstruct (cl--generic-generalizer (:constructor nil) @@ -589,19 +598,10 @@ The set of acceptable TYPEs (also called \"specializers\") is defined ;; e.g. for tracing/debug-on-entry. (defalias sym gfun))))) -(defmacro cl--generic-with-memoization (place &rest code) - (declare (indent 1) (debug t)) - (gv-letplace (getter setter) place - `(or ,getter - ,(macroexp-let2 nil val (macroexp-progn code) - `(progn - ,(funcall setter val) - ,val))))) - (defvar cl--generic-dispatchers (make-hash-table :test #'equal)) (defun cl--generic-get-dispatcher (dispatch) - (cl--generic-with-memoization + (with-memoization (gethash dispatch cl--generic-dispatchers) ;; (message "cl--generic-get-dispatcher (%S)" dispatch) (let* ((dispatch-arg (car dispatch)) @@ -644,10 +644,13 @@ The set of acceptable TYPEs (also called \"specializers\") is defined ;; overkill: better just use a `cl-typep' test. (byte-compile `(lambda (generic dispatches-left methods) + ;; FIXME: We should find a way to expand `with-memoize' once + ;; and forall so we don't need `subr-x' when we get here. + (eval-when-compile (require 'subr-x)) (let ((method-cache (make-hash-table :test #'eql))) (lambda (,@fixedargs &rest args) (let ,bindings - (apply (cl--generic-with-memoization + (apply (with-memoization (gethash ,tag-exp method-cache) (cl--generic-cache-miss generic ',dispatch-arg dispatches-left methods @@ -684,14 +687,14 @@ This is particularly useful when many different tags select the same set of methods, since this table then allows us to share a single combined-method for all those different tags in the method-cache.") -(define-error 'cl--generic-cyclic-definition "Cyclic definition: %S") +(define-error 'cl--generic-cyclic-definition "Cyclic definition") (defun cl--generic-build-combined-method (generic methods) (if (null methods) ;; Special case needed to fix a circularity during bootstrap. (cl--generic-standard-method-combination generic methods) (let ((f - (cl--generic-with-memoization + (with-memoization ;; FIXME: Since the fields of `generic' are modified, this ;; hash-table won't work right, because the hashes will change! ;; It's not terribly serious, but reduces the effectiveness of @@ -1143,7 +1146,7 @@ These match if the argument is a cons cell whose car is `eql' to VAL." ;; since we can't use the `head' specializer to implement itself. (if (not (eq (car-safe specializer) 'head)) (cl-call-next-method) - (cl--generic-with-memoization + (with-memoization (gethash (cadr specializer) cl--generic-head-used) specializer) (list cl--generic-head-generalizer))) diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index 317a4c62309..b01a32ca60c 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -560,4 +560,9 @@ of record objects." (t (advice-remove 'type-of #'cl--old-struct-type-of)))) +(defun cl-constantly (value) + "Return a function that takes any number of arguments, but returns VALUE." + (lambda (&rest _) + value)) + ;;; cl-lib.el ends here diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 1852471bcbb..f78fdcf0085 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -3050,7 +3050,7 @@ To see the documentation for a defined struct type, use `(,predicate cl-x)))) (when pred-form (push `(,defsym ,predicate (cl-x) - (declare (side-effect-free error-free)) + (declare (side-effect-free error-free) (pure t)) ,(if (eq (car pred-form) 'and) (append pred-form '(t)) `(and ,pred-form t))) @@ -3365,6 +3365,7 @@ Of course, we really can't know that for sure, so it's just a heuristic." (integer . integerp) (keyword . keywordp) (list . listp) + (natnum . natnump) (number . numberp) (null . null) (real . numberp) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 5518cdb4c90..3e816195209 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -70,7 +70,7 @@ (irange &aux (range (list irange)) (typeset ()))) - (:copier comp-cstr-shallow-copy)) + (:copier nil)) "Internal representation of a type/value constraint." (typeset '(t) :type list :documentation "List of possible types the mvar can assume. @@ -133,6 +133,14 @@ Integer values are handled in the `range' slot.") :range (copy-tree (range cstr)) :neg (neg cstr)))) +(defsubst comp-cstr-shallow-copy (dst src) + "Copy the content of SRC into DST." + (with-comp-cstr-accessors + (setf (range dst) (range src) + (valset dst) (valset src) + (typeset dst) (typeset src) + (neg dst) (neg src)))) + (defsubst comp-cstr-empty-p (cstr) "Return t if CSTR is equivalent to the nil type specifier or nil otherwise." (with-comp-cstr-accessors @@ -438,10 +446,7 @@ Return them as multiple value." ext-range) ext-range) (neg dst) nil) - (setf (typeset dst) (typeset old-dst) - (valset dst) (valset old-dst) - (range dst) (range old-dst) - (neg dst) (neg old-dst))))) + (comp-cstr-shallow-copy dst old-dst)))) (defmacro comp-cstr-set-range-for-arithm (dst src1 src2 &rest range-body) ;; Prevent some code duplication for `comp-cstr-add-2' @@ -581,10 +586,8 @@ DST is returned." (when (range pos) '(integer))))) (typeset neg))) - (setf (typeset dst) (typeset pos) - (valset dst) (valset pos) - (range dst) (range pos) - (neg dst) nil) + (comp-cstr-shallow-copy dst pos) + (setf (neg dst) nil) (cl-return-from comp-cstr-union-1-no-mem dst)) ;; Verify disjoint condition between positive types and @@ -631,15 +634,9 @@ DST is returned." (comp-range-negation (range neg)) (range pos)))))) - (if (comp-cstr-empty-p neg) - (setf (typeset dst) (typeset pos) - (valset dst) (valset pos) - (range dst) (range pos) - (neg dst) nil) - (setf (typeset dst) (typeset neg) - (valset dst) (valset neg) - (range dst) (range neg) - (neg dst) (neg neg))))) + (comp-cstr-shallow-copy dst (if (comp-cstr-empty-p neg) + pos + neg)))) ;; (not null) => t (when (and (neg dst) @@ -663,10 +660,7 @@ DST is returned." (mapcar #'comp-cstr-copy srcs) (apply #'comp-cstr-union-1-no-mem range srcs) mem-h)))) - (setf (typeset dst) (typeset res) - (valset dst) (valset res) - (range dst) (range res) - (neg dst) (neg res)) + (comp-cstr-shallow-copy dst res) res))) (cl-defun comp-cstr-intersection-homogeneous (dst &rest srcs) @@ -753,10 +747,8 @@ Non memoized version of `comp-cstr-intersection-no-mem'." ;; In case pos is not relevant return directly the content ;; of neg. (when (equal (typeset pos) '(t)) - (setf (typeset dst) (typeset neg) - (valset dst) (valset neg) - (range dst) (range neg) - (neg dst) t) + (comp-cstr-shallow-copy dst neg) + (setf (neg dst) t) ;; (not t) => nil (when (and (null (valset dst)) @@ -800,10 +792,8 @@ Non memoized version of `comp-cstr-intersection-no-mem'." (cl-set-difference (valset pos) (valset neg))) ;; Return a non negated form. - (setf (typeset dst) (typeset pos) - (valset dst) (valset pos) - (range dst) (range pos) - (neg dst) nil))) + (comp-cstr-shallow-copy dst pos) + (setf (neg dst) nil))) dst)))) @@ -883,7 +873,7 @@ Non memoized version of `comp-cstr-intersection-no-mem'." "Constraint OP1 being = OP2 setting the result into DST." (with-comp-cstr-accessors (cl-flet ((relax-cstr (cstr) - (setf cstr (comp-cstr-shallow-copy cstr)) + (setf cstr (copy-sequence cstr)) ;; If can be any float extend it to all integers. (when (memq 'float (typeset cstr)) (setf (range cstr) '((- . +)))) @@ -1008,10 +998,7 @@ DST is returned." (mapcar #'comp-cstr-copy srcs) (apply #'comp-cstr-intersection-no-mem srcs) mem-h)))) - (setf (typeset dst) (typeset res) - (valset dst) (valset res) - (range dst) (range res) - (neg dst) (neg res)) + (comp-cstr-shallow-copy dst res) res))) (defun comp-cstr-intersection-no-hashcons (dst &rest srcs) @@ -1067,10 +1054,9 @@ DST is returned." (valset dst) () (range dst) nil (neg dst) nil)) - (t (setf (typeset dst) (typeset src) - (valset dst) (valset src) - (range dst) (range src) - (neg dst) (not (neg src))))) + (t + (comp-cstr-shallow-copy dst src) + (setf (neg dst) (not (neg src))))) dst)) (defun comp-cstr-value-negation (dst src) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 0a105052570..b51224088f1 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3086,13 +3086,6 @@ Forward propagate immediate involed in assignments." ; FIXME: Typo. Involved or (`(setimm ,lval ,v) (setf (comp-cstr-imm lval) v)))))) -(defun comp-mvar-propagate (lval rval) - "Propagate into LVAL properties of RVAL." - (setf (comp-mvar-typeset lval) (comp-mvar-typeset rval) - (comp-mvar-valset lval) (comp-mvar-valset rval) - (comp-mvar-range lval) (comp-mvar-range rval) - (comp-mvar-neg lval) (comp-mvar-neg rval))) - (defun comp-function-foldable-p (f args) "Given function F called with ARGS, return non-nil when optimizable." (and (comp-function-pure-p f) @@ -3142,10 +3135,7 @@ Fold the call in case." (when (comp-cstr-empty-p cstr) ;; Store it to be rewritten as non local exit. (setf (comp-block-lap-non-ret-insn comp-block) insn)) - (setf (comp-mvar-range lval) (comp-cstr-range cstr) - (comp-mvar-valset lval) (comp-cstr-valset cstr) - (comp-mvar-typeset lval) (comp-cstr-typeset cstr) - (comp-mvar-neg lval) (comp-cstr-neg cstr)))) + (comp-cstr-shallow-copy lval cstr))) (cl-case f (+ (comp-cstr-add lval args)) (- (comp-cstr-sub lval args)) @@ -3163,9 +3153,9 @@ Fold the call in case." (let ((f (comp-func-name (gethash f (comp-ctxt-funcs-h comp-ctxt))))) (comp-fwprop-call insn lval f args))) (_ - (comp-mvar-propagate lval rval)))) + (comp-cstr-shallow-copy lval rval)))) (`(assume ,lval ,(and (pred comp-mvar-p) rval)) - (comp-mvar-propagate lval rval)) + (comp-cstr-shallow-copy lval rval)) (`(assume ,lval (,kind . ,operands)) (cl-case kind (and diff --git a/lisp/emacs-lisp/crm.el b/lisp/emacs-lisp/crm.el index d24ea355a51..59cbc0e50d5 100644 --- a/lisp/emacs-lisp/crm.el +++ b/lisp/emacs-lisp/crm.el @@ -244,30 +244,29 @@ contents of the minibuffer are \"alice,bob,eve\" and point is between This function returns a list of the strings that were read, with empty strings removed." - (unwind-protect - (progn - (add-hook 'choose-completion-string-functions - 'crm--choose-completion-string) - (let* ((minibuffer-completion-table #'crm--collection-fn) - (minibuffer-completion-predicate predicate) - ;; see completing_read in src/minibuf.c - (minibuffer-completion-confirm - (unless (eq require-match t) require-match)) - (crm-completion-table table) - (map (if require-match - crm-local-must-match-map - crm-local-completion-map)) - ;; If the user enters empty input, `read-from-minibuffer' - ;; returns the empty string, not DEF. - (input (read-from-minibuffer - prompt initial-input map - nil hist def inherit-input-method))) - (when (and def (string-equal input "")) - (setq input (if (consp def) (car def) def))) - ;; Remove empty strings in the list of read strings. - (split-string input crm-separator t))) - (remove-hook 'choose-completion-string-functions - 'crm--choose-completion-string))) + (let* ((map (if require-match + crm-local-must-match-map + crm-local-completion-map)) + input) + (minibuffer-with-setup-hook + (lambda () + (add-hook 'choose-completion-string-functions + 'crm--choose-completion-string nil 'local) + (setq-local minibuffer-completion-table #'crm--collection-fn) + (setq-local minibuffer-completion-predicate predicate) + ;; see completing_read in src/minibuf.c + (setq-local minibuffer-completion-confirm + (unless (eq require-match t) require-match)) + (setq-local crm-completion-table table)) + (setq input (read-from-minibuffer + prompt initial-input map + nil hist def inherit-input-method))) + ;; If the user enters empty input, `read-from-minibuffer' + ;; returns the empty string, not DEF. + (when (and def (string-equal input "")) + (setq input (if (consp def) (car def) def))) + ;; Remove empty strings in the list of read strings. + (split-string input crm-separator t))) ;; testing and debugging ;; (defun crm-init-test-environ () diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index 0592db85df4..163528acf6f 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -701,7 +701,8 @@ To specify a nil argument interactively, exit with an empty minibuffer." (interactive (list (let ((name (completing-read - "Cancel debug on entry to function (default all functions): " + (format-prompt "Cancel debug on entry to function" + "all functions") (mapcar #'symbol-name (debug--function-list)) nil t))) (when name (unless (string= name "") @@ -804,7 +805,8 @@ To specify a nil argument interactively, exit with an empty minibuffer." (interactive (list (let ((name (completing-read - "Cancel debug on set for variable (default all variables): " + (format-prompt "Cancel debug on set for variable" + "all variables") (mapcar #'symbol-name (debug--variable-list)) nil t))) (when name (unless (string= name "") diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el index dd30846546b..af5eecc22a5 100644 --- a/lisp/emacs-lisp/derived.el +++ b/lisp/emacs-lisp/derived.el @@ -175,12 +175,7 @@ See Info node `(elisp)Derived Modes' for more details. (declare (debug (&define name symbolp sexp [&optional stringp] [&rest keywordp sexp] def-body)) (doc-string 4) - ;; Ask not what - ;;(indent 3) - ;; can do for you, ask what it can do to others. IOW, the - ;; missing of indentation setting here is the indentation - ;; setting and not an oversight. - ) + (indent defun)) (when (and docstring (not (stringp docstring))) ;; Some trickiness, since what appears to be the docstring may really be diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index f752861d80a..db86e0e0292 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -198,6 +198,7 @@ INIT-VALUE LIGHTER KEYMAP. \(fn MODE DOC [KEYWORD VAL ... &rest BODY])" (declare (doc-string 2) + (indent defun) (debug (&define name string-or-null-p [&optional [¬ keywordp] sexp &optional [¬ keywordp] sexp @@ -450,7 +451,7 @@ after running the major mode's hook. However, MODE is not turned on if the hook has explicitly disabled it. \(fn GLOBAL-MODE MODE TURN-ON [KEY VALUE]... BODY...)" - (declare (doc-string 2)) + (declare (doc-string 2) (indent defun)) (let* ((global-mode-name (symbol-name global-mode)) (mode-name (symbol-name mode)) (pretty-name (easy-mmode-pretty-mode-name mode)) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 1ef29599512..ac1cd22ac27 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -3519,7 +3519,8 @@ The removes the effect of `edebug-on-entry'. If FUNCTION is nil, remove `edebug-on-entry' on all functions." (interactive (list (let ((name (completing-read - "Cancel edebug on entry to (default all functions): " + (format-prompt "Cancel edebug on entry to" + "all functions") (let ((functions (edebug--edebug-on-entry-functions))) (unless functions (user-error "No functions have `edebug-on-entry'")) @@ -4548,7 +4549,8 @@ instrumentation for, defaulting to all functions." (user-error "Found no functions to remove instrumentation from")) (let ((name (completing-read - "Remove instrumentation from (default all functions): " + (format-prompt "Remove instrumentation from" + "all functions") functions))) (if (and name (not (equal name ""))) diff --git a/lisp/emacs-lisp/eieio-compat.el b/lisp/emacs-lisp/eieio-compat.el index 6d84839c341..a5f37500092 100644 --- a/lisp/emacs-lisp/eieio-compat.el +++ b/lisp/emacs-lisp/eieio-compat.el @@ -5,6 +5,7 @@ ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Keywords: OO, lisp ;; Package: eieio +;; Obsolete-Since: 25.1 ;; This file is part of GNU Emacs. @@ -70,7 +71,8 @@ is appropriate to use. Uses `defmethod' to create methods, and calls `defgeneric' for you. With this implementation the ARGS are currently ignored. You can use `defgeneric' to apply specialized top level documentation to a method." - (declare (doc-string 3) (obsolete cl-defgeneric "25.1")) + (declare (doc-string 3) (obsolete cl-defgeneric "25.1") + (indent defun)) `(eieio--defalias ',method (eieio--defgeneric-init-form ',method @@ -103,6 +105,7 @@ Summary: \"doc-string\" body)" (declare (doc-string 3) (obsolete cl-defmethod "25.1") + (indent defun) (debug (&define ; this means we are defining something [&name sexp] ;Allow (setf ...) additionally to symbols. diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index 80d1711d817..ca47ec77f76 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -450,7 +450,7 @@ See `defclass' for more information." )) ;; Now that everything has been loaded up, all our lists are backwards! - ;; Fix that up now and then them into vectors. + ;; Fix that up now and turn them into vectors. (cl-callf (lambda (slots) (apply #'vector (nreverse slots))) (eieio--class-slots newc)) (cl-callf nreverse (eieio--class-initarg-tuples newc)) @@ -478,7 +478,8 @@ See `defclass' for more information." ;; (dotimes (cnt (length cslots)) ;; (setf (gethash (cl--slot-descriptor-name (aref cslots cnt)) oa) (- -1 cnt))) (dotimes (cnt (length slots)) - (setf (gethash (cl--slot-descriptor-name (aref slots cnt)) oa) cnt)) + (setf (gethash (cl--slot-descriptor-name (aref slots cnt)) oa) + (+ (eval-when-compile eieio--object-num-slots) cnt))) (setf (eieio--class-index-table newc) oa)) ;; Set up a specialized doc string. @@ -508,6 +509,7 @@ See `defclass' for more information." ;; Create the cached default object. (let ((cache (make-record newc (+ (length (eieio--class-slots newc)) + ;; FIXME: Why +1 -1 ? (eval-when-compile eieio--object-num-slots) -1) nil))) @@ -702,11 +704,15 @@ an error." nil ;; Trim off object IDX junk added in for the object index. (setq slot-idx (- slot-idx (eval-when-compile eieio--object-num-slots))) - (let ((st (cl--slot-descriptor-type (aref (eieio--class-slots class) - slot-idx)))) - (if (not (eieio--perform-slot-validation st value)) - (signal 'invalid-slot-type - (list (eieio--class-name class) slot st value)))))) + (let* ((sd (aref (eieio--class-slots class) + slot-idx)) + (st (cl--slot-descriptor-type sd))) + (cond + ((not (eieio--perform-slot-validation st value)) + (signal 'invalid-slot-type + (list (eieio--class-name class) slot st value))) + ((alist-get :read-only (cl--slot-descriptor-props sd)) + (signal 'eieio-read-only (list (eieio--class-name class) slot))))))) (defun eieio--validate-class-slot-value (class slot-idx value slot) "Make sure that for CLASS referencing SLOT-IDX, VALUE is valid. @@ -747,7 +753,7 @@ Argument FN is the function calling this verifier." (_ exp)))) (gv-setter eieio-oset)) (cl-check-type slot symbol) - (cl-check-type obj (or eieio-object class)) + (cl-check-type obj (or eieio-object class cl-structure-object)) (let* ((class (cond ((symbolp obj) (error "eieio-oref called on a class: %s" obj) (eieio--full-class-object obj)) @@ -763,7 +769,7 @@ Argument FN is the function calling this verifier." ;; to intercept missing slot definitions. Since it is also the LAST ;; thing called in this fn, its return value would be retrieved. (slot-missing obj slot 'oref)) - (cl-check-type obj eieio-object) + (cl-check-type obj (or eieio-object cl-structure-object)) (eieio-barf-if-slot-unbound (aref obj c) obj slot 'oref)))) @@ -811,7 +817,7 @@ Fills in CLASS's SLOT with its default value." (defun eieio-oset (obj slot value) "Do the work for the macro `oset'. Fills in OBJ's SLOT with VALUE." - (cl-check-type obj eieio-object) + (cl-check-type obj (or eieio-object cl-structure-object)) (cl-check-type slot symbol) (let* ((class (eieio--object-class obj)) (c (eieio--slot-name-index class slot))) @@ -892,7 +898,7 @@ reverse-lookup that name, and recurse with the associated slot value." ;; Removed checks to outside this call (let* ((fsi (gethash slot (eieio--class-index-table class)))) (if (integerp fsi) - (+ (eval-when-compile eieio--object-num-slots) fsi) + fsi (let ((fn (eieio--initarg-to-attribute class slot))) (if fn ;; Accessing a slot via its :initarg is accepted by EIEIO @@ -1061,6 +1067,7 @@ method invocation orders of the involved classes." ;; (define-error 'invalid-slot-name "Invalid slot name") (define-error 'invalid-slot-type "Invalid slot type") +(define-error 'eieio-read-only "Read-only slot") (define-error 'unbound-slot "Unbound slot") (define-error 'inconsistent-class-hierarchy "Inconsistent class hierarchy") diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index 9c842f46829..680395387c2 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el @@ -130,6 +130,7 @@ are not abstract." ;;;###autoload (defun eieio-help-constructor (ctr) "Describe CTR if it is a class constructor." + (declare (obsolete "use `describe-function' or `cl--describe-class'." "29.1")) (when (class-p ctr) (erase-buffer) (let ((location (find-lisp-object-file-name ctr 'define-type)) diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 2dc3e0aeffa..2850c91ecdf 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -110,7 +110,7 @@ Options in CLOS not supported in EIEIO: Due to the way class options are set up, you can add any tags you wish, and reference them using the function `class-option'." - (declare (doc-string 4)) + (declare (doc-string 4) (indent defun)) (cl-check-type superclasses list) (cond ((and (stringp (car options-and-doc)) @@ -359,9 +359,7 @@ variable name of the same name as the slot." (defun eieio-pcase-slot-index-from-index-table (index-table slot) "Find the index to pass to `aref' to access SLOT." - (let ((index (gethash slot index-table))) - (if index (+ (eval-when-compile eieio--object-num-slots) - index)))) + (gethash slot index-table)) (pcase-defmacro eieio (&rest fields) "Pcase patterns that match EIEIO object EXPVAL. @@ -994,11 +992,6 @@ of `eq'." (error "EIEIO: `change-class' is unimplemented")) (define-obsolete-function-alias 'change-class #'eieio-change-class "26.1") -;; Hook ourselves into help system for describing classes and methods. -;; FIXME: This is not actually needed any more since we can click on the -;; hyperlink from the constructor's docstring to see the type definition. -(add-hook 'help-fns-describe-function-functions #'eieio-help-constructor) - (provide 'eieio) ;;; eieio.el ends here diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index a1c3c3268f2..cd0e7dca7cf 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -380,7 +380,15 @@ Also store it in `eldoc-last-message' and return that value." ;; it undesirable to print eldoc messages right this instant. (defun eldoc-display-message-no-interference-p () "Return nil if displaying a message would cause interference." - (not (or executing-kbd-macro (bound-and-true-p edebug-active)))) + (not (or executing-kbd-macro + (bound-and-true-p edebug-active) + ;; The following configuration shows "Matches..." in the + ;; echo area when point is after a closing bracket, which + ;; conflicts with eldoc. + (and (boundp 'show-paren-context-when-offscreen) + show-paren-context-when-offscreen + (not (pos-visible-in-window-p + (overlay-end show-paren--overlay))))))) (defvar eldoc-documentation-functions nil diff --git a/lisp/emacs-lisp/elp.el b/lisp/emacs-lisp/elp.el index 8c33b7c9948..fde7947a273 100644 --- a/lisp/emacs-lisp/elp.el +++ b/lisp/emacs-lisp/elp.el @@ -202,14 +202,13 @@ This variable is set by the master function.") (defvar elp-not-profilable ;; First, the functions used inside each instrumented function: '(called-interactively-p - ;; Then the functions used by the above functions. I used - ;; (delq nil (mapcar (lambda (x) (and (symbolp x) (fboundp x) x)) - ;; (aref (symbol-function 'elp-wrapper) 2))) - ;; to help me find this list. - error call-interactively apply current-time + ;; (delq + ;; nil (mapcar + ;; (lambda (x) (and (symbolp x) (fboundp x) x)) + ;; (aref (aref (aref (symbol-function 'elp--make-wrapper) 2) 1) 2))) + error apply current-time float-time time-subtract ;; Andreas Politz reports problems profiling these (Bug#4233): - + byte-code-function-p functionp byte-code subrp - indirect-function fboundp) + + byte-code-function-p functionp byte-code subrp fboundp) "List of functions that cannot be profiled. Those functions are used internally by the profiling code and profiling them would thus lead to infinite recursion.") diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el index 3fc57d5182d..7fc316d1469 100644 --- a/lisp/emacs-lisp/ert-x.el +++ b/lisp/emacs-lisp/ert-x.el @@ -352,7 +352,6 @@ convert it to a string and pass it to COLLECTOR first." (defvar ert-resource-directory-trim-right-regexp "\\(-tests?\\)?\\.el" "Regexp for `string-trim' (right) used by `ert-resource-directory'.") -;; Has to be a macro for `load-file-name'. (defmacro ert-resource-directory () "Return absolute file name of the resource (test data) directory. @@ -368,17 +367,17 @@ variable `ert-resource-directory-format'. Before formatting, the file name will be trimmed using `string-trim' with arguments `ert-resource-directory-trim-left-regexp' and `ert-resource-directory-trim-right-regexp'." - `(let* ((testfile ,(or (macroexp-file-name) - buffer-file-name)) - (default-directory (file-name-directory testfile))) - (file-truename - (if (file-accessible-directory-p "resources/") - (expand-file-name "resources/") - (expand-file-name - (format ert-resource-directory-format - (string-trim testfile - ert-resource-directory-trim-left-regexp - ert-resource-directory-trim-right-regexp))))))) + `(when-let ((testfile ,(or (macroexp-file-name) + buffer-file-name))) + (let ((default-directory (file-name-directory testfile))) + (file-truename + (if (file-accessible-directory-p "resources/") + (expand-file-name "resources/") + (expand-file-name + (format ert-resource-directory-format + (string-trim testfile + ert-resource-directory-trim-left-regexp + ert-resource-directory-trim-right-regexp)))))))) (defmacro ert-resource-file (file) "Return absolute file name of resource (test data) file named FILE. @@ -386,6 +385,96 @@ A resource file is defined as any file placed in the resource directory as returned by `ert-resource-directory'." `(expand-file-name ,file (ert-resource-directory))) +(defvar ert-temp-file-prefix "emacs-test-" + "Prefix used by `ert-with-temp-file' and `ert-with-temp-directory'.") + +(defvar ert-temp-file-suffix nil + "Suffix used by `ert-with-temp-file' and `ert-with-temp-directory'.") + +(defun ert--with-temp-file-generate-suffix (filename) + "Generate temp file suffix from FILENAME." + (thread-last + (file-name-base filename) + (replace-regexp-in-string (rx string-start + (group (+? not-newline)) + (regexp "-?tests?") + string-end) + "\\1") + (concat "-"))) + +(defmacro ert-with-temp-file (name &rest body) + "Bind NAME to the name of a new temporary file and evaluate BODY. +Delete the temporary file after BODY exits normally or +non-locally. NAME will be bound to the file name of the temporary +file. + +The following keyword arguments are supported: + +:prefix STRING If non-nil, pass STRING to `make-temp-file' as + the PREFIX argument. Otherwise, use the value of + `ert-temp-file-prefix'. + +:suffix STRING If non-nil, pass STRING to `make-temp-file' as the + SUFFIX argument. Otherwise, use the value of + `ert-temp-file-suffix'; if the value of that + variable is nil, generate a suffix based on the + name of the file that `ert-with-temp-file' is + called from. + +:text STRING If non-nil, pass STRING to `make-temp-file' as + the TEXT argument. + +See also `ert-with-temp-directory'." + (declare (indent 1) (debug (symbolp body))) + (cl-check-type name symbol) + (let (keyw prefix suffix directory text extra-keywords) + (while (keywordp (setq keyw (car body))) + (setq body (cdr body)) + (pcase keyw + (:prefix (setq prefix (pop body))) + (:suffix (setq suffix (pop body))) + (:directory (setq directory (pop body))) + (:text (setq text (pop body))) + (_ (push keyw extra-keywords) (pop body)))) + (when extra-keywords + (error "Invalid keywords: %s" (mapconcat #'symbol-name extra-keywords " "))) + (let ((temp-file (make-symbol "temp-file")) + (prefix (or prefix ert-temp-file-prefix)) + (suffix (or suffix ert-temp-file-suffix + (ert--with-temp-file-generate-suffix + (or (macroexp-file-name) buffer-file-name))))) + `(let* ((,temp-file (,(if directory 'file-name-as-directory 'identity) + (make-temp-file ,prefix ,directory ,suffix ,text))) + (,name ,(if directory + `(file-name-as-directory ,temp-file) + temp-file))) + (unwind-protect + (progn ,@body) + (ignore-errors + ,(if directory + `(delete-directory ,temp-file :recursive) + `(delete-file ,temp-file)))))))) + +(defmacro ert-with-temp-directory (name &rest body) + "Bind NAME to the name of a new temporary directory and evaluate BODY. +Delete the temporary directory after BODY exits normally or +non-locally. + +NAME is bound to the directory name, not the directory file +name. (In other words, it will end with the directory delimiter; +on Unix-like systems, it will end with \"/\".) + +The same keyword arguments are supported as in +`ert-with-temp-file' (which see), except for :text." + (declare (indent 1) (debug (symbolp body))) + (let ((tail body) keyw) + (while (keywordp (setq keyw (car tail))) + (setq tail (cddr tail)) + (pcase keyw (:text (error "Invalid keyword for directory: :text"))))) + `(ert-with-temp-file ,name + :directory t + ,@body)) + (provide 'ert-x) ;;; ert-x.el ends here diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index b7d984374cb..597044cf21c 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -63,6 +63,9 @@ (require 'ewoc) (require 'find-func) (require 'pp) +(require 'map) + +(autoload 'xml-escape-string "xml.el") ;;; UI customization options. @@ -76,6 +79,35 @@ Use nil for no limit (caution: backtrace lines can be very long)." :type '(choice (const :tag "No truncation" nil) integer)) +(defvar ert-batch-print-length 10 + "`print-length' setting used in `ert-run-tests-batch'. + +When formatting lists in test conditions, `print-length' will be +temporarily set to this value. See also +`ert-batch-backtrace-line-length' for its effect on stack +traces.") + +(defvar ert-batch-print-level 5 + "`print-level' setting used in `ert-run-tests-batch'. + +When formatting lists in test conditions, `print-level' will be +temporarily set to this value. See also +`ert-batch-backtrace-line-length' for its effect on stack +traces.") + +(defvar ert-batch-backtrace-line-length t + "Target length for lines in ERT batch backtraces. + +Even modest settings for `print-length' and `print-level' can +produce extremely long lines in backtraces and lengthy delays in +forming them. This variable governs the target maximum line +length by manipulating these two variables while printing stack +traces. Setting this variable to t will re-use the value of +`backtrace-line-length' while printing stack traces in ERT batch +mode. Any other value will be temporarily bound to +`backtrace-line-length' when producing stack traces in batch +mode.") + (defface ert-test-result-expected '((((class color) (background light)) :background "green1") (((class color) (background dark)) @@ -88,23 +120,6 @@ Use nil for no limit (caution: backtrace lines can be very long)." :background "red3")) "Face used for unexpected results in the ERT results buffer.") - -;;; Copies/reimplementations of cl functions. - -(defun ert-equal-including-properties (a b) - "Return t if A and B have similar structure and contents. - -This is like `equal-including-properties' except that it compares -the property values of text properties structurally (by -recursing) rather than with `eq'. Perhaps this is what -`equal-including-properties' should do in the first place; see -Emacs bug 6581 at URL `https://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'." - ;; This implementation is inefficient. Rather than making it - ;; efficient, let's hope bug 6581 gets fixed so that we can delete - ;; it altogether. - (not (ert--explain-equal-including-properties a b))) - - ;;; Defining and locating tests. ;; The data structure that represents a test case. @@ -136,6 +151,10 @@ Emacs bug 6581 at URL `https://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'." ;; Note that nil is still a valid value for the `name' slot in ;; ert-test objects. It designates an anonymous test. (error "Attempt to define a test named nil")) + (when (and noninteractive (get symbol 'ert--test)) + ;; Make sure duplicated tests are discovered since the older test would + ;; be ignored silently otherwise. + (error "Test `%s' redefined" symbol)) (define-symbol-prop symbol 'ert--test definition) definition) @@ -191,6 +210,9 @@ Macros in BODY are expanded when the test is defined, not when it is run. If a macro (possibly with side effects) is to be tested, it has to be wrapped in `(eval (quote ...))'. +If NAME is already defined as a test and Emacs is running +in batch mode, an error is signalled. + \(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \ [:tags \\='(TAG...)] BODY...)" (declare (debug (&define [&name "test@" symbolp] @@ -218,11 +240,7 @@ it has to be wrapped in `(eval (quote ...))'. `(:expected-result-type ,expected-result)) ,@(when tags-supplied-p `(:tags ,tags)) - :body (lambda () - ;; Use the value of `lexical-binding' in - ;; the source file when evaluating the body. - (let ((lexical-binding ,lexical-binding)) - ,@body)))) + :body (lambda () ,@body))) ',name)))) (defvar ert--find-test-regexp @@ -231,7 +249,6 @@ it has to be wrapped in `(eval (quote ...))'. "%s\\(\\s-\\|$\\)") "The regexp the `find-function' mechanisms use for finding test definitions.") - (define-error 'ert-test-failed "Test failed") (define-error 'ert-test-skipped "Test skipped") @@ -469,7 +486,7 @@ Errors during evaluation are caught and handled like nil." (defun ert--explain-equal-rec (a b) "Return a programmer-readable explanation of why A and B are not `equal'. -Returns nil if they are." +Return nil if they are." (if (not (eq (type-of a) (type-of b))) `(different-types ,a ,b) (pcase a @@ -602,14 +619,9 @@ If SUFFIXP is non-nil, returns a suffix of S, otherwise a prefix." (t (substring s 0 len))))) -;; TODO(ohler): Once bug 6581 is fixed, rename this to -;; `ert--explain-equal-including-properties-rec' and add a fast-path -;; wrapper like `ert--explain-equal'. -(defun ert--explain-equal-including-properties (a b) - "Explainer function for `ert-equal-including-properties'. - -Returns a programmer-readable explanation of why A and B are not -`ert-equal-including-properties', or nil if they are." +(defun ert--explain-equal-including-properties-rec (a b) + "Return explanation of why A and B are not `equal-including-properties'. +Return nil if they are." (if (not (equal a b)) (ert--explain-equal a b) (cl-assert (stringp a) t) @@ -631,15 +643,17 @@ Returns a programmer-readable explanation of why A and B are not ,(ert--abbreviate-string (substring-no-properties a (1+ i)) 10 nil)))) - ;; TODO(ohler): Get `equal-including-properties' fixed in - ;; Emacs, delete `ert-equal-including-properties', and - ;; re-enable this assertion. - ;;finally (cl-assert (equal-including-properties a b) t) - ))) -(put 'ert-equal-including-properties - 'ert-explainer - 'ert--explain-equal-including-properties) + finally (cl-assert (equal-including-properties a b) t)))) +(defun ert--explain-equal-including-properties (a b) + "Explainer function for `equal-including-properties'." + ;; Do a quick comparison in C to avoid running our expensive + ;; comparison when possible. + (if (equal-including-properties a b) + nil + (ert--explain-equal-including-properties-rec a b))) +(put 'equal-including-properties 'ert-explainer + 'ert--explain-equal-including-properties) ;;; Implementation of `ert-info'. @@ -664,7 +678,6 @@ and is displayed in front of the value of MESSAGE-FORM." ,@body)) - ;;; Facilities for running a single test. (defvar ert-debug-on-error nil @@ -779,7 +792,8 @@ This mainly sets up debugger-related bindings." ;; handle ert errors. Once that's done, remove ;; `ert--should-signal-hook'. See Bug#24402 and Bug#11218 for ;; details. - (let ((debugger (lambda (&rest args) + (let ((lexical-binding t) + (debugger (lambda (&rest args) (ert--run-test-debugger test-execution-info args))) (debug-on-error t) @@ -1423,9 +1437,10 @@ Returns the stats object." (if (getenv "EMACS_TEST_VERBOSE") (ert-reason-for-test-result result) "")))) - (message "%s" ""))))) - (test-started - ) + (message "%s" "")) + (when (getenv "EMACS_TEST_JUNIT_REPORT") + (ert-write-junit-test-report stats))))) + (test-started) (test-ended (cl-destructuring-bind (stats test result) event-args (unless (ert-test-result-expected-p test result) @@ -1435,8 +1450,14 @@ Returns the stats object." (ert-test-result-with-condition (message "Test %S backtrace:" (ert-test-name test)) (with-temp-buffer - (insert (backtrace-to-string - (ert-test-result-with-condition-backtrace result))) + (let ((backtrace-line-length + (if (eq ert-batch-backtrace-line-length t) + backtrace-line-length + ert-batch-backtrace-line-length)) + (print-level ert-batch-print-level) + (print-length ert-batch-print-length)) + (insert (backtrace-to-string + (ert-test-result-with-condition-backtrace result)))) (if (not ert-batch-backtrace-right-margin) (message "%s" (buffer-substring-no-properties (point-min) @@ -1455,8 +1476,8 @@ Returns the stats object." (ert--insert-infos result) (insert " ") (let ((print-escape-newlines t) - (print-level 5) - (print-length 10)) + (print-level ert-batch-print-level) + (print-length ert-batch-print-length)) (ert--pp-with-indentation-and-newline (ert-test-result-with-condition-condition result))) (goto-char (1- (point-max))) @@ -1506,6 +1527,164 @@ the tests)." (backtrace)) (kill-emacs 2)))) +(defun ert-write-junit-test-report (stats) + "Write a JUnit test report, generated from STATS." + ;; https://www.ibm.com/docs/en/developer-for-zos/14.1.0?topic=formats-junit-xml-format + ;; https://llg.cubic.org/docs/junit/ + (unless (zerop (length (ert--stats-tests stats))) + (when-let ((test-file + (symbol-file + (ert-test-name (aref (ert--stats-tests stats) 0)) 'ert--test)) + (test-report (file-name-with-extension test-file "xml"))) + (with-temp-file test-report + (insert "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n") + (insert (format "<testsuites name=\"%s\" tests=\"%s\" errors=\"%s\" failures=\"%s\" skipped=\"%s\" time=\"%s\">\n" + (file-name-nondirectory test-report) + (ert-stats-total stats) + (if (ert--stats-aborted-p stats) 1 0) + (ert-stats-completed-unexpected stats) + (ert-stats-skipped stats) + (float-time + (time-subtract + (ert--stats-end-time stats) + (ert--stats-start-time stats))))) + (insert (format " <testsuite id=\"0\" name=\"%s\" tests=\"%s\" errors=\"%s\" failures=\"%s\" skipped=\"%s\" time=\"%s\" timestamp=\"%s\">\n" + (file-name-nondirectory test-report) + (ert-stats-total stats) + (if (ert--stats-aborted-p stats) 1 0) + (ert-stats-completed-unexpected stats) + (ert-stats-skipped stats) + (float-time + (time-subtract + (ert--stats-end-time stats) + (ert--stats-start-time stats))) + (ert--format-time-iso8601 (ert--stats-end-time stats)))) + (insert " <properties>\n" + (format " <property name=\"selector\" value=\"%s\"/>\n" + (ert--stats-selector stats)) + " </properties>\n") + (cl-loop for test across (ert--stats-tests stats) + for result = (ert-test-most-recent-result test) do + (insert (format " <testcase name=\"%s\" status=\"%s\" time=\"%s\"" + (xml-escape-string + (symbol-name (ert-test-name test))) + (ert-string-for-test-result + result + (ert-test-result-expected-p test result)) + (ert-test-result-duration result))) + (if (and (ert-test-result-expected-p test result) + (not (ert-test-aborted-with-non-local-exit-p result)) + (not (ert-test-skipped-p result)) + (zerop (length (ert-test-result-messages result)))) + (insert "/>\n") + (insert ">\n") + (cond + ((ert-test-skipped-p result) + (insert (format " <skipped message=\"%s\" type=\"%s\">\n" + (xml-escape-string + (string-trim + (ert-reason-for-test-result result))) + (ert-string-for-test-result + result + (ert-test-result-expected-p + test result))) + (xml-escape-string + (string-trim + (ert-reason-for-test-result result))) + "\n" + " </skipped>\n")) + ((ert-test-aborted-with-non-local-exit-p result) + (insert (format " <error message=\"%s\" type=\"%s\">\n" + (file-name-nondirectory test-report) + (ert-string-for-test-result + result + (ert-test-result-expected-p + test result))) + (format "Test %s aborted with non-local exit\n" + (xml-escape-string + (symbol-name (ert-test-name test)))) + " </error>\n")) + ((not (ert-test-result-type-p + result (ert-test-expected-result-type test))) + (insert (format " <failure message=\"%s\" type=\"%s\">\n" + (xml-escape-string + (string-trim + (ert-reason-for-test-result result))) + (ert-string-for-test-result + result + (ert-test-result-expected-p + test result))) + (xml-escape-string + (string-trim + (ert-reason-for-test-result result))) + "\n" + " </failure>\n"))) + (unless (zerop (length (ert-test-result-messages result))) + (insert " <system-out>\n" + (xml-escape-string + (ert-test-result-messages result)) + " </system-out>\n")) + (insert " </testcase>\n"))) + (insert " </testsuite>\n") + (insert "</testsuites>\n"))))) + +(defun ert-write-junit-test-summary-report (&rest logfiles) + "Write a JUnit summary test report, generated from LOGFILES." + (let ((report (file-name-with-extension + (getenv "EMACS_TEST_JUNIT_REPORT") "xml")) + (tests 0) (errors 0) (failures 0) (skipped 0) (time 0) (id 0)) + (with-temp-file report + (dolist (logfile logfiles) + (let ((test-report (file-name-with-extension logfile "xml"))) + (if (not (file-readable-p test-report)) + (let ((logfile (file-name-with-extension logfile "log"))) + (insert (format " <testsuite id=\"%s\" name=\"%s\" tests=\"1\" errors=\"1\" failures=\"0\" skipped=\"0\" time=\"0\" timestamp=\"%s\">\n" + id test-report + (ert--format-time-iso8601 (current-time)))) + (insert (format " <testcase name=\"Test report missing %s\" status=\"error\" time=\"0\">\n" + (file-name-nondirectory test-report))) + (insert (format " <error message=\"Test report missing %s\" type=\"error\">\n" + (file-name-nondirectory test-report))) + (when (file-readable-p logfile) + (insert (xml-escape-string + (with-temp-buffer + (insert-file-contents-literally logfile) + (buffer-string))))) + (insert " </error>\n" + " </testcase>\n" + " </testsuite>\n") + (cl-incf errors 1) + (cl-incf id 1)) + + (insert-file-contents-literally test-report) + (when (looking-at-p + (regexp-quote "<?xml version=\"1.0\" encoding=\"utf-8\"?>")) + (delete-region (point) (line-beginning-position 2))) + (when (looking-at + "<testsuites name=\".+\" tests=\"\\(.+\\)\" errors=\"\\(.+\\)\" failures=\"\\(.+\\)\" skipped=\"\\(.+\\)\" time=\"\\(.+\\)\">") + (cl-incf tests (string-to-number (match-string 1))) + (cl-incf errors (string-to-number (match-string 2))) + (cl-incf failures (string-to-number (match-string 3))) + (cl-incf skipped (string-to-number (match-string 4))) + (cl-incf time (string-to-number (match-string 5))) + (delete-region (point) (line-beginning-position 2))) + (when (looking-at " <testsuite id=\"\\(0\\)\"") + (replace-match (number-to-string id) nil nil nil 1) + (cl-incf id 1)) + (goto-char (point-max)) + (beginning-of-line 0) + (when (looking-at-p "</testsuites>") + (delete-region (point) (line-beginning-position 2)))) + + (narrow-to-region (point-max) (point-max)))) + + (insert "</testsuites>\n") + (widen) + (goto-char (point-min)) + (insert "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n") + (insert (format "<testsuites name=\"%s\" tests=\"%s\" errors=\"%s\" failures=\"%s\" skipped=\"%s\" time=\"%s\">\n" + (file-name-nondirectory report) + tests errors failures skipped time))))) (defun ert-summarize-tests-batch-and-exit (&optional high) "Summarize the results of testing. @@ -1521,6 +1700,8 @@ If HIGH is a natural number, the HIGH long lasting tests are summarized." ;; behavior. (setq attempt-stack-overflow-recovery nil attempt-orderly-shutdown-on-fatal-signal nil) + (when (getenv "EMACS_TEST_JUNIT_REPORT") + (apply #'ert-write-junit-test-summary-report command-line-args-left)) (let ((nlogs (length command-line-args-left)) (ntests 0) (nrun 0) (nexpected 0) (nunexpected 0) (nskipped 0) nnotrun logfile notests badtests unexpected skipped tests) @@ -1836,7 +2017,6 @@ Also sets `ert--results-progress-bar-button-begin'." ;; should test it again.) "\n"))) - (defvar ert-test-run-redisplay-interval-secs .1 "How many seconds ERT should wait between redisplays while running tests. @@ -1984,13 +2164,13 @@ otherwise." (ewoc-refresh ert--results-ewoc) (font-lock-default-function enabledp)) -(defun ert--setup-results-buffer (stats listener buffer-name) +(defvar ert--output-buffer-name "*ert*") + +(defun ert--setup-results-buffer (stats listener) "Set up a test results buffer. -STATS is the stats object; LISTENER is the results listener; -BUFFER-NAME, if non-nil, is the buffer name to use." - (unless buffer-name (setq buffer-name "*ert*")) - (let ((buffer (get-buffer-create buffer-name))) +STATS is the stats object; LISTENER is the results listener." + (let ((buffer (get-buffer-create ert--output-buffer-name))) (with-current-buffer buffer (let ((inhibit-read-only t)) (buffer-disable-undo) @@ -2018,22 +2198,14 @@ BUFFER-NAME, if non-nil, is the buffer name to use." (goto-char (1- (point-max))) buffer))))) - (defvar ert--selector-history nil "List of recent test selectors read from terminal.") -;; Should OUTPUT-BUFFER-NAME and MESSAGE-FN really be arguments here? -;; They are needed only for our automated self-tests at the moment. -;; Or should there be some other mechanism? ;;;###autoload -(defun ert-run-tests-interactively (selector - &optional output-buffer-name message-fn) +(defun ert-run-tests-interactively (selector) "Run the tests specified by SELECTOR and display the results in a buffer. -SELECTOR works as described in `ert-select-tests'. -OUTPUT-BUFFER-NAME and MESSAGE-FN should normally be nil; they -are used for automated self-tests and specify which buffer to use -and how to display message." +SELECTOR works as described in `ert-select-tests'." (interactive (list (let ((default (if ert--selector-history ;; Can't use `first' here as this form is @@ -2044,25 +2216,18 @@ and how to display message." (read (completing-read (format-prompt "Run tests" default) obarray #'ert-test-boundp nil nil - 'ert--selector-history default nil))) - nil)) - (unless message-fn (setq message-fn 'message)) - (let ((output-buffer-name output-buffer-name) - buffer - listener - (message-fn message-fn)) + 'ert--selector-history default nil))))) + (let (buffer listener) (setq listener (lambda (event-type &rest event-args) (cl-ecase event-type (run-started (cl-destructuring-bind (stats) event-args - (setq buffer (ert--setup-results-buffer stats - listener - output-buffer-name)) + (setq buffer (ert--setup-results-buffer stats listener)) (pop-to-buffer buffer))) (run-ended (cl-destructuring-bind (stats abortedp) event-args - (funcall message-fn + (message "%sRan %s tests, %s results were as expected%s%s" (if (not abortedp) "" @@ -2416,7 +2581,7 @@ To be used in the ERT results buffer." (interactive nil ert-results-mode) (cl-assert (eql major-mode 'ert-results-mode)) (let ((selector (ert--stats-selector ert--results-stats))) - (ert-run-tests-interactively selector (buffer-name)))) + (ert-run-tests-interactively selector))) (defun ert-results-rerun-test-at-point () "Re-run the test at point. @@ -2665,9 +2830,135 @@ To be used in the ERT results buffer." 'ert--activate-font-lock-keywords) nil) +(defun ert-test-erts-file (file &optional transform) + "Parse FILE as a file containing before/after parts. +TRANSFORM will be called to get from before to after." + (with-temp-buffer + (insert-file-contents file) + (let ((gen-specs (list (cons 'dummy t) + (cons 'code transform)))) + ;; Find the start of a test. + (while (re-search-forward "^=-=\n" nil t) + (setq gen-specs (ert-test--erts-test gen-specs file)) + ;; Search to the end of the test. + (re-search-forward "^=-=-=\n"))))) + +(defun ert-test--erts-test (gen-specs file) + (let* ((file-buffer (current-buffer)) + (specs (ert--erts-specifications (match-beginning 0))) + (name (cdr (assq 'name specs))) + (start-before (point)) + (end-after (if (re-search-forward "^=-=-=\n" nil t) + (match-beginning 0) + (point-max))) + (skip (cdr (assq 'skip specs))) + end-before start-after + after after-point) + (unless name + (error "No name for test case")) + (if (and skip + (eval (car (read-from-string skip)))) + ;; Skipping this test. + () + ;; Do the test. + (goto-char end-after) + ;; We have a separate after section. + (if (re-search-backward "^=-=\n" start-before t) + (setq end-before (match-beginning 0) + start-after (match-end 0)) + (setq end-before end-after + start-after start-before)) + ;; Update persistent specs. + (when-let ((point-char (assq 'point-char specs))) + (setq gen-specs + (map-insert gen-specs 'point-char (cdr point-char)))) + (when-let ((code (cdr (assq 'code specs)))) + (setq gen-specs + (map-insert gen-specs 'code (car (read-from-string code))))) + ;; Get the "after" strings. + (with-temp-buffer + (insert-buffer-substring file-buffer start-after end-after) + (ert--erts-unquote) + ;; Remove the newline at the end of the buffer. + (when-let ((no-newline (cdr (assq 'no-after-newline specs)))) + (goto-char (point-min)) + (when (re-search-forward "\n\\'" nil t) + (delete-region (match-beginning 0) (match-end 0)))) + ;; Get the expected "after" point. + (when-let ((point-char (cdr (assq 'point-char gen-specs)))) + (goto-char (point-min)) + (when (search-forward point-char nil t) + (delete-region (match-beginning 0) (match-end 0)) + (setq after-point (point)))) + (setq after (buffer-string))) + ;; Do the test. + (with-temp-buffer + (insert-buffer-substring file-buffer start-before end-before) + (ert--erts-unquote) + ;; Remove the newline at the end of the buffer. + (when-let ((no-newline (cdr (assq 'no-before-newline specs)))) + (goto-char (point-min)) + (when (re-search-forward "\n\\'" nil t) + (delete-region (match-beginning 0) (match-end 0)))) + (goto-char (point-min)) + ;; Place point in the specified place. + (when-let ((point-char (cdr (assq 'point-char gen-specs)))) + (when (search-forward point-char nil t) + (delete-region (match-beginning 0) (match-end 0)))) + (let ((code (cdr (assq 'code gen-specs)))) + (unless code + (error "No code to run the transform")) + (funcall code)) + (unless (equal (buffer-string) after) + (ert-fail (list (format "Mismatch in test \"%s\", file %s" + name file) + (buffer-string) + after))) + (when (and after-point + (not (= after-point (point)))) + (ert-fail (list (format "Point wrong in test \"%s\", expected point %d, actual %d, file %s" + name + after-point (point) + file) + (buffer-string))))))) + ;; Return the new value of the general specifications. + gen-specs) + +(defun ert--erts-unquote () + (goto-char (point-min)) + (while (re-search-forward "^\\=-=\\(-=\\)$" nil t) + (delete-region (match-beginning 0) (1+ (match-beginning 0))))) + +(defun ert--erts-specifications (end) + "Find specifications before point (back to the previous test)." + (save-excursion + (goto-char end) + (goto-char + (if (re-search-backward "^=-=-=\n" nil t) + (match-end 0) + (point-min))) + (let ((specs nil)) + (while (< (point) end) + (if (looking-at "\\([^ \n\t:]+\\):\\([ \t]+\\)?\\(.*\\)") + (let ((name (intern (downcase (match-string 1)))) + (value (match-string 3))) + (forward-line 1) + (while (looking-at "[ \t]+\\(.*\\)") + (setq value (concat value (match-string 1))) + (forward-line 1)) + (push (cons name (substring-no-properties value)) specs)) + (forward-line 1))) + (nreverse specs)))) + (defvar ert-unload-hook ()) (add-hook 'ert-unload-hook #'ert--unload-function) +;;; Obsolete + +(define-obsolete-function-alias 'ert-equal-including-properties + #'equal-including-properties "29.1") +(put 'ert-equal-including-properties 'ert-explainer + 'ert--explain-equal-including-properties) (provide 'ert) diff --git a/lisp/emacs-lisp/generator.el b/lisp/emacs-lisp/generator.el index 2075ac472d1..ac1412704b0 100644 --- a/lisp/emacs-lisp/generator.el +++ b/lisp/emacs-lisp/generator.el @@ -143,8 +143,7 @@ the CPS state machinery." (setf ,static-var ,dynamic-var))))) (defmacro cps--with-dynamic-binding (dynamic-var static-var &rest body) - "Evaluate BODY such that generated atomic evaluations run with -DYNAMIC-VAR bound to STATIC-VAR." + "Run BODY's atomic evaluations run with DYNAMIC-VAR bound to STATIC-VAR." (declare (indent 2)) `(cps--with-value-wrapper (cps--make-dynamic-binding-wrapper ,dynamic-var ,static-var) @@ -291,22 +290,28 @@ DYNAMIC-VAR bound to STATIC-VAR." (cps--transform-1 `(progn ,@rest) next-state))) - ;; Process `let' in a helper function that transforms it into a - ;; let* with temporaries. + (`(,(or 'let 'let*) () . ,body) + (cps--transform-1 `(progn ,@body) next-state)) + + ;; Transform multi-variable `let' into `let*': + ;; (let ((v1 e1) ... (vN eN)) BODY) + ;; -> (let* ((t1 e1) ... (tN-1 eN-1) (vN eN) (v1 t1) (vN-1 tN-1)) BODY) (`(let ,bindings . ,body) (let* ((bindings (cl-loop for binding in bindings collect (if (symbolp binding) (list binding nil) binding))) - (temps (cl-loop for (var _value-form) in bindings + (butlast-bindings (butlast bindings)) + (temps (cl-loop for (var _value-form) in butlast-bindings collect (cps--add-binding var)))) (cps--transform-1 `(let* ,(append - (cl-loop for (_var value-form) in bindings + (cl-loop for (_var value-form) in butlast-bindings for temp in temps collect (list temp value-form)) - (cl-loop for (var _binding) in bindings + (last bindings) + (cl-loop for (var _binding) in butlast-bindings for temp in temps collect (list var temp))) ,@body) @@ -315,9 +320,6 @@ DYNAMIC-VAR bound to STATIC-VAR." ;; Process `let*' binding: process one binding at a time. Flatten ;; lexical bindings. - (`(let* () . ,body) - (cps--transform-1 `(progn ,@body) next-state)) - (`(let* (,binding . ,more-bindings) . ,body) (let* ((var (if (symbolp binding) binding (car binding))) (value-form (car (cdr-safe binding))) @@ -642,12 +644,11 @@ modified copy." (iter-close iterator))))) iterator)))) -(defun iter-yield (value) +(defun iter-yield (_value) "When used inside a generator, yield control to caller. The caller of `iter-next' receives VALUE, and the next call to `iter-next' resumes execution with the form immediately following this `iter-yield' call." - (identity value) (error "`iter-yield' used outside a generator")) (defmacro iter-yield-from (value) diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index d6272a52469..ebcc63cc2a5 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -74,7 +74,7 @@ ;; (defvar gv--macro-environment nil ;; "Macro expanders for generalized variables.") -(define-error 'gv-invalid-place "%S is not a valid place expression") +(define-error 'gv-invalid-place "Invalid place expression") ;;;###autoload (defun gv-get (place do) diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index bb00a97f8e3..416d64558d9 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -29,6 +29,7 @@ ;;; Code: (eval-when-compile (require 'cl-lib)) +(eval-when-compile (require 'subr-x)) (defvar font-lock-comment-face) (defvar font-lock-doc-face) @@ -590,6 +591,8 @@ containing STARTPOS." (defun lisp-string-after-doc-keyword-p (listbeg startpos) "Return non-nil if `:documentation' symbol ends at STARTPOS inside a list. +`:doc' can also be used. + LISTBEG is the position of the start of the innermost list containing STARTPOS." (and listbeg ; We are inside a Lisp form. @@ -597,7 +600,7 @@ containing STARTPOS." (goto-char startpos) (ignore-errors (progn (backward-sexp 1) - (looking-at ":documentation\\_>")))))) + (looking-at ":documentation\\_>\\|:doc\\_>")))))) (defun lisp-font-lock-syntactic-face-function (state) "Return syntactic face function for the position represented by STATE. @@ -1106,6 +1109,53 @@ is the buffer position of the start of the containing expression." (t normal-indent)))))) +(defun lisp--local-defform-body-p (state) + "Return non-nil when at local definition body according to STATE. +STATE is the `parse-partial-sexp' state for current position." + (when-let ((start-of-innermost-containing-list (nth 1 state))) + (let* ((parents (nth 9 state)) + (first-cons-after (cdr parents)) + (second-cons-after (cdr first-cons-after)) + first-order-parent second-order-parent) + (while second-cons-after + (when (= start-of-innermost-containing-list + (car second-cons-after)) + (setq second-order-parent (pop parents) + first-order-parent (pop parents) + ;; Leave the loop. + second-cons-after nil)) + (pop second-cons-after) + (pop parents)) + (when second-order-parent + (let (local-definitions-starting-point) + (and (save-excursion + (goto-char (1+ second-order-parent)) + (when-let ((head (ignore-errors + ;; FIXME: This does not distinguish + ;; between reading nil and a read error. + ;; We don't care but still, better fix this. + (read (current-buffer))))) + (when (memq head '( cl-flet cl-labels cl-macrolet cl-flet* + cl-symbol-macrolet)) + ;; In what follows, we rely on (point) returning non-nil. + (setq local-definitions-starting-point + (progn + (parse-partial-sexp + (point) first-order-parent nil + ;; From docstring of `parse-partial-sexp': + ;; Fourth arg non-nil means stop + ;; when we come to any character + ;; that starts a sexp. + t) + (point)))))) + (save-excursion + (when (ignore-errors + ;; We rely on `backward-up-list' working + ;; even when sexp is incomplete “to the right”. + (backward-up-list 2) + t) + (= local-definitions-starting-point (point)))))))))) + (defun lisp-indent-function (indent-point state) "This function is the normal value of the variable `lisp-indent-function'. The function `calculate-lisp-indent' calls this to determine @@ -1139,16 +1189,19 @@ Lisp function does not specify a special indentation." (if (and (elt state 2) (not (looking-at "\\sw\\|\\s_"))) ;; car of form doesn't seem to be a symbol - (progn + (if (lisp--local-defform-body-p state) + ;; We nevertheless check whether we are in flet-like form + ;; as we presume local function names could be non-symbols. + (lisp-indent-defform state indent-point) (if (not (> (save-excursion (forward-line 1) (point)) calculate-lisp-indent-last-sexp)) - (progn (goto-char calculate-lisp-indent-last-sexp) - (beginning-of-line) - (parse-partial-sexp (point) - calculate-lisp-indent-last-sexp 0 t))) - ;; Indent under the list or under the first sexp on the same - ;; line as calculate-lisp-indent-last-sexp. Note that first - ;; thing on that line has to be complete sexp since we are + (progn (goto-char calculate-lisp-indent-last-sexp) + (beginning-of-line) + (parse-partial-sexp (point) + calculate-lisp-indent-last-sexp 0 t))) + ;; Indent under the list or under the first sexp on the same + ;; line as calculate-lisp-indent-last-sexp. Note that first + ;; thing on that line has to be complete sexp since we are ;; inside the innermost containing sexp. (backward-prefix-chars) (current-column)) @@ -1159,15 +1212,14 @@ Lisp function does not specify a special indentation." 'lisp-indent-function) (get (intern-soft function) 'lisp-indent-hook))) (cond ((or (eq method 'defun) - (and (null method) - (> (length function) 3) - (string-match "\\`def" function))) + ;; Check whether we are in flet-like form. + (lisp--local-defform-body-p state)) (lisp-indent-defform state indent-point)) ((integerp method) (lisp-indent-specform method state indent-point normal-indent)) (method - (funcall method indent-point state))))))) + (funcall method indent-point state))))))) (defcustom lisp-body-indent 2 "Number of columns to indent the second line of a `(def...)' form." @@ -1235,6 +1287,13 @@ Lisp function does not specify a special indentation." (put 'autoload 'lisp-indent-function 'defun) ;Elisp (put 'progn 'lisp-indent-function 0) +(put 'defvar 'lisp-indent-function 'defun) +(put 'defalias 'lisp-indent-function 'defun) +(put 'defvaralias 'lisp-indent-function 'defun) +(put 'defconst 'lisp-indent-function 'defun) +(put 'define-category 'lisp-indent-function 'defun) +(put 'define-charset-internal 'lisp-indent-function 'defun) +(put 'define-fringe-bitmap 'lisp-indent-function 'defun) (put 'prog1 'lisp-indent-function 1) (put 'save-excursion 'lisp-indent-function 0) ;Elisp (put 'save-restriction 'lisp-indent-function 0) ;Elisp @@ -1249,6 +1308,7 @@ Lisp function does not specify a special indentation." (put 'handler-bind 'lisp-indent-function 1) ;CL (put 'unwind-protect 'lisp-indent-function 1) (put 'with-output-to-temp-buffer 'lisp-indent-function 1) +(put 'closure 'lisp-indent-function 2) (defun indent-sexp (&optional endpos) "Indent each line of the list starting just after point. diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 1e4fdd126cb..a20c424e2bd 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -136,9 +136,12 @@ Other uses risk returning non-nil value that point to the wrong file." (defvar macroexp--warned (make-hash-table :test #'equal :weakness 'key)) (defun macroexp--warn-wrap (msg form category) - (let ((when-compiled (lambda () - (when (byte-compile-warning-enabled-p category) - (byte-compile-warn "%s" msg))))) + (let ((when-compiled + (lambda () + (when (if (consp category) + (apply #'byte-compile-warning-enabled-p category) + (byte-compile-warning-enabled-p category)) + (byte-compile-warn "%s" msg))))) `(progn (macroexp--funcall-if-compiled ',when-compiled) ,form))) @@ -220,7 +223,7 @@ is executed without being compiled first." fun obsolete (if (symbolp (symbol-function fun)) "alias" "macro")) - new-form 'obsolete)) + new-form (list 'obsolete fun))) new-form))) (defun macroexp--unfold-lambda (form &optional name) diff --git a/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el index b95f11eab64..2f2f96ca0da 100644 --- a/lisp/emacs-lisp/map-ynp.el +++ b/lisp/emacs-lisp/map-ynp.el @@ -215,12 +215,12 @@ The function's value is the number of actions taken." (action (or (nth 2 help) "act on"))) (concat (format-message - "\ -Type SPC or `y' to %s the current %s; -DEL or `n' to skip the current %s; -RET or `q' to skip the current and all remaining %s; -C-g to quit (cancel the whole command); -! to %s all remaining %s;\n" + (substitute-command-keys "\ +Type \\`SPC' or \\`y' to %s the current %s; +\\`DEL' or \\`n' to skip the current %s; +\\`RET' or \\`q' to skip the current and all remaining %s; +\\`C-g' to quit (cancel the whole command); +\\`!' to %s all remaining %s;\n") action object object objects action objects) (mapconcat (lambda (elt) (format "%s to %s;\n" diff --git a/lisp/emacs-lisp/memory-report.el b/lisp/emacs-lisp/memory-report.el index 3166d33e029..450cdaa7a84 100644 --- a/lisp/emacs-lisp/memory-report.el +++ b/lisp/emacs-lisp/memory-report.el @@ -31,7 +31,7 @@ (require 'subr-x) (require 'cl-lib) -(defvar memory-report--type-size (make-hash-table)) +(defvar memory-report--type-size nil) ;;;###autoload (defun memory-report () @@ -84,6 +84,7 @@ by counted more than once." (gethash 'object memory-report--type-size))) (defun memory-report--set-size (elems) + (setq memory-report--type-size (make-hash-table)) (setf (gethash 'string memory-report--type-size) (cadr (assq 'strings elems))) (setf (gethash 'cons memory-report--type-size) @@ -282,7 +283,7 @@ by counted more than once." buffers) do (insert (memory-report--format size) " " - (button-buttonize + (buttonize (buffer-name buffer) #'memory-report--buffer-details buffer) "\n")) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 2c37e19980d..de4cebccca3 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -714,6 +714,7 @@ REQUIREMENTS is a list of dependencies on other packages. where OTHER-VERSION is a string. EXTRA-PROPERTIES is currently unused." + (declare (indent defun)) ;; FIXME: Placeholder! Should we keep it? (error "Don't call me!")) @@ -757,47 +758,47 @@ PKG-DESC is a `package-desc' object." (format "%s-autoloads" (package-desc-name pkg-desc)) (package-desc-dir pkg-desc))) -(defun package--activate-autoloads-and-load-path (pkg-desc) - "Load the autoloads file and add package dir to `load-path'. -PKG-DESC is a `package-desc' object." - (let* ((old-lp load-path) - (pkg-dir (package-desc-dir pkg-desc)) - (pkg-dir-dir (file-name-as-directory pkg-dir))) - (with-demoted-errors "Error loading autoloads: %s" - (load (package--autoloads-file-name pkg-desc) nil t)) - (when (and (eq old-lp load-path) - (not (or (member pkg-dir load-path) - (member pkg-dir-dir load-path)))) - ;; Old packages don't add themselves to the `load-path', so we have to - ;; do it ourselves. - (push pkg-dir load-path)))) - (defvar Info-directory-list) (declare-function info-initialize "info" ()) (defvar package--quickstart-pkgs t "If set to a list, we're computing the set of pkgs to activate.") -(defun package--load-files-for-activation (pkg-desc reload) - "Load files for activating a package given by PKG-DESC. -Load the autoloads file, and ensure `load-path' is setup. If -RELOAD is non-nil, also load all files in the package that -correspond to previously loaded files." - (let* ((loaded-files-list - (when reload - (package--list-loaded-files (package-desc-dir pkg-desc))))) - ;; Add to load path, add autoloads, and activate the package. - (package--activate-autoloads-and-load-path pkg-desc) - ;; Call `load' on all files in `package-desc-dir' already present in - ;; `load-history'. This is done so that macros in these files are updated - ;; to their new definitions. If another package is being installed which - ;; depends on this new definition, not doing this update would cause - ;; compilation errors and break the installation. - (with-demoted-errors "Error in package--load-files-for-activation: %s" - (mapc (lambda (feature) (load feature nil t)) - ;; Skip autoloads file since we already evaluated it above. - (remove (file-truename (package--autoloads-file-name pkg-desc)) - loaded-files-list))))) +(defsubst package--library-stem (file) + (catch 'done + (let (result) + (dolist (suffix (get-load-suffixes) file) + (setq result (string-trim file nil suffix)) + (unless (equal file result) + (throw 'done result)))))) + +(defun package--reload-previously-loaded (pkg-desc) + "Force reimportation of files in PKG-DESC already present in `load-history'. +New editions of files contain macro definitions and +redefinitions, the overlooking of which would cause +byte-compilation of the new package to fail." + (with-demoted-errors "Error in package--load-files-for-activation: %s" + (let* (result + (dir (package-desc-dir pkg-desc)) + (load-path-sans-dir + (cl-remove-if (apply-partially #'string= dir) + (or (bound-and-true-p find-function-source-path) + load-path))) + (files (directory-files-recursively dir "\\`[^\\.].*\\.el\\'")) + (history (mapcar #'file-truename + (cl-remove-if-not #'stringp + (mapcar #'car load-history))))) + (dolist (file files) + (when-let ((library (package--library-stem + (file-relative-name file dir))) + (canonical (locate-library library nil load-path-sans-dir)) + (found (member (file-truename canonical) history)) + (recent-index (length found))) + (unless (equal (file-name-base library) + (format "%s-autoloads" (package-desc-name pkg-desc))) + (push (cons (expand-file-name library dir) recent-index) result)))) + (mapc (lambda (c) (load (car c) nil t)) + (sort result (lambda (x y) (< (cdr x) (cdr y)))))))) (defun package-activate-1 (pkg-desc &optional reload deps) "Activate package given by PKG-DESC, even if it was already active. @@ -824,7 +825,11 @@ correspond to previously loaded files (those returned by (if (listp package--quickstart-pkgs) ;; We're only collecting the set of packages to activate! (push pkg-desc package--quickstart-pkgs) - (package--load-files-for-activation pkg-desc reload)) + (when reload + (package--reload-previously-loaded pkg-desc)) + (with-demoted-errors "Error loading autoloads: %s" + (load (package--autoloads-file-name pkg-desc) nil t)) + (add-to-list 'load-path (directory-file-name pkg-dir))) ;; Add info node. (when (file-exists-p (expand-file-name "dir" pkg-dir)) ;; FIXME: not the friendliest, but simple. @@ -835,48 +840,6 @@ correspond to previously loaded files (those returned by ;; Don't return nil. t))) -(defun package--files-load-history () - (delq nil - (mapcar (lambda (x) - (let ((f (car x))) - (and (stringp f) - (file-name-sans-extension (file-truename f))))) - load-history))) - -(defun package--list-of-conflicts (dir history) - (require 'find-func) - (declare-function find-library-name "find-func" (library)) - (delq - nil - (mapcar - (lambda (x) (let* ((file (file-relative-name x dir)) - ;; Previously loaded file, if any. - (previous - (ignore-error file-error ;"Can't find library" - (file-name-sans-extension - (file-truename (find-library-name file))))) - (pos (when previous (member previous history)))) - ;; Return (RELATIVE-FILENAME . HISTORY-POSITION) - (when pos - (cons (file-name-sans-extension file) (length pos))))) - (directory-files-recursively dir "\\`[^\\.].*\\.el\\'")))) - -(defun package--list-loaded-files (dir) - "Recursively list all files in DIR which correspond to loaded features. -Returns the `file-name-sans-extension' of each file, relative to -DIR, sorted by most recently loaded last." - (let* ((history (package--files-load-history)) - (dir (file-truename dir)) - ;; List all files that have already been loaded. - (list-of-conflicts (package--list-of-conflicts dir history))) - ;; Turn the list of (FILENAME . POS) back into a list of features. Files in - ;; subdirectories are returned relative to DIR (so not actually features). - (let ((default-directory (file-name-as-directory dir))) - (mapcar (lambda (x) (file-truename (car x))) - (sort list-of-conflicts - ;; Sort the files by ascending HISTORY-POSITION. - (lambda (x y) (< (cdr x) (cdr y)))))))) - ;;;; `package-activate' (defun package--get-activatable-pkg (pkg-name) @@ -995,7 +958,7 @@ untar into a directory named DIR; otherwise, signal an error." (package--native-compile-async new-desc)) ;; After compilation, load again any files loaded by ;; `activate-1', so that we use the byte-compiled definitions. - (package--load-files-for-activation new-desc :reload))) + (package--reload-previously-loaded new-desc))) pkg-dir)) (defun package-generate-description-file (pkg-desc pkg-file) @@ -1218,13 +1181,17 @@ The return result is a `package-desc'." info) (while files (with-temp-buffer - (insert-file-contents (pop files)) - ;; When we find the file with the data, - (when (setq info (ignore-errors (package-buffer-info))) - ;; stop looping, - (setq files nil) - ;; set the 'dir kind, - (setf (package-desc-kind info) 'dir)))) + (let ((file (pop files))) + ;; The file may be a link to a nonexistent file; e.g., a + ;; lock file. + (when (file-exists-p file) + (insert-file-contents file) + ;; When we find the file with the data, + (when (setq info (ignore-errors (package-buffer-info))) + ;; stop looping, + (setq files nil) + ;; set the 'dir kind, + (setf (package-desc-kind info) 'dir)))))) (unless info (error "No .el files with package headers in `%s'" default-directory)) ;; and return the info. @@ -2488,6 +2455,15 @@ The description is read from the installed package files." (format "%s.el" (package-desc-name desc)) srcdir)) ""))) +(defun package--describe-add-library-links () + "Add links to library names in package description." + (while (re-search-forward "\\<\\([-[:alnum:]]+\\.el\\)\\>" nil t) + (if (locate-library (match-string 1)) + (make-text-button (match-beginning 1) (match-end 1) + 'xref (match-string-no-properties 1) + 'help-echo "Read this file's commentary" + :type 'package--finder-xref)))) + (defun describe-package-1 (pkg) "Insert the package description for PKG. Helper function for `describe-package'." @@ -2714,6 +2690,9 @@ Helper function for `describe-package'." t) (insert (or readme-string "This package does not provide a description."))))) + ;; Make library descriptions into links. + (goto-char start-of-description) + (package--describe-add-library-links) ;; Make URLs in the description into links. (goto-char start-of-description) (browse-url-add-buttons)))) @@ -2759,6 +2738,15 @@ function is a convenience wrapper used by `describe-package-1'." (apply #'insert-text-button button-text 'face button-face 'follow-link t properties))) +(defun package--finder-goto-xref (button) + "Jump to a Lisp file for the BUTTON at point." + (let* ((file (button-get button 'xref)) + (lib (locate-library file))) + (if lib (finder-commentary lib) + (message "Unable to locate `%s'" file)))) + +(define-button-type 'package--finder-xref 'action #'package--finder-goto-xref) + (defun package--print-email-button (recipient) "Insert a button whose action will send an email to RECIPIENT. NAME should have the form (FULLNAME . EMAIL) where FULLNAME is @@ -2780,35 +2768,33 @@ either a full name or nil, and EMAIL is a valid email address." ;;;; Package menu mode. -(defvar package-menu-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map tabulated-list-mode-map) - (define-key map "\C-m" 'package-menu-describe-package) - (define-key map "u" 'package-menu-mark-unmark) - (define-key map "\177" 'package-menu-backup-unmark) - (define-key map "d" 'package-menu-mark-delete) - (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 "~" 'package-menu-mark-obsolete-for-deletion) - (define-key map "w" 'package-browse-url) - (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 "/ d") 'package-menu-filter-by-description) - (define-key map (kbd "/ k") 'package-menu-filter-by-keyword) - (define-key map (kbd "/ N") 'package-menu-filter-by-name-or-description) - (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) - (define-key map (kbd "/ u") 'package-menu-filter-upgradable) - map) - "Local keymap for `package-menu-mode' buffers.") +(defvar-keymap package-menu-mode-map + :doc "Local keymap for `package-menu-mode' buffers." + :parent tabulated-list-mode-map + "C-m" #'package-menu-describe-package + "u" #'package-menu-mark-unmark + "DEL" #'package-menu-backup-unmark + "d" #'package-menu-mark-delete + "i" #'package-menu-mark-install + "U" #'package-menu-mark-upgrades + "r" #'revert-buffer + "~" #'package-menu-mark-obsolete-for-deletion + "w" #'package-browse-url + "x" #'package-menu-execute + "h" #'package-menu-quick-help + "H" #'package-menu-hide-package + "?" #'package-menu-describe-package + "(" #'package-menu-toggle-hiding + "/ /" #'package-menu-clear-filter + "/ a" #'package-menu-filter-by-archive + "/ d" #'package-menu-filter-by-description + "/ k" #'package-menu-filter-by-keyword + "/ N" #'package-menu-filter-by-name-or-description + "/ n" #'package-menu-filter-by-name + "/ s" #'package-menu-filter-by-status + "/ v" #'package-menu-filter-by-version + "/ m" #'package-menu-filter-marked + "/ u" #'package-menu-filter-upgradable) (easy-menu-define package-menu-mode-menu package-menu-mode-map "Menu for `package-menu-mode'." @@ -4195,6 +4181,7 @@ activations need to be changed, such as when `package-load-list' is modified." (replace-match (if (match-end 1) "" pfile) t t))) (unless (bolp) (insert "\n")) (insert ")\n"))) + (pp `(defvar package-activated-list) (current-buffer)) (pp `(setq package-activated-list (append ',(mapcar #'package-desc-name package--quickstart-pkgs) package-activated-list)) @@ -4212,6 +4199,7 @@ activations need to be changed, such as when `package-load-list' is modified." ;; Local\sVariables: ;; version-control: never ;; no-update-autoloads: t +;; byte-compile-warnings: (not make-local) ;; End: ")) ;; FIXME: Do it asynchronously in an Emacs subprocess, and diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el index 0bf774dffd8..8464b5a5198 100644 --- a/lisp/emacs-lisp/pp.el +++ b/lisp/emacs-lisp/pp.el @@ -33,22 +33,43 @@ (defcustom pp-escape-newlines t "Value of `print-escape-newlines' used by pp-* functions." + :type 'boolean) + +(defcustom pp-max-width t + "Max width to use when formatting. +If nil, there's no max width. If t, use the window width. +Otherwise this should be a number." + :type '(choice (const :tag "none" nil) + (const :tag "window width" t) + number) + :version "29.1") + +(defcustom pp-use-max-width nil + "If non-nil, `pp'-related functions will try to fold lines. +The target width is given by the `pp-max-width' variable." :type 'boolean - :group 'pp) + :version "29.1") + +(defvar pp--inhibit-function-formatting nil) ;;;###autoload (defun pp-to-string (object) "Return a string containing the pretty-printed representation of OBJECT. OBJECT can be any Lisp object. Quoting characters are used as needed to make output that `read' can handle, whenever this is possible." - (with-temp-buffer - (lisp-mode-variables nil) - (set-syntax-table emacs-lisp-mode-syntax-table) - (let ((print-escape-newlines pp-escape-newlines) - (print-quoted t)) - (prin1 object (current-buffer))) - (pp-buffer) - (buffer-string))) + (if pp-use-max-width + (let ((pp--inhibit-function-formatting t)) + (with-temp-buffer + (pp-emacs-lisp-code object) + (buffer-string))) + (with-temp-buffer + (lisp-mode-variables nil) + (set-syntax-table emacs-lisp-mode-syntax-table) + (let ((print-escape-newlines pp-escape-newlines) + (print-quoted t)) + (prin1 object (current-buffer))) + (pp-buffer) + (buffer-string)))) ;;;###autoload (defun pp-buffer () @@ -56,7 +77,6 @@ to make output that `read' can handle, whenever this is possible." (interactive) (goto-char (point-min)) (while (not (eobp)) - ;; (message "%06d" (- (point-max) (point))) (cond ((ignore-errors (down-list 1) t) (save-excursion @@ -82,11 +102,21 @@ to make output that `read' can handle, whenever this is possible." "Output the pretty-printed representation of OBJECT, any Lisp object. Quoting characters are printed as needed to make output that `read' can handle, whenever this is possible. + +This function does not apply special formatting rules for Emacs +Lisp code. See `pp-emacs-lisp-code' instead. + +By default, this function won't limit the line length of lists +and vectors. Bind `pp-use-max-width' to a non-nil value to do so. + Output stream is STREAM, or value of `standard-output' (which see)." (princ (pp-to-string object) (or stream standard-output))) -(defun pp-display-expression (expression out-buffer-name) +;;;###autoload +(defun pp-display-expression (expression out-buffer-name &optional lisp) "Prettify and display EXPRESSION in an appropriate way, depending on length. +If LISP, format with `pp-emacs-lisp-code'; use `pp' otherwise. + If a temporary buffer is needed for representation, it will be named after OUT-BUFFER-NAME." (let* ((old-show-function temp-buffer-show-function) @@ -110,11 +140,13 @@ after OUT-BUFFER-NAME." (select-window window) (run-hooks 'temp-buffer-show-hook)) (when (window-live-p old-selected) - (select-window old-selected)) - (message "See buffer %s." out-buffer-name))) + (select-window old-selected)))) (message "%s" (buffer-substring (point-min) (point)))))))) (with-output-to-temp-buffer out-buffer-name - (pp expression) + (if lisp + (with-current-buffer standard-output + (pp-emacs-lisp-code expression)) + (pp expression)) (with-current-buffer standard-output (emacs-lisp-mode) (setq buffer-read-only nil) @@ -179,6 +211,188 @@ Ignores leading comment characters." (insert (pp-to-string (macroexpand-1 (pp-last-sexp)))) (pp-macroexpand-expression (pp-last-sexp)))) +;;;###autoload +(defun pp-emacs-lisp-code (sexp) + "Insert SEXP into the current buffer, formatted as Emacs Lisp code. +Use the `pp-max-width' variable to control the desired line length." + (require 'edebug) + (let ((obuf (current-buffer))) + (with-temp-buffer + (emacs-lisp-mode) + (pp--insert-lisp sexp) + (insert "\n") + (goto-char (point-min)) + (indent-sexp) + (while (re-search-forward " +$" nil t) + (replace-match "")) + (insert-into-buffer obuf)))) + +(defun pp--insert-lisp (sexp) + (cl-case (type-of sexp) + (vector (pp--format-vector sexp)) + (cons (cond + ((consp (cdr sexp)) + (if (and (length= sexp 2) + (eq (car sexp) 'quote)) + (cond + ((symbolp (cadr sexp)) + (let ((print-quoted t)) + (prin1 sexp (current-buffer)))) + ((consp (cadr sexp)) + (insert "'") + (pp--format-list (cadr sexp) + (set-marker (make-marker) (1- (point)))))) + (pp--format-list sexp))) + (t + (princ sexp (current-buffer))))) + ;; Print some of the smaller integers as characters, perhaps? + (integer + (if (<= ?0 sexp ?z) + (let ((print-integers-as-characters t)) + (princ sexp (current-buffer))) + (princ sexp (current-buffer)))) + (string + (let ((print-escape-newlines t)) + (prin1 sexp (current-buffer)))) + (otherwise (princ sexp (current-buffer))))) + +(defun pp--format-vector (sexp) + (insert "[") + (cl-loop for i from 0 + for element across sexp + do (pp--insert (and (> i 0) " ") element)) + (insert "]")) + +(defun pp--format-list (sexp &optional start) + (if (and (symbolp (car sexp)) + (not pp--inhibit-function-formatting) + (not (keywordp (car sexp)))) + (pp--format-function sexp) + (insert "(") + (pp--insert start (pop sexp)) + (while sexp + (pp--insert " " (pop sexp))) + (insert ")"))) + +(defun pp--format-function (sexp) + (let* ((sym (car sexp)) + (edebug (get sym 'edebug-form-spec)) + (indent (get sym 'lisp-indent-function)) + (doc (get sym 'doc-string-elt))) + (when (eq indent 'defun) + (setq indent 2)) + ;; We probably want to keep all the elements before the doc string + ;; on a single line. + (when doc + (setq indent (1- doc))) + ;; Special-case closures -- these shouldn't really exist in actual + ;; source code, so there's no indentation information. But make + ;; them output slightly better. + (when (and (not indent) + (eq sym 'closure)) + (setq indent 0)) + (pp--insert "(" sym) + (pop sexp) + ;; Get the first entries on the first line. + (if indent + (pp--format-definition sexp indent edebug) + (let ((prev 0)) + (while sexp + (let ((start (point))) + ;; Don't put sexps on the same line as a multi-line sexp + ;; preceding it. + (pp--insert (if (> prev 1) "\n" " ") + (pop sexp)) + (setq prev (count-lines start (point))))))) + (insert ")"))) + +(defun pp--format-definition (sexp indent edebug) + (while (and (cl-plusp indent) + sexp) + (insert " ") + ;; We don't understand all the edebug specs. + (unless (consp edebug) + (setq edebug nil)) + (if (and (consp (car edebug)) + (eq (caar edebug) '&rest)) + (pp--insert-binding (pop sexp)) + (if (null (car sexp)) + (insert "()") + (pp--insert-lisp (car sexp))) + (pop sexp)) + (pop edebug) + (cl-decf indent)) + (when (stringp (car sexp)) + (insert "\n") + (prin1 (pop sexp) (current-buffer))) + ;; Then insert the rest with line breaks before each form. + (while sexp + (insert "\n") + (if (keywordp (car sexp)) + (progn + (pp--insert-lisp (pop sexp)) + (when sexp + (pp--insert " " (pop sexp)))) + (pp--insert-lisp (pop sexp))))) + +(defun pp--insert-binding (sexp) + (insert "(") + (while sexp + (if (consp (car sexp)) + ;; Newlines after each (...) binding. + (progn + (pp--insert-lisp (car sexp)) + (when (cdr sexp) + (insert "\n"))) + ;; Keep plain symbols on the same line. + (pp--insert " " (car sexp))) + (pop sexp)) + (insert ")")) + +(defun pp--insert (delim &rest things) + (let ((start (if (markerp delim) + (prog1 + delim + (setq delim nil)) + (point-marker)))) + (when delim + (insert delim)) + (dolist (thing things) + (pp--insert-lisp thing)) + ;; We need to indent what we have so far to see if we have to fold. + (pp--indent-buffer) + (when (> (current-column) (pp--max-width)) + (save-excursion + (goto-char start) + (unless (looking-at "[ \t]+$") + (insert "\n")) + (pp--indent-buffer) + (goto-char (point-max)) + ;; If we're still too wide, then go up one step and try to + ;; insert a newline there. + (when (> (current-column) (pp--max-width)) + (condition-case () + (backward-up-list 1) + (:success (when (looking-back " " 2) + (insert "\n"))) + (error nil))))))) + +(defun pp--max-width () + (cond ((numberp pp-max-width) + pp-max-width) + ((null pp-max-width) + most-positive-fixnum) + ((eq pp-max-width t) + (window-width)) + (t + (error "Invalid pp-max-width value: %s" pp-max-width)))) + +(defun pp--indent-buffer () + (goto-char (point-min)) + (while (not (eobp)) + (lisp-indent-line) + (forward-line 1))) + (provide 'pp) ; so (require 'pp) works ;;; pp.el ends here diff --git a/lisp/emacs-lisp/re-builder.el b/lisp/emacs-lisp/re-builder.el index aec438ed994..9be6ac649f3 100644 --- a/lisp/emacs-lisp/re-builder.el +++ b/lisp/emacs-lisp/re-builder.el @@ -274,8 +274,8 @@ Except for Lisp syntax this is the same as `reb-regexp'.") emacs-lisp-mode "RE Builder Lisp" "Major mode for interactively building symbolic Regular Expressions." ;; Pull in packages as needed - (cond ((memq reb-re-syntax '(sregex rx)) ; rx-to-string is autoloaded - (require 'rx))) ; require rx anyway + (when (eq reb-re-syntax 'rx) ; rx-to-string is autoloaded + (require 'rx)) ; require rx anyway (reb-mode-common)) (defvar reb-subexp-mode-map @@ -307,8 +307,8 @@ Except for Lisp syntax this is the same as `reb-regexp'.") (eq 'color (frame-parameter nil 'display-type))) (defsubst reb-lisp-syntax-p () - "Return non-nil if RE Builder uses a Lisp syntax." - (memq reb-re-syntax '(sregex rx))) + "Return non-nil if RE Builder uses `rx' syntax." + (eq reb-re-syntax 'rx)) (defmacro reb-target-binding (symbol) "Return binding for SYMBOL in the RE Builder target buffer." @@ -448,7 +448,8 @@ provided in the Commentary section of this library." (setq reb-subexp-mode t) (reb-update-modestring) (use-local-map reb-subexp-mode-map) - (message "`0'-`9' to display subexpressions `q' to quit subexp mode")) + (message (substitute-command-keys + "\\`0'-\\`9' to display subexpressions \\`q' to quit subexp mode"))) (defun reb-show-subexp (subexp &optional pause) "Visually show limit of subexpression SUBEXP of recent search. @@ -482,11 +483,11 @@ Optional argument SYNTAX must be specified if called non-interactively." (list (intern (completing-read (format-prompt "Select syntax" reb-re-syntax) - '(read string sregex rx) + '(read string rx) nil t nil nil (symbol-name reb-re-syntax) 'reb-change-syntax-hist)))) - (if (memq syntax '(read string sregex rx)) + (if (memq syntax '(read string rx)) (let ((buffer (get-buffer reb-buffer))) (setq reb-re-syntax syntax) (when buffer @@ -605,9 +606,9 @@ optional fourth argument FORCE is non-nil." (defun reb-cook-regexp (re) "Return RE after processing it according to `reb-re-syntax'." - (cond ((memq reb-re-syntax '(sregex rx)) - (rx-to-string (eval (car (read-from-string re))))) - (t re))) + (if (eq reb-re-syntax 'rx) + (rx-to-string (eval (car (read-from-string re)))) + re)) (defun reb-update-regexp () "Update the regexp for the target buffer. diff --git a/lisp/emacs-lisp/shadow.el b/lisp/emacs-lisp/shadow.el index e2a24e9949c..1fbe946a7f9 100644 --- a/lisp/emacs-lisp/shadow.el +++ b/lisp/emacs-lisp/shadow.el @@ -151,9 +151,6 @@ See the documentation for `list-load-path-shadows' for further information." ;; Return the list of shadowings. shadows)) -(define-obsolete-function-alias 'find-emacs-lisp-shadows - 'load-path-shadows-find "23.3") - ;; Return true if neither file exists, or if both exist and have identical ;; contents. (defun load-path-shadows-same-file-or-nonexistent (f1 f2) diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index 17ac3e471c0..b9e000cc05f 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -71,6 +71,7 @@ string, it'll be inserted as is, then the string will be `read', and then evaluated. There can be any number of :example/:result elements." + (declare (indent defun)) `(progn (setq shortdoc--groups (delq (assq ',group shortdoc--groups) shortdoc--groups)) @@ -195,6 +196,13 @@ There can be any number of :example/:result elements." :eval (substring-no-properties (propertize "foobar" 'face 'bold) 0 3)) (try-completion :eval (try-completion "foo" '("foobar" "foozot" "gazonk"))) + "Unicode Strings" + (string-glyph-split + :eval (string-glyph-split "Hello, 👼🏻🧑🏼🤝🧑🏻")) + (string-glyph-compose + :eval (string-glyph-compose "Å")) + (string-glyph-decompose + :eval (string-glyph-decompose "Å")) "Predicates for Strings" (string-equal :eval (string-equal "foo" "foo")) @@ -241,7 +249,14 @@ There can be any number of :example/:result elements." :eval (number-to-string 42)) "Data About Strings" (length - :eval (length "foo")) + :eval (length "foo") + :eval (length "avocado: 🥑")) + (string-width + :eval (string-width "foo") + :eval (string-width "avocado: 🥑")) + (string-pixel-width + :eval (string-pixel-width "foo") + :eval (string-pixel-width "avocado: 🥑")) (string-search :eval (string-search "bar" "foobarzot")) (assoc-string @@ -271,6 +286,9 @@ There can be any number of :example/:result elements." :eval (file-name-base "/tmp/foo.txt")) (file-relative-name :eval (file-relative-name "/tmp/foo" "/tmp")) + (file-name-split + :eval (file-name-split "/tmp/foo") + :eval (file-name-split "foo/bar")) (make-temp-name :eval (make-temp-name "/tmp/foo-")) (file-name-concat @@ -348,6 +366,9 @@ There can be any number of :example/:result elements." (file-newer-than-file-p :no-eval (file-newer-than-file-p "/tmp/foo" "/tmp/bar") :eg-result nil) + (file-has-changed-p + :no-eval (file-has-changed-p "/tmp/foo") + :eg-result t) (file-equal-p :no-eval (file-equal-p "/tmp/foo" "/tmp/bar") :eg-result nil) @@ -1206,6 +1227,39 @@ There can be any number of :example/:result elements." (text-property-search-backward :no-eval (text-property-search-backward 'face nil t))) +(define-short-documentation-group keymaps + "Defining keymaps" + (define-keymap + :no-eval (define-keymap "C-c C-c" #'quit-buffer)) + (defvar-keymap + :no-eval (defvar-keymap my-keymap "C-c C-c" #'quit-buffer)) + "Setting keys" + (keymap-set + :no-eval (keymap-set map "C-c C-c" #'quit-buffer)) + (keymap-local-set + :no-eval (keymap-local-set "C-c C-c" #'quit-buffer)) + (keymap-global-set + :no-eval (keymap-global-set "C-c C-c" #'quit-buffer)) + (keymap-unset + :no-eval (keymap-unset map "C-c C-c")) + (keymap-local-unset + :no-eval (keymap-local-unset "C-c C-c")) + (keymap-global-unset + :no-eval (keymap-global-unset "C-c C-c")) + (keymap-substitute + :no-eval (keymap-substitute map "C-c C-c" "M-a")) + (keymap-set-after + :no-eval (keymap-set-after map "<separator-2>" menu-bar-separator)) + "Predicates" + (keymapp + :eval (keymapp (define-keymap))) + (key-valid-p + :eval (key-valid-p "C-c C-c") + :eval (key-valid-p "C-cC-c")) + "Lookup" + (keymap-lookup + :eval (keymap-lookup (current-global-map) "C-x x g"))) + ;;;###autoload (defun shortdoc-display-group (group &optional function) "Pop to a buffer with short documentation summary for functions in GROUP. @@ -1369,14 +1423,12 @@ Example: (setq slist (cdr slist))) (setcdr slist (cons elem (cdr slist)))))) -(defvar shortdoc-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "n") 'shortdoc-next) - (define-key map (kbd "p") 'shortdoc-previous) - (define-key map (kbd "C-c C-n") 'shortdoc-next-section) - (define-key map (kbd "C-c C-p") 'shortdoc-previous-section) - map) - "Keymap for `shortdoc-mode'.") +(defvar-keymap shortdoc-mode-map + :doc "Keymap for `shortdoc-mode'." + "n" #'shortdoc-next + "p" #'shortdoc-previous + "C-c C-n" #'shortdoc-next-section + "C-c C-p" #'shortdoc-previous-section) (define-derived-mode shortdoc-mode special-mode "shortdoc" "Mode for shortdoc." diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index 788cd0f34bf..b53245b9b5f 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -208,7 +208,9 @@ The variable list SPEC is the same as in `if-let'." (string= string "")) (defsubst string-join (strings &optional separator) - "Join all STRINGS using SEPARATOR." + "Join all STRINGS using SEPARATOR. +Optional argument SEPARATOR must be a string, a vector, or a list of +characters; nil stands for the empty string." (mapconcat #'identity strings separator)) (define-obsolete-function-alias 'string-reverse 'reverse "25.1") @@ -400,6 +402,114 @@ as the new values of the bound variables in the recursive invocation." (cl-labels ((,name ,fargs . ,body)) #',name) . ,aargs))) +(defmacro with-memoization (place &rest code) + "Return the value of CODE and stash it in PLACE. +If PLACE's value is non-nil, then don't bother evaluating CODE +and return the value found in PLACE instead." + (declare (indent 1) (debug (gv-place body))) + (gv-letplace (getter setter) place + `(or ,getter + ,(macroexp-let2 nil val (macroexp-progn code) + `(progn + ,(funcall setter val) + ,val))))) + +;;;###autoload +(defun ensure-empty-lines (&optional lines) + "Ensure that there are LINES number of empty lines before point. +If LINES is nil or omitted, ensure that there is a single empty +line before point. + +If called interactively, LINES is given by the prefix argument. + +If there are more than LINES empty lines before point, the number +of empty lines is reduced to LINES. + +If point is not at the beginning of a line, a newline character +is inserted before adjusting the number of empty lines." + (interactive "p") + (unless (bolp) + (insert "\n")) + (let ((lines (or lines 1)) + (start (save-excursion + (if (re-search-backward "[^\n]" nil t) + (+ (point) 2) + (point-min))))) + (cond + ((> (- (point) start) lines) + (delete-region (point) (- (point) (- (point) start lines)))) + ((< (- (point) start) lines) + (insert (make-string (- lines (- (point) start)) ?\n)))))) + +;;;###autoload +(defun string-pixel-width (string) + "Return the width of STRING in pixels." + (with-temp-buffer + (insert string) + (car (buffer-text-pixel-size nil nil t)))) + +;;;###autoload +(defun string-glyph-split (string) + "Split STRING into a list of strings representing separate glyphs. +This takes into account combining characters and grapheme clusters." + (let ((result nil) + (start 0) + comp) + (while (< start (length string)) + (if (setq comp (find-composition-internal + start + ;; Don't search backward in the string for the + ;; start of the composition. + (min (length string) (1+ start)) + string nil)) + (progn + (push (substring string (car comp) (cadr comp)) result) + (setq start (cadr comp))) + (push (substring string start (1+ start)) result) + (setq start (1+ start)))) + (nreverse result))) + +;;;###autoload +(defun add-display-text-property (start end prop value + &optional object) + "Add display property PROP with VALUE to the text from START to END. +If any text in the region has a non-nil `display' property, those +properties are retained. + +If OBJECT is non-nil, it should be a string or a buffer. If nil, +this defaults to the current buffer." + (let ((sub-start start) + (sub-end 0) + disp) + (while (< sub-end end) + (setq sub-end (next-single-property-change sub-start 'display object + (if (stringp object) + (min (length object) end) + (min end (point-max))))) + (if (not (setq disp (get-text-property sub-start 'display object))) + ;; No old properties in this range. + (put-text-property sub-start sub-end 'display (list prop value)) + ;; We have old properties. + (let ((vector nil)) + ;; Make disp into a list. + (setq disp + (cond + ((vectorp disp) + (setq vector t) + (seq-into disp 'list)) + ((not (consp (car disp))) + (list disp)) + (t + disp))) + ;; Remove any old instances. + (when-let ((old (assoc prop disp))) + (setq disp (delete old disp))) + (setq disp (cons (list prop value) disp)) + (when vector + (setq disp (seq-into disp 'vector))) + ;; Finally update the range. + (put-text-property sub-start sub-end 'display disp))) + (setq sub-start sub-end)))) (provide 'subr-x) diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index 0ae355e5917..075fe836f6b 100644 --- a/lisp/emacs-lisp/tabulated-list.el +++ b/lisp/emacs-lisp/tabulated-list.el @@ -115,16 +115,25 @@ where: This should be either a function, or a list. If a list, each element has the form (ID [DESC1 ... DESCN]), where: + - ID is nil, or a Lisp object uniquely identifying this entry, which is used to keep the cursor on the \"same\" entry when rearranging the list. Comparison is done with `equal'. - Each DESC is a column descriptor, one for each column - specified in `tabulated-list-format'. A descriptor is either - a string, which is printed as-is, or a list (LABEL . PROPS), - which means to use `insert-text-button' to insert a text - button with label LABEL and button properties PROPS. - The string, or button label, must not contain any newline. + specified in `tabulated-list-format'. The descriptor DESC is + one of: + + - A string, which is printed as-is, and must not contain any + newlines. + + - An image descriptor (a list), which is used to insert an + image (see Info node `(elisp) Image Descriptors'). + + - A list (LABEL . PROPS), which means to use + `insert-text-button' to insert a text button with label + LABEL and button properties PROPS. LABEL must not contain + any newlines. If `tabulated-list-entries' is a function, it is called with no arguments and must return a list of the above form.") @@ -547,7 +556,9 @@ Return the column number after insertion." (props (nthcdr 3 format)) (pad-right (or (plist-get props :pad-right) 1)) (right-align (plist-get props :right-align)) - (label (if (stringp col-desc) col-desc (car col-desc))) + (label (cond ((stringp col-desc) col-desc) + ((eq (car col-desc) 'image) " ") + (t (car col-desc)))) (label-width (string-width label)) (help-echo (concat (car format) ": " label)) (opoint (point)) @@ -571,11 +582,15 @@ Return the column number after insertion." 'display `(space :align-to ,(+ x shift)))) (setq width (- width shift)) (setq x (+ x shift)))) - (if (stringp col-desc) - (insert (if (get-text-property 0 'help-echo label) - label - (propertize label 'help-echo help-echo))) - (apply 'insert-text-button label (cdr col-desc))) + (cond ((stringp col-desc) + (insert (if (get-text-property 0 'help-echo label) + label + (propertize label 'help-echo help-echo)))) + ((eq (car col-desc) 'image) + (insert (propertize " " + 'display col-desc + 'help-echo help-echo))) + ((apply 'insert-text-button label (cdr col-desc)))) (let ((next-x (+ x pad-right width))) ;; No need to append any spaces if this is the last column. (when not-last-col @@ -669,6 +684,10 @@ With a numeric prefix argument N, sort the Nth column. If the numeric prefix is -1, restore order the list was originally displayed in." (interactive "P") + (when (and n + (or (>= n (length tabulated-list-format)) + (< n -1))) + (user-error "Invalid column number")) (if (equal n -1) ;; Restore original order. (progn diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el index 1ef4931b7be..c7d02cc7487 100644 --- a/lisp/emacs-lisp/timer.el +++ b/lisp/emacs-lisp/timer.el @@ -314,7 +314,7 @@ This function is called, by name, directly by the C code." (not (timer--idle-delay timer))) (setf (timer--time timer) (timer-next-integral-multiple-of-time - (current-time) (timer--repeat-delay timer)))) + nil (timer--repeat-delay timer)))) ;; Place it back on the timer-list before running ;; timer--function, so it can cancel-timer itself. (timer-activate timer t cell) @@ -351,19 +351,27 @@ This function is called, by name, directly by the C code." Repeat the action every REPEAT seconds, if REPEAT is non-nil. REPEAT may be an integer or floating point number. TIME should be one of: + - a string giving today's time like \"11:23pm\" (the acceptable formats are HHMM, H:MM, HH:MM, HHam, HHAM, HHpm, HHPM, HH:MMam, HH:MMAM, HH:MMpm, or HH:MMPM; a period `.' can be used instead of a colon `:' to separate the hour and minute parts); + - a string giving a relative time like \"90\" or \"2 hours 35 minutes\" (the acceptable forms are a number of seconds without units or some combination of values using units in `timer-duration-words'); + - nil, meaning now; + - a number of seconds from now; + - a value from `encode-time'; -- or t (with non-nil REPEAT) meaning the next integral - multiple of REPEAT. + +- or t (with non-nil REPEAT) meaning the next integral multiple + of REPEAT. This is handy when you want the function to run at + a certain \"round\" number. For instance, (run-at-time t 60 ...) + will run at 11:04:00, 11:05:00, etc. The action is to call FUNCTION with arguments ARGS. @@ -383,7 +391,7 @@ This function returns a timer object which you can use in ;; Special case: t means the next integral multiple of REPEAT. (when (and (eq time t) repeat) - (setq time (timer-next-integral-multiple-of-time (current-time) repeat)) + (setq time (timer-next-integral-multiple-of-time nil repeat)) (setf (timer--integral-multiple timer) t)) ;; Handle numbers as relative times in seconds. diff --git a/lisp/emacs-lisp/warnings.el b/lisp/emacs-lisp/warnings.el index 36b275e2d3c..1d061364a03 100644 --- a/lisp/emacs-lisp/warnings.el +++ b/lisp/emacs-lisp/warnings.el @@ -307,7 +307,9 @@ entirely by setting `warning-suppress-types' or 'type 'warning-suppress-log-warning 'warning-type type)) (funcall newline) - (when (and warning-fill-prefix (not (string-search "\n" message))) + (when (and warning-fill-prefix + (not (string-search "\n" message)) + (not noninteractive)) (let ((fill-prefix warning-fill-prefix) (fill-column warning-fill-column)) (fill-region start (point)))) diff --git a/lisp/emulation/cua-base.el b/lisp/emulation/cua-base.el index 3976c1ea063..befcb423823 100644 --- a/lisp/emulation/cua-base.el +++ b/lisp/emulation/cua-base.el @@ -396,17 +396,17 @@ and after the region marked by the rectangle to search." (defcustom cua-rectangle-mark-key [(control return)] "Global key used to toggle the cua rectangle mark." - :set #'(lambda (symbol value) - (set symbol value) - (when (and (boundp 'cua--keymaps-initialized) - cua--keymaps-initialized) - (define-key cua-global-keymap value - #'cua-set-rectangle-mark) - (when (boundp 'cua--rectangle-keymap) - (define-key cua--rectangle-keymap value - #'cua-clear-rectangle-mark) - (define-key cua--region-keymap value - #'cua-toggle-rectangle-mark)))) + :set (lambda (symbol value) + (set symbol value) + (when (and (boundp 'cua--keymaps-initialized) + cua--keymaps-initialized) + (define-key cua-global-keymap value + #'cua-set-rectangle-mark) + (when (boundp 'cua--rectangle-keymap) + (define-key cua--rectangle-keymap value + #'cua-clear-rectangle-mark) + (define-key cua--region-keymap value + #'cua-toggle-rectangle-mark)))) :type 'key-sequence) (defcustom cua-rectangle-modifier-key 'meta @@ -699,6 +699,11 @@ Repeating prefix key when region is active works as a single prefix key." (interactive) (cua--prefix-override-replay 0)) +;; These aliases are so that we can look up the commands and find the +;; correct keys when generating menus. +(defalias 'cua-cut-handler #'cua--prefix-override-handler) +(defalias 'cua-copy-handler #'cua--prefix-override-handler) + (defun cua--prefix-repeat-handler () "Repeating prefix key when region is active works as a single prefix key." (interactive) @@ -1258,10 +1263,8 @@ If ARG is the atom `-', scroll upward by nearly full screen." (define-key cua--cua-keys-keymap [(meta v)] #'delete-selection-repeat-replace-region)) - (define-key cua--prefix-override-keymap [(control x)] - #'cua--prefix-override-handler) - (define-key cua--prefix-override-keymap [(control c)] - #'cua--prefix-override-handler) + (define-key cua--prefix-override-keymap [(control x)] #'cua-cut-handler) + (define-key cua--prefix-override-keymap [(control c)] #'cua-copy-handler) (define-key cua--prefix-repeat-keymap [(control x) (control x)] #'cua--prefix-repeat-handler) diff --git a/lisp/emulation/cua-rect.el b/lisp/emulation/cua-rect.el index 65ae2f192fa..7df45e705d3 100644 --- a/lisp/emulation/cua-rect.el +++ b/lisp/emulation/cua-rect.el @@ -486,10 +486,8 @@ Activates the region if needed. Only lasts until the region is deactivated." (cua--deactivate t)) (setq cua--last-rectangle nil) (mouse-set-point event) - ;; FIX ME -- need to calculate virtual column. - (cua-set-rectangle-mark) - (setq cua--buffer-and-point-before-command nil) - (setq cua--mouse-last-pos nil)) + (activate-mark) + (cua-rectangle-mark-mode)) (defun cua-mouse-save-then-kill-rectangle (event arg) "Expand rectangle to mouse click position and copy rectangle. diff --git a/lisp/emulation/viper-cmd.el b/lisp/emulation/viper-cmd.el index 9f3d515bc6d..849ad3d8241 100644 --- a/lisp/emulation/viper-cmd.el +++ b/lisp/emulation/viper-cmd.el @@ -35,9 +35,7 @@ (defvar viper--key-maps) (defvar viper--intercept-key-maps) (defvar iso-accents-mode) -(defvar quail-mode) (defvar quail-current-str) -(defvar mark-even-if-inactive) (defvar viper--init-message) (defvar viper-initial) (defvar undo-beg-posn) @@ -69,8 +67,7 @@ (nm-p (intern (concat snm "-p"))) (nms (intern (concat snm "s")))) `(defun ,nm-p (com) - (consp (viper-memq-char com ,nms) - )))) + (consp (memq com ,nms))))) ;; Variables for defining VI commands @@ -1035,23 +1032,23 @@ as a Meta key and any number of multiple escapes are allowed." cmd-info cmd-to-exec-at-end) (while (and cont - (viper-memq-char char - (list ?c ?d ?y ?! ?< ?> ?= ?# ?r ?R ?\" - viper-buffer-search-char))) + (memq char + (list ?c ?d ?y ?! ?< ?> ?= ?# ?r ?R ?\" + viper-buffer-search-char))) (if com ;; this means that we already have a command character, so we ;; construct a com list and exit while. however, if char is " ;; it is an error. (progn ;; new com is (CHAR . OLDCOM) - (if (viper-memq-char char '(?# ?\")) (user-error viper-ViperBell)) + (if (memq char '(?# ?\")) (user-error viper-ViperBell)) (setq com (cons char com)) (setq cont nil)) ;; If com is nil we set com as char, and read more. Again, if char is ;; ", we read the name of register and store it in viper-use-register. ;; if char is !, =, or #, a complete com is formed so we exit the while ;; loop. - (cond ((viper-memq-char char '(?! ?=)) + (cond ((memq char '(?! ?=)) (setq com char) (setq char (read-char)) (setq cont nil)) @@ -1091,7 +1088,7 @@ as a Meta key and any number of multiple escapes are allowed." `(key-binding (char-to-string ,char))))) ;; as com is non-nil, this means that we have a command to execute - (if (viper-memq-char (car com) '(?r ?R)) + (if (memq (car com) '(?r ?R)) ;; execute appropriate region command. (let ((char (car com)) (com (cdr com))) (setq prefix-arg (cons value com)) @@ -2314,7 +2311,6 @@ problems." (viper-downgrade-to-insert)) (defun viper-start-R-mode () - ;; Leave arg as 1, not t: XEmacs insists that it must be a pos number (overwrite-mode 1) (add-hook 'viper-post-command-hooks #'viper-R-state-post-command-sentinel t 'local) @@ -2603,12 +2599,12 @@ On reaching beginning of line, stop and signal error." (let ((prev-char (viper-char-at-pos 'backward)) (saved-point (point))) ;; skip non-newline separators backward - (while (and (not (viper-memq-char prev-char '(nil \n))) + (while (and (not (memq prev-char '(nil \n))) (< lim (point)) ;; must be non-newline separator (if (eq viper-syntax-preference 'strict-vi) - (viper-memq-char prev-char '(?\ ?\t)) - (viper-memq-char (char-syntax prev-char) '(?\ ?-)))) + (memq prev-char '(?\ ?\t)) + (memq (char-syntax prev-char) '(?\ ?-)))) (viper-backward-char-carefully) (setq prev-char (viper-char-at-pos 'backward))) @@ -2622,12 +2618,12 @@ On reaching beginning of line, stop and signal error." ;; skip again, but make sure we don't overshoot the limit (if twice - (while (and (not (viper-memq-char prev-char '(nil \n))) + (while (and (not (memq prev-char '(nil \n))) (< lim (point)) ;; must be non-newline separator (if (eq viper-syntax-preference 'strict-vi) - (viper-memq-char prev-char '(?\ ?\t)) - (viper-memq-char (char-syntax prev-char) '(?\ ?-)))) + (memq prev-char '(?\ ?\t)) + (memq (char-syntax prev-char) '(?\ ?-)))) (viper-backward-char-carefully) (setq prev-char (viper-char-at-pos 'backward)))) @@ -2645,10 +2641,10 @@ On reaching beginning of line, stop and signal error." (viper-forward-word-kernel val) (if com (progn - (cond ((viper-char-equal com ?c) + (cond ((eq com ?c) (viper-separator-skipback-special 'twice viper-com-point)) ;; Yank words including the whitespace, but not newline - ((viper-char-equal com ?y) + ((eq com ?y) (viper-separator-skipback-special nil viper-com-point)) ((viper-dotable-command-p com) (viper-separator-skipback-special nil viper-com-point))) @@ -2666,10 +2662,10 @@ On reaching beginning of line, stop and signal error." (viper-skip-nonseparators 'forward) (viper-skip-separators t)) (if com (progn - (cond ((viper-char-equal com ?c) + (cond ((eq com ?c) (viper-separator-skipback-special 'twice viper-com-point)) ;; Yank words including the whitespace, but not newline - ((viper-char-equal com ?y) + ((eq com ?y) (viper-separator-skipback-special nil viper-com-point)) ((viper-dotable-command-p com) (viper-separator-skipback-special nil viper-com-point))) @@ -4714,15 +4710,15 @@ Please, specify your level now: ")) (defun viper-submit-report () "Submit bug report on Viper." (interactive) - (defvar viper-color-display-p) + (defvar x-display-color-p) (defvar viper-frame-parameters) (defvar viper-minibuffer-emacs-face) (defvar viper-minibuffer-vi-face) (defvar viper-minibuffer-insert-face) (let ((reporter-prompt-for-summary-p t) - (viper-color-display-p (if (viper-window-display-p) - (viper-color-display-p) - 'non-x)) + (x-display-color-p (if (viper-window-display-p) + (x-display-color-p) + 'non-x)) (viper-frame-parameters (frame-parameters (selected-frame))) (viper-minibuffer-emacs-face (if (viper-has-face-support-p) (facep @@ -4780,7 +4776,7 @@ Please, specify your level now: ")) 'viper-expert-level 'major-mode 'window-system - 'viper-color-display-p + 'x-display-color-p 'viper-frame-parameters 'viper-minibuffer-vi-face 'viper-minibuffer-insert-face diff --git a/lisp/emulation/viper-ex.el b/lisp/emulation/viper-ex.el index ef15779e1bf..85c8b87b9a1 100644 --- a/lisp/emulation/viper-ex.el +++ b/lisp/emulation/viper-ex.el @@ -25,7 +25,6 @@ ;;; Code: ;; Compiler pacifier -(defvar read-file-name-map) (defvar viper-use-register) (defvar viper-s-string) (defvar viper-shift-width) diff --git a/lisp/emulation/viper-init.el b/lisp/emulation/viper-init.el index fe3704841ac..368a5dc40a6 100644 --- a/lisp/emulation/viper-init.el +++ b/lisp/emulation/viper-init.el @@ -25,16 +25,12 @@ ;;; Code: ;; compiler pacifier -(defvar mark-even-if-inactive) -(defvar quail-mode) (defvar iso-accents-mode) (defvar viper-current-state) (defvar viper-version) (defvar viper-expert-level) (defvar current-input-method) (defvar default-input-method) -(defvar describe-current-input-method-function) -(defvar bar-cursor) (defvar cursor-type) ;; end pacifier @@ -48,12 +44,6 @@ (define-obsolete-function-alias 'viper-device-type #'window-system "27.1") -(defun viper-color-display-p () - (condition-case nil - (display-color-p) - (error nil))) - -;; in XEmacs: device-type is tty on tty and stream in batch. (defun viper-window-display-p () (and window-system (not (memq window-system '(tty stream pc))))) @@ -81,7 +71,7 @@ In all likelihood, you don't need to bother with this setting." (defun viper-has-face-support-p () (cond ((viper-window-display-p)) (viper-force-faces) - ((viper-color-display-p)) + ((x-display-color-p)) (t (memq window-system '(pc))))) diff --git a/lisp/emulation/viper-mous.el b/lisp/emulation/viper-mous.el index 02db39f1cb0..879d8edca6f 100644 --- a/lisp/emulation/viper-mous.el +++ b/lisp/emulation/viper-mous.el @@ -26,7 +26,6 @@ ;; compiler pacifier (defvar double-click-time) -(defvar mouse-track-multi-click-time) (defvar viper-search-start-marker) (defvar viper-local-search-start-marker) (defvar viper-search-history) @@ -76,8 +75,8 @@ or a triple-click." ;; remembers prefix argument to pass along to commands invoked by second ;; click. -;; This is needed because in Emacs (not XEmacs), assigning to prefix-arg -;; causes Emacs to count the second click as if it was a single click +;; This is needed because assigning to prefix-arg causes Emacs to +;; count the second click as if it was a single click (defvar viper-global-prefix-argument nil) @@ -199,8 +198,7 @@ is ignored." (setq result (buffer-substring word-beg (point)))) ) ; if - ;; XEmacs doesn't have set-text-properties, but there buffer-substring - ;; doesn't return properties together with the string, so it's not needed. + ;; FIXME: Use `buffer-substring-no-properties' above instead? (set-text-properties 0 (length result) nil result) result)) diff --git a/lisp/emulation/viper-util.el b/lisp/emulation/viper-util.el index 0f6dceb13cf..0af54b37432 100644 --- a/lisp/emulation/viper-util.el +++ b/lisp/emulation/viper-util.el @@ -29,9 +29,6 @@ ;; Compiler pacifier (defvar viper-minibuffer-current-face) -(defvar viper-minibuffer-insert-face) -(defvar viper-minibuffer-vi-face) -(defvar viper-minibuffer-emacs-face) (defvar viper-replace-overlay-face) (defvar viper-fast-keyseq-timeout) (defvar ex-unix-type-shell) @@ -64,22 +61,8 @@ (define-obsolete-function-alias 'viper-iconify #'iconify-or-deiconify-frame "27.1") - -;; CHAR is supposed to be a char or an integer (positive or negative) -;; LIST is a list of chars, nil, and negative numbers -;; Check if CHAR is a member by trying to convert in characters, if necessary. -;; Introduced for compatibility with XEmacs, where integers are not the same as -;; chars. -(defun viper-memq-char (char list) - (cond ((and (integerp char) (>= char 0)) - (memq char list)) - ((memq char list)))) - -;; Check if char-or-int and char are the same as characters -(defun viper-char-equal (char-or-int char) - (cond ((and (integerp char-or-int) (>= char-or-int 0)) - (= char-or-int char)) - ((eq char-or-int char)))) +(define-obsolete-function-alias 'viper-memq-char #'memq "29.1") +(define-obsolete-function-alias 'viper-char-equal #'eq "29.1") ;; Like =, but accommodates null and also is t for eq-objects (defun viper= (char char1) @@ -88,8 +71,7 @@ (= char char1)) (t nil))) -(defsubst viper-color-display-p () - (x-display-color-p)) +(define-obsolete-function-alias 'viper-color-display-p #'x-display-color-p "29.1") (defun viper-get-cursor-color (&optional _frame) (cdr (assoc 'cursor-color (frame-parameters)))) @@ -97,9 +79,6 @@ (defmacro viper-frame-value (variable) "Return the value of VARIABLE local to the current frame, if there is one. Otherwise return the normal value." - ;; Frame-local variables are obsolete from Emacs 22.2 onwards, - ;; so we do it by hand instead. - ;; Buffer-local values take precedence over frame-local ones. `(if (local-variable-p ',variable) ,variable ;; Distinguish between no frame parameter and a frame parameter @@ -110,7 +89,7 @@ Otherwise return the normal value." ;; cursor colors (defun viper-change-cursor-color (new-color &optional frame) - (if (and (viper-window-display-p) (viper-color-display-p) + (if (and (viper-window-display-p) (x-display-color-p) (stringp new-color) (x-color-defined-p new-color) (not (string= new-color (viper-get-cursor-color)))) (modify-frame-parameters @@ -142,7 +121,7 @@ Otherwise return the normal value." ;; By default, saves current frame cursor color before changing viper state (defun viper-save-cursor-color (before-which-mode) - (if (and (viper-window-display-p) (viper-color-display-p)) + (if (and (viper-window-display-p) (x-display-color-p)) (let ((color (viper-get-cursor-color))) (if (and (stringp color) (x-color-defined-p color) ;; there is something fishy in that the color is not saved if @@ -1183,25 +1162,23 @@ This option is appropriate if you like Emacs-style words." (looking-at (concat "[" viper-strict-ALPHA-chars addl-chars "]")) (or ;; or one of the additional chars being asked to include - (viper-memq-char char (viper-string-to-list addl-chars)) + (memq char (viper-string-to-list addl-chars)) (and ;; not one of the excluded word chars (note: ;; viper-non-word-characters is a list) - (not (viper-memq-char char viper-non-word-characters)) + (not (memq char viper-non-word-characters)) ;; char of the Viper-word syntax class - (viper-memq-char (char-syntax char) - (viper-string-to-list viper-ALPHA-char-class)))))) - )) + (memq (char-syntax char) + (viper-string-to-list viper-ALPHA-char-class)))))))) (defun viper-looking-at-separator () (let ((char (char-after (point)))) (if char (if (eq viper-syntax-preference 'strict-vi) - (viper-memq-char char (viper-string-to-list viper-strict-SEP-chars)) + (memq char (viper-string-to-list viper-strict-SEP-chars)) (or (eq char ?\n) ; RET is always a separator in Vi - (viper-memq-char (char-syntax char) - (viper-string-to-list viper-SEP-char-class))))) - )) + (memq (char-syntax char) + (viper-string-to-list viper-SEP-char-class))))))) (defsubst viper-looking-at-alphasep (&optional addl-chars) (or (viper-looking-at-separator) (viper-looking-at-alpha addl-chars))) @@ -1327,8 +1304,7 @@ This option is appropriate if you like Emacs-style words." ;; of the excluded characters (if (and (eq syntax-of-char-looked-at ?w) (not negated-syntax)) - (not (viper-memq-char - char-looked-at viper-non-word-characters)) + (not (memq char-looked-at viper-non-word-characters)) t)) (funcall skip-syntax-func 1) 0) diff --git a/lisp/emulation/viper.el b/lisp/emulation/viper.el index e9c0fb5e24b..1ee53651264 100644 --- a/lisp/emulation/viper.el +++ b/lisp/emulation/viper.el @@ -304,7 +304,6 @@ ;; compiler pacifier (defvar mark-even-if-inactive) -(defvar quail-mode) (defvar viper-expert-level) (defvar viper-mode-string) (defvar viper-major-mode-modifier-list) diff --git a/lisp/epa-hook.el b/lisp/epa-hook.el index aa196851d4d..5b250af6d70 100644 --- a/lisp/epa-hook.el +++ b/lisp/epa-hook.el @@ -56,15 +56,15 @@ through Custom does that automatically." May either be a string or a list of strings.") (put 'epa-file-encrypt-to 'safe-local-variable - #'(lambda (val) - (or (stringp val) - (and (listp val) - (catch 'safe - (mapc (lambda (elt) - (unless (stringp elt) - (throw 'safe nil))) - val) - t))))) + (lambda (val) + (or (stringp val) + (and (listp val) + (catch 'safe + (mapc (lambda (elt) + (unless (stringp elt) + (throw 'safe nil))) + val) + t))))) (put 'epa-file-encrypt-to 'permanent-local t) diff --git a/lisp/epa-ks.el b/lisp/epa-ks.el index 35caa1a93c5..5dd6ad34d74 100644 --- a/lisp/epa-ks.el +++ b/lisp/epa-ks.el @@ -210,7 +210,8 @@ KEYS is a list of `epa-ks-key' structures, as parsed by (with-current-buffer buf (setq tabulated-list-entries entries) (tabulated-list-print t t)) - (message "Press `f' to mark a key, `x' to fetch all marked keys.")))) + (message (substitute-command-keys + "Press \\`f' to mark a key, \\`x' to fetch all marked keys."))))) (defun epa-ks--restart-search () (when epa-ks-last-query diff --git a/lisp/epa.el b/lisp/epa.el index 57d355cb3e0..93c85bfd37c 100644 --- a/lisp/epa.el +++ b/lisp/epa.el @@ -607,7 +607,11 @@ If SECRET is non-nil, list secret keys instead of public keys." (_ "Error while executing \"%s\":\n\n")) (epg-context-program context)) "\n\n" - (epg-context-error-output context))) + (epg-context-error-output context) + (if (string-search "Unexpected error" + (epg-context-error-output context)) + "\n(File possibly not an encrypted file, but is perhaps a key ring file?)\n" + ""))) (epa-info-mode) (goto-char (point-min))) (display-buffer buffer))))) @@ -648,7 +652,7 @@ If SECRET is non-nil, list secret keys instead of public keys." (setq input (file-name-sans-extension (expand-file-name input))) (expand-file-name (read-file-name - (concat "To file (default " (file-name-nondirectory input) ") ") + (format-prompt "To file" (file-name-nondirectory input)) (file-name-directory input) input))) @@ -1236,9 +1240,7 @@ If no one is selected, symmetric encryption will be performed. ") (list keys (expand-file-name (read-file-name - (concat "To file (default " - (file-name-nondirectory default-name) - ") ") + (format-prompt "To file" (file-name-nondirectory default-name)) (file-name-directory default-name) default-name))))) (let ((context (epg-make-context epa-protocol))) diff --git a/lisp/epg.el b/lisp/epg.el index ea7aa869a0f..3354eb2c1ed 100644 --- a/lisp/epg.el +++ b/lisp/epg.el @@ -334,6 +334,7 @@ callback data (if any)." (cl-defstruct (epg-key (:constructor nil) + (:copier epg--copy-key) (:constructor epg-make-key (owner-trust)) (:predicate nil)) (owner-trust nil :read-only t) @@ -1389,7 +1390,7 @@ NAME is either a string or a list of strings." (if (seq-find (lambda (user) (eq (epg-user-id-validity user) 'revoked)) (epg-key-user-id-list key)) - (let ((copy (copy-epg-key key))) + (let ((copy (epg--copy-key key))) (setf (epg-key-user-id-list copy) (seq-remove (lambda (user) (eq (epg-user-id-validity user) 'revoked)) diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el index 140755fab51..69f63dfbc44 100644 --- a/lisp/erc/erc-backend.el +++ b/lisp/erc/erc-backend.el @@ -199,6 +199,11 @@ active, use the `erc-server-process-alive' function instead.") (defvar-local erc-server-reconnecting nil "Non-nil if the user requests an explicit reconnect, and the current IRC process is still alive.") +(make-obsolete-variable 'erc-server-reconnecting + "see `erc--server-reconnecting'" "29.1") + +(defvar-local erc--server-reconnecting nil + "Non-nil when reconnecting.") (defvar-local erc-server-timed-out nil "Non-nil if the IRC server failed to respond to a ping.") @@ -533,7 +538,8 @@ TLS (see `erc-session-client-certificate' for more details)." (with-current-buffer buffer (setq erc-server-process process) (setq erc-server-quitting nil) - (setq erc-server-reconnecting nil) + (setq erc-server-reconnecting nil + erc--server-reconnecting nil) (setq erc-server-timed-out nil) (setq erc-server-banned nil) (setq erc-server-error-occurred nil) @@ -616,36 +622,42 @@ Make sure you are in an ERC buffer when running this." (erc-log-irc-protocol line nil) (erc-parse-server-response process line))))))) -(define-inline erc-server-reconnect-p (event) +(defun erc--server-reconnect-p (event) + "Return non-nil when ERC should attempt to reconnect. +EVENT is the message received from the closed connection process." + (and erc-server-auto-reconnect + (not erc-server-banned) + ;; make sure we don't infinitely try to reconnect, unless the + ;; user wants that + (or (eq erc-server-reconnect-attempts t) + (and (integerp erc-server-reconnect-attempts) + (< erc-server-reconnect-count + erc-server-reconnect-attempts))) + (or erc-server-timed-out + (not (string-match "^deleted" event))) + ;; open-network-stream-nowait error for connection refused + (if (string-match "^failed with code 111" event) 'nonblocking t))) + +(defun erc-server-reconnect-p (event) "Return non-nil if ERC should attempt to reconnect automatically. EVENT is the message received from the closed connection process." - (inline-letevals (event) - (inline-quote - (or erc-server-reconnecting - (and erc-server-auto-reconnect - (not erc-server-banned) - ;; make sure we don't infinitely try to reconnect, unless the - ;; user wants that - (or (eq erc-server-reconnect-attempts t) - (and (integerp erc-server-reconnect-attempts) - (< erc-server-reconnect-count - erc-server-reconnect-attempts))) - (or erc-server-timed-out - (not (string-match "^deleted" ,event))) - ;; open-network-stream-nowait error for connection refused - (if (string-match "^failed with code 111" ,event) 'nonblocking t)))))) + (declare (obsolete "see `erc--server-reconnect-p'" "29.1")) + (or (with-suppressed-warnings ((obsolete erc-server-reconnecting)) + erc-server-reconnecting) + (erc--server-reconnect-p event))) (defun erc-process-sentinel-2 (event buffer) "Called when `erc-process-sentinel-1' has detected an unexpected disconnect." (if (not (buffer-live-p buffer)) (erc-update-mode-line) (with-current-buffer buffer - (let ((reconnect-p (erc-server-reconnect-p event)) message delay) + (let ((reconnect-p (erc--server-reconnect-p event)) message delay) (setq message (if reconnect-p 'disconnected 'disconnected-noreconnect)) (erc-display-message nil 'error (current-buffer) message) (if (not reconnect-p) ;; terminate, do not reconnect (progn + (setq erc--server-reconnecting nil) (erc-display-message nil 'error (current-buffer) 'terminated ?e event) ;; Update mode line indicators @@ -654,7 +666,8 @@ EVENT is the message received from the closed connection process." ;; reconnect (condition-case nil (progn - (setq erc-server-reconnecting nil + (setq erc-server-reconnecting nil + erc--server-reconnecting t erc-server-reconnect-count (1+ erc-server-reconnect-count)) (setq delay erc-server-reconnect-timeout) (run-at-time delay nil @@ -1169,7 +1182,8 @@ Would expand to: \(fn (NAME &rest ALIASES) &optional EXTRA-FN-DOC EXTRA-VAR-DOC &rest FN-BODY)" (declare (debug (&define [&name "erc-response-handler@" (symbolp &rest symbolp)] - &optional sexp sexp def-body))) + &optional sexp sexp def-body)) + (indent defun)) (if (numberp name) (setq name (intern (format "%03i" name)))) (setq aliases (mapcar (lambda (a) (if (numberp a) diff --git a/lisp/erc/erc-compat.el b/lisp/erc/erc-compat.el index 6b1da2f9054..9bbc1f6a0d1 100644 --- a/lisp/erc/erc-compat.el +++ b/lisp/erc/erc-compat.el @@ -27,8 +27,6 @@ ;;; Code: -(require 'format-spec) - ;;;###autoload(autoload 'erc-define-minor-mode "erc-compat") (define-obsolete-function-alias 'erc-define-minor-mode #'define-minor-mode "28.1") diff --git a/lisp/erc/erc-dcc.el b/lisp/erc/erc-dcc.el index db278a1275c..f27425ac8a1 100644 --- a/lisp/erc/erc-dcc.el +++ b/lisp/erc/erc-dcc.el @@ -1,7 +1,6 @@ ;;; erc-dcc.el --- CTCP DCC module for ERC -*- lexical-binding: t; -*- -;; Copyright (C) 1993-1995, 1998, 2002-2004, 2006-2021 Free Software -;; Foundation, Inc. +;; Copyright (C) 1993-2021 Free Software Foundation, Inc. ;; Author: Ben A. Mesander <ben@gnu.ai.mit.edu> ;; Noah Friedman <friedman@prep.ai.mit.edu> @@ -183,9 +182,7 @@ compared with `erc-nick-equal-p' which is IRC case-insensitive." (let ((prop (car prem)) (val (cadr prem))) (setq prem (cddr prem) - ;; plist-member is a predicate in xemacs - test (and (plist-member elt prop) - (plist-get elt prop))) + test (cadr (plist-member elt prop))) ;; if the property exists and is equal, we continue, else, try the ;; next element of the list (or (and (eq prop :nick) (if (>= emacs-major-version 28) diff --git a/lisp/erc/erc-goodies.el b/lisp/erc/erc-goodies.el index fc9a8d39ef4..683ac2d37c5 100644 --- a/lisp/erc/erc-goodies.el +++ b/lisp/erc/erc-goodies.el @@ -137,7 +137,7 @@ Put this function on `erc-insert-post-hook' and/or `erc-send-post-hook'." (goto-char (point-max)))) (defun erc-move-to-prompt-setup () - "Initialize the move-to-prompt module for XEmacs." + "Initialize the move-to-prompt module." (add-hook 'pre-command-hook #'erc-move-to-prompt nil t)) ;;; Keep place in unvisited channels diff --git a/lisp/erc/erc-imenu.el b/lisp/erc/erc-imenu.el index dcf6db7407a..522bc805f8d 100644 --- a/lisp/erc/erc-imenu.el +++ b/lisp/erc/erc-imenu.el @@ -1,7 +1,6 @@ ;;; erc-imenu.el --- Imenu support for ERC -*- lexical-binding: t; -*- -;; Copyright (C) 2001-2002, 2004, 2006-2021 Free Software Foundation, -;; Inc. +;; Copyright (C) 2001-2021 Free Software Foundation, Inc. ;; Author: Mario Lang <mlang@delysid.org> ;; Maintainer: Amin Bandali <bandali@gnu.org> diff --git a/lisp/erc/erc-replace.el b/lisp/erc/erc-replace.el index 90c0ee6f8a4..b2e9047ce77 100644 --- a/lisp/erc/erc-replace.el +++ b/lisp/erc/erc-replace.el @@ -1,7 +1,6 @@ ;;; erc-replace.el --- wash and massage messages inserted into the buffer -*- lexical-binding: t; -*- -;; Copyright (C) 2001-2002, 2004, 2006-2021 Free Software Foundation, -;; Inc. +;; Copyright (C) 2001-2021 Free Software Foundation, Inc. ;; Author: Andreas Fuchs <asf@void.at> ;; Maintainer: Amin Bandali <bandali@gnu.org> diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 885d311cf38..df6c3c09d90 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -12,7 +12,7 @@ ;; David Edmondson (dme@dme.org) ;; Michael Olson (mwolson@gnu.org) ;; Kelvin White (kwhite@gnu.org) -;; Version: 5.4 +;; Version: 5.4.1 ;; Package-Requires: ((emacs "27.1")) ;; Keywords: IRC, chat, client, Internet ;; URL: https://www.gnu.org/software/emacs/erc.html @@ -69,7 +69,7 @@ (require 'iso8601) (eval-when-compile (require 'subr-x)) -(defconst erc-version "5.4" +(defconst erc-version "5.4.1" "This version of ERC.") (defvar erc-official-location @@ -83,7 +83,8 @@ 'customize-package-emacs-version-alist '(ERC ("5.2" . "22.1") ("5.3" . "23.1") - ("5.4" . "28.1"))) + ("5.4" . "28.1") + ("5.4.1" . "29.1"))) (defgroup erc nil "Emacs Internet Relay Chat client." @@ -871,8 +872,8 @@ See `erc-server-flood-margin' for other flood-related parameters.") ;; Script parameters (defcustom erc-startup-file-list - (list (concat user-emacs-directory ".ercrc.el") - (concat user-emacs-directory ".ercrc") + (list (locate-user-emacs-file ".ercrc.el") + (locate-user-emacs-file ".ercrc") "~/.ercrc.el" "~/.ercrc" ".ercrc.el" ".ercrc") "List of files to try for a startup script. The first existent and readable one will get executed. @@ -1291,7 +1292,7 @@ Example: #\\='erc-replace-insert)) ((remove-hook \\='erc-insert-modify-hook #\\='erc-replace-insert)))" - (declare (doc-string 3)) + (declare (doc-string 3) (indent defun)) (let* ((sn (symbol-name name)) (mode (intern (format "erc-%s-mode" (downcase sn)))) (group (intern (format "erc-%s" (downcase sn)))) @@ -1478,6 +1479,7 @@ Defaults to the server buffer." (define-derived-mode erc-mode fundamental-mode "ERC" "Major mode for Emacs IRC." + :interactive nil (setq local-abbrev-table erc-mode-abbrev-table) (setq-local next-line-add-newlines nil) (setq line-move-ignore-invisible t) @@ -2403,7 +2405,8 @@ If ARG is non-nil, show the *erc-protocol* buffer." (concat "This buffer displays all IRC protocol " "traffic exchanged with servers.")) (erc-make-notice "Kill it to disable logging.") - (erc-make-notice "Press `t' to toggle.")))) + (erc-make-notice (substitute-command-keys + "Press \\`t' to toggle."))))) (insert (string-join msg "\r\n"))) (use-local-map (make-sparse-keymap)) (local-set-key (kbd "t") 'erc-toggle-debug-irc-protocol)) @@ -2816,20 +2819,17 @@ present." (let ((prop-val (erc-get-parsed-vector position))) (and prop-val (member (erc-response.command prop-val) list)))) -(defvar-local erc-send-input-line-function 'erc-send-input-line) +(defvar-local erc-send-input-line-function 'erc-send-input-line + "Function for sending lines lacking a leading user command. +When a line typed into a buffer contains an explicit command, like /msg, +a corresponding handler (here, erc-cmd-MSG) is called. But lines typed +into a channel or query buffer already have an implicit target and +command (PRIVMSG). This function is called on such occasions and also +for special purposes (see erc-dcc.el).") (defun erc-send-input-line (target line &optional force) - "Send LINE to TARGET. - -See also `erc-server-send'." - (setq line (format "PRIVMSG %s :%s" - target - ;; If the line is empty, we still want to - ;; send it - i.e. an empty pasted line. - (if (string= line "\n") - " \n" - line))) - (erc-server-send line force target)) + "Send LINE to TARGET." + (erc-message "PRIVMSG" (concat target " " line) force)) (defun erc-get-arglist (fun) "Return the argument list of a function without the parens." @@ -2967,7 +2967,7 @@ Commands for which no erc-cmd-xxx exists, are tunneled through this function. LINE is sent to the server verbatim, and therefore has to contain the command itself as well." (erc-log (format "cmd: DEFAULT: %s" line)) - (erc-server-send (substring line 1)) + (erc-server-send (string-trim-right (substring line 1) "[\r\n]")) t) (defvar erc--read-time-period-history nil) @@ -3608,11 +3608,13 @@ other people should be displayed." (defun erc-cmd-QUERY (&optional user) "Open a query with USER. -The type of query window/frame/etc will depend on the value of -`erc-query-display'. - -If USER is omitted, close the current query buffer if one exists -- except this is broken now ;-)" +How the query is displayed (in a new window, frame, etc.) depends +on the value of `erc-query-display'." + ;; FIXME: The doc string used to say at the end: + ;; "If USER is omitted, close the current query buffer if one exists + ;; - except this is broken now ;-)" + ;; Does it make sense to have that functionality? What's wrong with + ;; `kill-buffer'? If it makes sense, re-add it. -- SK @ 2021-11-11 (interactive (list (read-string "Start a query with: "))) (let ((session-buffer (erc-server-buffer)) @@ -3754,13 +3756,17 @@ the message given by REASON." (setq buffer (current-buffer))) (with-current-buffer buffer (setq erc-server-quitting nil) - (setq erc-server-reconnecting t) + (with-suppressed-warnings ((obsolete erc-server-reconnecting)) + (setq erc-server-reconnecting t)) + (setq erc--server-reconnecting t) (setq erc-server-reconnect-count 0) (setq process (get-buffer-process (erc-server-buffer))) (if process (delete-process process) (erc-server-reconnect)) - (setq erc-server-reconnecting nil))) + (with-suppressed-warnings ((obsolete erc-server-reconnecting)) + (setq erc-server-reconnecting nil)) + (setq erc--server-reconnecting nil))) t) (put 'erc-cmd-RECONNECT 'process-not-needed t) diff --git a/lisp/eshell/esh-mode.el b/lisp/eshell/esh-mode.el index 8e6506c301c..cae5236d894 100644 --- a/lisp/eshell/esh-mode.el +++ b/lisp/eshell/esh-mode.el @@ -308,7 +308,7 @@ and the hook `eshell-exit-hook'." (make-local-variable 'eshell-command-running-string) (let ((fmt (copy-sequence mode-line-format))) (setq-local mode-line-format fmt)) - (let ((mode-line-elt (memq 'mode-line-modified mode-line-format))) + (let ((mode-line-elt (cdr (memq 'mode-line-front-space mode-line-format)))) (if mode-line-elt (setcar mode-line-elt 'eshell-command-running-string)))) @@ -616,6 +616,14 @@ newline." (and eshell-send-direct-to-subprocesses proc-running-p)) (insert-before-markers-and-inherit ?\n)) + ;; Delete and reinsert input. This seems like a no-op, except + ;; for the resulting entries in the undo list: undoing this + ;; insertion will delete the region, moving the process mark + ;; back to its original position. + (let ((text (buffer-substring eshell-last-output-end (point))) + (inhibit-read-only t)) + (delete-region eshell-last-output-end (point)) + (insert text)) (if proc-running-p (progn (eshell-update-markers eshell-last-output-end) @@ -939,7 +947,14 @@ This function could be in the list `eshell-output-filter-functions'." (beginning-of-line) (if (re-search-forward eshell-password-prompt-regexp eshell-last-output-end t) - (eshell-send-invisible)))))) + ;; Use `run-at-time' in order not to pause execution of + ;; the process filter with a minibuffer + (run-at-time + 0 nil + (lambda (current-buf) + (with-current-buffer current-buf + (eshell-send-invisible))) + (current-buffer))))))) (custom-add-option 'eshell-output-filter-functions 'eshell-watch-for-password-prompt) diff --git a/lisp/eshell/esh-util.el b/lisp/eshell/esh-util.el index 72de6b13e2e..0eef45e0efb 100644 --- a/lisp/eshell/esh-util.el +++ b/lisp/eshell/esh-util.el @@ -63,11 +63,11 @@ has no effect." Setting this to nil is offered as an aid to debugging only." :type 'boolean) -(defcustom eshell-private-file-modes 384 ; umask 177 +(defcustom eshell-private-file-modes #o600 ; umask 177 "The file-modes value to use for creating \"private\" files." :type 'integer) -(defcustom eshell-private-directory-modes 448 ; umask 077 +(defcustom eshell-private-directory-modes #o700 ; umask 077 "The file-modes value to use for creating \"private\" directories." :type 'integer) diff --git a/lisp/ezimage.el b/lisp/ezimage.el index 13f5c039a7f..57033cde058 100644 --- a/lisp/ezimage.el +++ b/lisp/ezimage.el @@ -45,6 +45,7 @@ (defmacro defezimage (variable imagespec docstring) "Define VARIABLE as an image if `defimage' is not available. IMAGESPEC is the image data, and DOCSTRING is documentation for the image." + (declare (indent defun)) `(progn (defimage ,variable ,imagespec ,docstring) (put (quote ,variable) 'ezimage t))) diff --git a/lisp/facemenu.el b/lisp/facemenu.el index 7417bb12030..fe458b8c07b 100644 --- a/lisp/facemenu.el +++ b/lisp/facemenu.el @@ -551,8 +551,8 @@ If the optional argument CALLBACK is non-nil, it should be a function to call each time the user types RET or clicks on a color. The function should accept a single argument, the color name." (interactive) - (when (and (null list) (> (display-color-cells) 0)) - (setq list (list-colors-duplicates (defined-colors))) + (when (> (display-color-cells) 0) + (setq list (list-colors-duplicates (or list (defined-colors)))) (when list-colors-sort ;; Schwartzian transform with `(color key1 key2 key3 ...)'. (setq list (mapcar diff --git a/lisp/faces.el b/lisp/faces.el index 327b0ac01ec..9caba3a11be 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -88,9 +88,9 @@ a font height that isn't optimal." :tag "Font selection order" :type '(list symbol symbol symbol symbol) :group 'font-selection - :set #'(lambda (symbol value) - (set-default symbol value) - (internal-set-font-selection-order value))) + :set (lambda (symbol value) + (set-default symbol value) + (internal-set-font-selection-order value))) ;; In the absence of Fontconfig support, Monospace and Sans Serif are @@ -140,9 +140,9 @@ ALTERNATIVE2 etc." :tag "Alternative font families to try" :type '(repeat (repeat string)) :group 'font-selection - :set #'(lambda (symbol value) - (set-default symbol value) - (internal-set-alternative-font-family-alist value))) + :set (lambda (symbol value) + (set-default symbol value) + (internal-set-alternative-font-family-alist value))) ;; This is defined originally in xfaces.c. @@ -167,9 +167,9 @@ REGISTRY, ALTERNATIVE1, ALTERNATIVE2, and etc." :type '(repeat (repeat string)) :version "21.1" :group 'font-selection - :set #'(lambda (symbol value) - (set-default symbol value) - (internal-set-alternative-font-registry-alist value))) + :set (lambda (symbol value) + (set-default symbol value) + (internal-set-alternative-font-registry-alist value))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -702,9 +702,10 @@ for it to be relative to). `:weight' -VALUE specifies the weight of the font to use. It must be one of the -symbols `ultra-bold', `extra-bold', `bold', `semi-bold', `normal', -`semi-light', `light', `extra-light', `ultra-light'. +VALUE specifies the weight of the font to use. It must be one of +the symbols `ultra-heavy', `heavy', `ultra-bold', `extra-bold', +`bold', `semi-bold', `medium', `normal', `book', `semi-light', +`light', `extra-light', `ultra-light', or `thin'. `:slant' @@ -861,8 +862,8 @@ is specified, `:italic' is ignored." (defun make-face-bold (face &optional frame _noerror) "Make the font of FACE be bold, if possible. FRAME nil or not specified means change face on all frames. -Argument NOERROR is ignored and retained for compatibility. Use `set-face-attribute' for finer control of the font weight." + (declare (advertised-calling-convention (face &optional frame) "29.1")) (interactive (list (read-face-name "Make which face bold" (face-at-point t)))) (set-face-attribute face frame :weight 'bold)) @@ -870,8 +871,8 @@ Use `set-face-attribute' for finer control of the font weight." (defun make-face-unbold (face &optional frame _noerror) "Make the font of FACE be non-bold, if possible. -FRAME nil or not specified means change face on all frames. -Argument NOERROR is ignored and retained for compatibility." +FRAME nil or not specified means change face on all frames." + (declare (advertised-calling-convention (face &optional frame) "29.1")) (interactive (list (read-face-name "Make which face non-bold" (face-at-point t)))) (set-face-attribute face frame :weight 'normal)) @@ -880,8 +881,8 @@ Argument NOERROR is ignored and retained for compatibility." (defun make-face-italic (face &optional frame _noerror) "Make the font of FACE be italic, if possible. FRAME nil or not specified means change face on all frames. -Argument NOERROR is ignored and retained for compatibility. Use `set-face-attribute' for finer control of the font slant." + (declare (advertised-calling-convention (face &optional frame) "29.1")) (interactive (list (read-face-name "Make which face italic" (face-at-point t)))) (set-face-attribute face frame :slant 'italic)) @@ -889,8 +890,8 @@ Use `set-face-attribute' for finer control of the font slant." (defun make-face-unitalic (face &optional frame _noerror) "Make the font of FACE be non-italic, if possible. -FRAME nil or not specified means change face on all frames. -Argument NOERROR is ignored and retained for compatibility." +FRAME nil or not specified means change face on all frames." + (declare (advertised-calling-convention (face &optional frame) "29.1")) (interactive (list (read-face-name "Make which face non-italic" (face-at-point t)))) (set-face-attribute face frame :slant 'normal)) @@ -899,8 +900,8 @@ Argument NOERROR is ignored and retained for compatibility." (defun make-face-bold-italic (face &optional frame _noerror) "Make the font of FACE be bold and italic, if possible. FRAME nil or not specified means change face on all frames. -Argument NOERROR is ignored and retained for compatibility. Use `set-face-attribute' for finer control of font weight and slant." + (declare (advertised-calling-convention (face &optional frame) "29.1")) (interactive (list (read-face-name "Make which face bold-italic" (face-at-point t)))) (set-face-attribute face frame :weight 'bold :slant 'italic)) @@ -1100,7 +1101,7 @@ returned. Otherwise, DEFAULT is returned verbatim." ;; prompt. If so, remove it. (setq prompt (replace-regexp-in-string ": ?\\'" "" prompt)) (let ((prompt (if default - (format-message "%s (default `%s'): " prompt default) + (format-prompt prompt default) (format "%s: " prompt))) aliasfaces nonaliasfaces faces) ;; Build up the completion tables. @@ -1146,32 +1147,32 @@ an integer value." (:foundry (list nil)) (:width - (mapcar #'(lambda (x) (cons (symbol-name (aref x 1)) (aref x 1))) + (mapcar (lambda (x) (cons (symbol-name (aref x 1)) (aref x 1))) font-width-table)) (:weight - (mapcar #'(lambda (x) (cons (symbol-name (aref x 1)) (aref x 1))) + (mapcar (lambda (x) (cons (symbol-name (aref x 1)) (aref x 1))) font-weight-table)) (:slant - (mapcar #'(lambda (x) (cons (symbol-name (aref x 1)) (aref x 1))) + (mapcar (lambda (x) (cons (symbol-name (aref x 1)) (aref x 1))) font-slant-table)) ((or :inverse-video :extend) - (mapcar #'(lambda (x) (cons (symbol-name x) x)) + (mapcar (lambda (x) (cons (symbol-name x) x)) (internal-lisp-face-attribute-values attribute))) ((or :underline :overline :strike-through :box) (if (window-system frame) - (nconc (mapcar #'(lambda (x) (cons (symbol-name x) x)) + (nconc (mapcar (lambda (x) (cons (symbol-name x) x)) (internal-lisp-face-attribute-values attribute)) - (mapcar #'(lambda (c) (cons c c)) + (mapcar (lambda (c) (cons c c)) (defined-colors frame))) - (mapcar #'(lambda (x) (cons (symbol-name x) x)) + (mapcar (lambda (x) (cons (symbol-name x) x)) (internal-lisp-face-attribute-values attribute)))) ((or :foreground :background) - (mapcar #'(lambda (c) (cons c c)) + (mapcar (lambda (c) (cons c c)) (defined-colors frame))) (:height 'integerp) (:stipple - (and (memq (window-system frame) '(x ns)) ; No stipple on w32 + (and (memq (window-system frame) '(x ns)) ; No stipple on w32 or haiku (mapcar #'list (apply #'nconc (mapcar (lambda (dir) @@ -1181,7 +1182,7 @@ an integer value." x-bitmap-file-path))))) (:inherit (cons '("none" . nil) - (mapcar #'(lambda (c) (cons (symbol-name c) c)) + (mapcar (lambda (c) (cons (symbol-name c) c)) (face-list)))) (_ (error "Internal error"))))) @@ -2285,19 +2286,19 @@ If you set `term-file-prefix' to nil, this function does nothing." (let* (term-init-func) ;; First, load the terminal initialization file, if it is ;; available and it hasn't been loaded already. - (tty-find-type #'(lambda (type) - (let ((file (locate-library (concat term-file-prefix type)))) - (and file - (or (assoc file load-history) - (load (replace-regexp-in-string - "\\.el\\(\\.gz\\)?\\'" "" - file) - t t))))) - type) + (tty-find-type (lambda (type) + (let ((file (locate-library (concat term-file-prefix type)))) + (and file + (or (assoc file load-history) + (load (replace-regexp-in-string + "\\.el\\(\\.gz\\)?\\'" "" + file) + t t))))) + type) ;; Next, try to find a matching initialization function, and call it. - (tty-find-type #'(lambda (type) - (fboundp (setq term-init-func - (intern (concat "terminal-init-" type))))) + (tty-find-type (lambda (type) + (fboundp (setq term-init-func + (intern (concat "terminal-init-" type))))) type) (when (fboundp term-init-func) (funcall term-init-func)) @@ -2380,6 +2381,15 @@ If you set `term-file-prefix' to nil, this function does nothing." "The basic variable-pitch face." :group 'basic-faces) +(defface variable-pitch-text + '((t :inherit variable-pitch + :height 1.1)) + "The proportional face used for longer texts. +This is like the `variable-pitch' face, but is slightly bigger by +default." + :version "29.1" + :group 'basic-faces) + (defface shadow '((((class color grayscale) (min-colors 88) (background light)) :foreground "grey50") @@ -2613,14 +2623,23 @@ non-nil." :background "grey75" :foreground "black") (t :inverse-video t)) - "Basic mode line face for selected window." + "Face for the mode lines (for the selected window) as well as header lines. +See `mode-line-display' for the face used on mode lines." :version "21.1" :group 'mode-line-faces :group 'basic-faces) +(defface mode-line-active + '((t :inherit (mode-line variable-pitch))) + "Face for the selected mode line. +This inherits from the `mode-line' face." + :version "29.1" + :group 'mode-line-faces + :group 'basic-faces) + (defface mode-line-inactive '((default - :inherit mode-line) + :inherit (mode-line variable-pitch)) (((class color) (min-colors 88) (background light)) :weight light :box (:line-width -1 :color "grey75" :style nil) @@ -2821,7 +2840,7 @@ Note: Other faces cannot inherit from the cursor face." '((default :box (:line-width 1 :style released-button) :foreground "black") - (((type x w32 ns) (class color)) + (((type x w32 ns haiku) (class color)) :background "grey75") (((type x) (class mono)) :background "grey")) @@ -2877,14 +2896,22 @@ Note: Other faces cannot inherit from the cursor face." :background "grey96" :foreground "DarkBlue" ;; We use negative thickness of the horizontal box border line to ;; avoid enlarging the height of the echo-area display, which - ;; would then move the mode line a few pixels up. - :box (:line-width (1 . -1) :color "grey80")) + ;; would then move the mode line a few pixels up. We use + ;; negative thickness for the vertical border line to avoid + ;; making the characters wider, which then would cause unpleasant + ;; horizontal shifts of the cursor during C-n/C-p movement + ;; through a line with this face. + :box (:line-width (-1 . -1) :color "grey80") + :inherit fixed-pitch) (((class color) (min-colors 88) (background dark)) :background "grey19" :foreground "LightBlue" - :box (:line-width (1 . -1) :color "grey35")) - (((class color grayscale) (background light)) :background "grey90") - (((class color grayscale) (background dark)) :background "grey25") - (t :background "grey90")) + :box (:line-width (-1 . -1) :color "grey35") + :inherit fixed-pitch) + (((class color grayscale) (background light)) :background "grey90" + :inherit fixed-pitch) + (((class color grayscale) (background dark)) :background "grey25" + :inherit fixed-pitch) + (t :background "grey90" :inherit fixed-pitch)) "Face for keybindings in *Help* buffers. This face is added by `substitute-command-keys', which see. diff --git a/lisp/ffap.el b/lisp/ffap.el index 964daaaa15d..5d3cee591be 100644 --- a/lisp/ffap.el +++ b/lisp/ffap.el @@ -651,7 +651,7 @@ also is substituted for the first empty-string component, if there is one. Uses `path-separator' to separate the path into substrings." ;; We cannot use parse-colon-path (files.el), since it kills ;; "//" entries using file-name-as-directory. - ;; Similar: dired-split, TeX-split-string, and RHOGEE's psg-list-env + ;; Similar: TeX-split-string, and RHOGEE's psg-list-env ;; in ff-paths and bib-cite. The EMPTY arg may help mimic kpathsea. (if (or empty (getenv env)) ; should return something (let ((start 0) match dir ret) diff --git a/lisp/filenotify.el b/lisp/filenotify.el index 271fa270836..26954cc73f2 100644 --- a/lisp/filenotify.el +++ b/lisp/filenotify.el @@ -480,6 +480,14 @@ DESCRIPTOR should be an object returned by `file-notify-add-watch'." ;; Modify `file-notify-descriptors' and send a `stopped' event. (file-notify--rm-descriptor descriptor)))) +(defun file-notify-rm-all-watches () + "Remove all existing file notification watches from Emacs." + (interactive) + (maphash + (lambda (key _value) + (file-notify-rm-watch key)) + file-notify-descriptors)) + (defun file-notify-valid-p (descriptor) "Check a watch specified by its DESCRIPTOR. DESCRIPTOR should be an object returned by `file-notify-add-watch'." diff --git a/lisp/files.el b/lisp/files.el index 32b7faa43d0..9ed63a60f81 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -68,6 +68,31 @@ a regexp matching the name it is linked to." :group 'abbrev :group 'find-file) +(defun directory-abbrev-make-regexp (directory) + "Create a regexp to match DIRECTORY for `directory-abbrev-alist'." + (let ((regexp + ;; We include a slash at the end, to avoid spurious + ;; matches such as `/usr/foobar' when the home dir is + ;; `/usr/foo'. + (concat "\\`" (regexp-quote directory) "\\(/\\|\\'\\)"))) + ;; The value of regexp could be multibyte or unibyte. In the + ;; latter case, we need to decode it. + (if (multibyte-string-p regexp) + regexp + (decode-coding-string regexp + (if (eq system-type 'windows-nt) + 'utf-8 + locale-coding-system))))) + +(defun directory-abbrev-apply (filename) + "Apply the abbreviations in `directory-abbrev-alist' to FILENAME. +Note that when calling this, you should set `case-fold-search' as +appropriate for the filesystem used for FILENAME." + (dolist (dir-abbrev directory-abbrev-alist filename) + (when (string-match (car dir-abbrev) filename) + (setq filename (concat (cdr dir-abbrev) + (substring filename (match-end 0))))))) + (defcustom make-backup-files t "Non-nil means make a backup of a file the first time it is saved. This can be done by renaming the file or by copying. @@ -2015,73 +2040,54 @@ if you want to permanently change your home directory after having started Emacs, set `abbreviated-home-dir' to nil so it will be recalculated)." ;; Get rid of the prefixes added by the automounter. (save-match-data ;FIXME: Why? - (if (and automount-dir-prefix - (string-match automount-dir-prefix filename) - (file-exists-p (file-name-directory - (substring filename (1- (match-end 0)))))) - (setq filename (substring filename (1- (match-end 0))))) - ;; Avoid treating /home/foo as /home/Foo during `~' substitution. - (let ((case-fold-search (file-name-case-insensitive-p filename))) - ;; If any elt of directory-abbrev-alist matches this name, - ;; abbreviate accordingly. - (dolist (dir-abbrev directory-abbrev-alist) - (if (string-match (car dir-abbrev) filename) - (setq filename - (concat (cdr dir-abbrev) - (substring filename (match-end 0)))))) - ;; Compute and save the abbreviated homedir name. - ;; We defer computing this until the first time it's needed, to - ;; give time for directory-abbrev-alist to be set properly. - ;; We include a slash at the end, to avoid spurious matches - ;; such as `/usr/foobar' when the home dir is `/usr/foo'. - (unless abbreviated-home-dir - (put 'abbreviated-home-dir 'home (expand-file-name "~")) - (setq abbreviated-home-dir - (let* ((abbreviated-home-dir "\\`\\'.") ;Impossible regexp. - (regexp - (concat "\\`" - (regexp-quote - (abbreviate-file-name - (get 'abbreviated-home-dir 'home))) - "\\(/\\|\\'\\)"))) - ;; Depending on whether default-directory does or - ;; doesn't include non-ASCII characters, the value - ;; of abbreviated-home-dir could be multibyte or - ;; unibyte. In the latter case, we need to decode - ;; it. Note that this function is called for the - ;; first time (from startup.el) when - ;; locale-coding-system is already set up. - (if (multibyte-string-p regexp) - regexp - (decode-coding-string regexp - (if (eq system-type 'windows-nt) - 'utf-8 - locale-coding-system)))))) - - ;; If FILENAME starts with the abbreviated homedir, - ;; and ~ hasn't changed since abbreviated-home-dir was set, - ;; make it start with `~' instead. - ;; If ~ has changed, we ignore abbreviated-home-dir rather than - ;; invalidating it, on the assumption that a change in HOME - ;; is likely temporary (eg for testing). - ;; FIXME Is it even worth caching abbreviated-home-dir? - ;; Ref: https://debbugs.gnu.org/19657#20 - (let (mb1) - (if (and (string-match abbreviated-home-dir filename) - (setq mb1 (match-beginning 1)) - ;; If the home dir is just /, don't change it. - (not (and (= (match-end 0) 1) - (= (aref filename 0) ?/))) - ;; MS-DOS root directories can come with a drive letter; - ;; Novell Netware allows drive letters beyond `Z:'. - (not (and (memq system-type '(ms-dos windows-nt cygwin)) - (string-match "\\`[a-zA-`]:/\\'" filename))) - (equal (get 'abbreviated-home-dir 'home) - (expand-file-name "~"))) - (setq filename - (concat "~" - (substring filename mb1)))) - filename)))) + (if-let ((handler (find-file-name-handler filename 'abbreviate-file-name))) + (funcall handler 'abbreviate-file-name filename) + (if (and automount-dir-prefix + (string-match automount-dir-prefix filename) + (file-exists-p (file-name-directory + (substring filename (1- (match-end 0)))))) + (setq filename (substring filename (1- (match-end 0))))) + ;; Avoid treating /home/foo as /home/Foo during `~' substitution. + (let ((case-fold-search (file-name-case-insensitive-p filename))) + ;; If any elt of directory-abbrev-alist matches this name, + ;; abbreviate accordingly. + (setq filename (directory-abbrev-apply filename)) + + ;; Compute and save the abbreviated homedir name. + ;; We defer computing this until the first time it's needed, to + ;; give time for directory-abbrev-alist to be set properly. + (unless abbreviated-home-dir + (put 'abbreviated-home-dir 'home (expand-file-name "~")) + (setq abbreviated-home-dir + (directory-abbrev-make-regexp + (let ((abbreviated-home-dir "\\`\\'.")) ;Impossible regexp. + (abbreviate-file-name + (get 'abbreviated-home-dir 'home)))))) + + ;; If FILENAME starts with the abbreviated homedir, + ;; and ~ hasn't changed since abbreviated-home-dir was set, + ;; make it start with `~' instead. + ;; If ~ has changed, we ignore abbreviated-home-dir rather than + ;; invalidating it, on the assumption that a change in HOME + ;; is likely temporary (eg for testing). + ;; FIXME Is it even worth caching abbreviated-home-dir? + ;; Ref: https://debbugs.gnu.org/19657#20 + (let (mb1) + (if (and (string-match abbreviated-home-dir filename) + (setq mb1 (match-beginning 1)) + ;; If the home dir is just /, don't change it. + (not (and (= (match-end 0) 1) + (= (aref filename 0) ?/))) + ;; MS-DOS root directories can come with a drive letter; + ;; Novell Netware allows drive letters beyond `Z:'. + (not (and (memq system-type '(ms-dos windows-nt cygwin)) + (string-match "\\`[a-zA-`]:/\\'" filename))) + (equal (get 'abbreviated-home-dir 'home) + (expand-file-name "~"))) + (setq filename + (concat "~" + (substring filename mb1)))) + filename))))) (defun find-buffer-visiting (filename &optional predicate) "Return the buffer visiting file FILENAME (a string). @@ -2761,6 +2767,7 @@ since only a single case-insensitive search through the alist is made." ("\\.gif\\'" . image-mode) ("\\.png\\'" . image-mode) ("\\.jpe?g\\'" . image-mode) + ("\\.webp\\'" . image-mode) ("\\.te?xt\\'" . text-mode) ("\\.[tT]e[xX]\\'" . tex-mode) ("\\.ins\\'" . tex-mode) ;Installation files for TeX packages. @@ -2886,6 +2893,7 @@ ARC\\|ZIP\\|LZH\\|LHA\\|ZOO\\|[JEW]AR\\|XPI\\|RAR\\|CBR\\|7Z\\|SQUASHFS\\)\\'" . ("\\.[ds]?va?h?\\'" . verilog-mode) ("\\.by\\'" . bovine-grammar-mode) ("\\.wy\\'" . wisent-grammar-mode) + ("\\.erts\\'" . erts-mode) ;; .emacs or .gnus or .viper following a directory delimiter in ;; Unix or MS-DOS syntax. ("[:/\\]\\..*\\(emacs\\|gnus\\|viper\\)\\'" . emacs-lisp-mode) @@ -2978,6 +2986,7 @@ ARC\\|ZIP\\|LZH\\|LHA\\|ZOO\\|[JEW]AR\\|XPI\\|RAR\\|CBR\\|7Z\\|SQUASHFS\\)\\'" . ("\\.dng\\'" . image-mode) ("\\.dpx\\'" . image-mode) ("\\.fax\\'" . image-mode) + ("\\.heic\\'" . image-mode) ("\\.hrz\\'" . image-mode) ("\\.icb\\'" . image-mode) ("\\.icc\\'" . image-mode) @@ -4736,7 +4745,6 @@ using \\<minibuffer-local-map>\\[next-history-element]. If optional second arg CONFIRM is non-nil, this function asks for confirmation before overwriting an existing file. Interactively, confirmation is required unless you supply a prefix argument." -;; (interactive "FWrite file: ") (interactive (list (if buffer-file-name (read-file-name "Write file: " @@ -4747,33 +4755,44 @@ Interactively, confirmation is required unless you supply a prefix argument." default-directory) nil nil)) (not current-prefix-arg))) - (or (null filename) (string-equal filename "") - (progn - ;; If arg is a directory name, - ;; use the default file name, but in that directory. - (if (directory-name-p filename) - (setq filename (concat filename - (file-name-nondirectory - (or buffer-file-name (buffer-name)))))) - (and confirm - (file-exists-p filename) - ;; NS does its own confirm dialog. - (not (and (eq (framep-on-display) 'ns) - (listp last-nonmenu-event) - use-dialog-box)) - (or (y-or-n-p (format-message - "File `%s' exists; overwrite? " filename)) - (user-error "Canceled"))) - (set-visited-file-name filename (not confirm)))) - (set-buffer-modified-p t) - ;; Make buffer writable if file is writable. - (and buffer-file-name - (file-writable-p buffer-file-name) - (setq buffer-read-only nil)) - (save-buffer) - ;; It's likely that the VC status at the new location is different from - ;; the one at the old location. - (vc-refresh-state)) + (let ((old-modes + (and buffer-file-name + ;; File may have gone away; ignore errors in that case. + (ignore-errors (file-modes buffer-file-name))))) + (or (null filename) (string-equal filename "") + (progn + ;; If arg is a directory name, + ;; use the default file name, but in that directory. + (if (directory-name-p filename) + (setq filename (concat filename + (file-name-nondirectory + (or buffer-file-name (buffer-name)))))) + (and confirm + (file-exists-p filename) + ;; NS does its own confirm dialog. + (not (and (eq (framep-on-display) 'ns) + (listp last-nonmenu-event) + use-dialog-box)) + (or (y-or-n-p (format-message + "File `%s' exists; overwrite? " filename)) + (user-error "Canceled"))) + (set-visited-file-name filename (not confirm)))) + (set-buffer-modified-p t) + ;; Make buffer writable if file is writable. + (and buffer-file-name + (file-writable-p buffer-file-name) + (setq buffer-read-only nil)) + (save-buffer) + ;; If the old file was executable, then make the new file + ;; executable, too. + (when (and old-modes + (not (zerop (logand #o111 old-modes)))) + (set-file-modes buffer-file-name + (logior (logand #o111 old-modes) + (file-modes buffer-file-name)))) + ;; It's likely that the VC status at the new location is different from + ;; the one at the old location. + (vc-refresh-state))) (defun file-extended-attributes (filename) "Return an alist of extended attributes of file FILENAME. @@ -5048,6 +5067,29 @@ See also `file-name-sans-extension'." (file-name-sans-extension (file-name-nondirectory (or filename (buffer-file-name))))) +(defun file-name-split (filename) + "Return a list of all the components of FILENAME. +On most systems, this will be true: + + (equal (string-join (file-name-split filename) \"/\") filename)" + (let ((components nil)) + ;; If this is a directory file name, then we have a null file name + ;; at the end. + (when (directory-name-p filename) + (push "" components) + (setq filename (directory-file-name filename))) + ;; Loop, chopping off components. + (while (length> filename 0) + (push (file-name-nondirectory filename) components) + (let ((dir (file-name-directory filename))) + (setq filename (and dir (directory-file-name dir))) + ;; If there's nothing left to peel off, we're at the root and + ;; we can stop. + (when (and dir (equal dir filename)) + (push "" components) + (setq filename nil)))) + components)) + (defcustom make-backup-file-name-function #'make-backup-file-name--default-function "A function that `make-backup-file-name' uses to create backup file names. @@ -5774,13 +5816,13 @@ of the directory that was default during command invocation." (defun save-some-buffers (&optional arg pred) "Save some modified file-visiting buffers. Asks user about each one. -You can answer `y' or SPC to save, `n' or DEL not to save, `C-r' +You can answer \\`y' or \\`SPC' to save, \\`n' or \\`DEL' not to save, \\`C-r' to look at the buffer in question with `view-buffer' before -deciding, `d' to view the differences using -`diff-buffer-with-file', `!' to save the buffer and all remaining -buffers without any further querying, `.' to save only the -current buffer and skip the remaining ones and `q' or RET to exit -the function without saving any more buffers. `C-h' displays a +deciding, \\`d' to view the differences using +`diff-buffer-with-file', \\`!' to save the buffer and all remaining +buffers without any further querying, \\`.' to save only the +current buffer and skip the remaining ones and \\`q' or \\`RET' to exit +the function without saving any more buffers. \\`C-h' displays a help message describing these options. This command first saves any buffers where `buffer-save-without-query' is @@ -6180,6 +6222,29 @@ Return nil if DIR is not an existing directory." (unless mismatch (file-equal-p root dir))))))) +(defvar file-has-changed-p--hash-table (make-hash-table :test #'equal) + "Internal variable used by `file-has-changed-p'.") + +(defun file-has-changed-p (file &optional tag) + "Return non-nil if FILE has changed. +The size and modification time of FILE are compared to the size +and modification time of the same FILE during a previous +invocation of `file-has-changed-p'. Thus, the first invocation +of `file-has-changed-p' always returns non-nil when FILE exists. +The optional argument TAG, which must be a symbol, can be used to +limit the comparison to invocations with identical tags; it can be +the symbol of the calling function, for example." + (let* ((file (directory-file-name (expand-file-name file))) + (remote-file-name-inhibit-cache t) + (fileattr (file-attributes file 'integer)) + (attr (and fileattr + (cons (file-attribute-size fileattr) + (file-attribute-modification-time fileattr)))) + (sym (concat (symbol-name tag) "@" file)) + (cachedattr (gethash sym file-has-changed-p--hash-table))) + (when (not (equal attr cachedattr)) + (puthash sym attr file-has-changed-p--hash-table)))) + (defun copy-directory (directory newname &optional keep-time parents copy-contents) "Copy DIRECTORY to NEWNAME. Both args must be strings. This function always sets the file modes of the output files to match @@ -7132,16 +7197,16 @@ default directory. However, if FULL is non-nil, they are absolute." (let ((this-dir-contents ;; Filter out "." and ".." (delq nil - (mapcar #'(lambda (name) - (unless (string-match "\\`\\.\\.?\\'" - (file-name-nondirectory name)) - name)) + (mapcar (lambda (name) + (unless (string-match "\\`\\.\\.?\\'" + (file-name-nondirectory name)) + name)) (directory-files (or dir ".") full (wildcard-to-regexp nondir)))))) (setq contents (nconc (if (and dir (not full)) - (mapcar #'(lambda (name) (concat dir name)) + (mapcar (lambda (name) (concat dir name)) this-dir-contents) this-dir-contents) contents))))) @@ -7156,11 +7221,18 @@ DIRNAME is globbed by the shell if necessary. Prefix arg (second arg if noninteractive) means supply -l switch to `ls'. Actions controlled by variables `list-directory-brief-switches' and `list-directory-verbose-switches'." - (interactive (let ((pfx current-prefix-arg)) - (list (read-directory-name (if pfx "List directory (verbose): " - "List directory (brief): ") - nil default-directory nil) - pfx))) + (interactive + (let ((pfx current-prefix-arg)) + (list (read-file-name + (if pfx "List directory (verbose): " + "List directory (brief): ") + nil default-directory t + nil + (lambda (file) + (or (file-directory-p file) + (insert-directory-wildcard-in-dir-p + (expand-file-name file))))) + pfx))) (let ((switches (if verbose list-directory-verbose-switches list-directory-brief-switches)) buffer) @@ -7611,21 +7683,7 @@ normally equivalent short `-D' option is just passed on to (if val coding-no-eol coding)) (if val (put-text-property pos (point) - 'dired-filename t))))))) - - (if full-directory-p - ;; Try to insert the amount of free space. - (save-excursion - (goto-char beg) - ;; First find the line to put it on. - (when (re-search-forward "^ *\\(total\\)" nil t) - ;; Replace "total" with "total used in directory" to - ;; avoid confusion. - (replace-match "total used in directory" nil nil nil 1) - (let ((available (get-free-disk-space file))) - (when available - (end-of-line) - (insert " available " available)))))))))) + 'dired-filename t))))))))))) (defun insert-directory-adj-pos (pos error-lines) "Convert `ls --dired' file name position value POS to a buffer position. @@ -7786,10 +7844,11 @@ only these files will be asked to be saved." ;; Get a list of the indices of the args that are file names. (file-arg-indices (cdr (or (assq operation - '(;; The first seven are special because they + '(;; The first eight are special because they ;; return a file name. We want to include ;; the /: in the return value. So just ;; avoid stripping it in the first place. + (abbreviate-file-name) (directory-file-name) (expand-file-name) (file-name-as-directory) diff --git a/lisp/finder.el b/lisp/finder.el index c2b9a6d0ef9..00f321b8028 100644 --- a/lisp/finder.el +++ b/lisp/finder.el @@ -362,19 +362,13 @@ not `finder-known-keywords'." (let ((package-list-unversioned t)) (package-show-package-list packages)))) -(define-button-type 'finder-xref 'action #'finder-goto-xref) - -(defun finder-goto-xref (button) - "Jump to a Lisp file for the BUTTON at point." - (let* ((file (button-get button 'xref)) - (lib (locate-library file))) - (if lib (finder-commentary lib) - (message "Unable to locate `%s'" file)))) - ;;;###autoload (defun finder-commentary (file) "Display FILE's commentary section. FILE should be in a form suitable for passing to `locate-library'." + ;; FIXME: Merge this function into `describe-package', which is + ;; strictly better as it has links to URL's and is in a proper help + ;; buffer with navigation forward and backward, etc. (interactive (list (completing-read "Library name: " @@ -391,12 +385,7 @@ FILE should be in a form suitable for passing to `locate-library'." (erase-buffer) (insert str) (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) - 'xref (match-string-no-properties 1) - 'help-echo "Read this file's commentary" - :type 'finder-xref))) + (package--describe-add-library-links) (goto-char (point-min)) (setq buffer-read-only t) (set-buffer-modified-p nil) @@ -469,6 +458,9 @@ Quit the window and kill all Finder-related buffers." ;; continue standard unloading nil) +(define-obsolete-function-alias 'finder-goto-xref + #'package--finder-goto-xref "29.1") + (provide 'finder) diff --git a/lisp/font-lock.el b/lisp/font-lock.el index a4ab897f6f2..c2590eb3c11 100644 --- a/lisp/font-lock.el +++ b/lisp/font-lock.el @@ -2075,7 +2075,7 @@ as the constructs of Haddock, Javadoc and similar systems." (((class color) (min-colors 16) (background dark)) :foreground "PaleGreen") (((class color) (min-colors 8)) :foreground "green") (t :weight bold :underline t)) - "Font Lock mode face used to highlight type and classes." + "Font Lock mode face used to highlight type and class names." :group 'font-lock-faces) (defface font-lock-constant-face diff --git a/lisp/format.el b/lisp/format.el index 6c0ba11641e..8ae51f19ebc 100644 --- a/lisp/format.el +++ b/lisp/format.el @@ -320,7 +320,7 @@ If the format is not specified, attempt a regexp-based guess. Set `buffer-file-format' to the format used, and call any format-specific mode functions." (interactive - (list (format-read "Translate buffer from format (default guess): "))) + (list (format-read (format-prompt "Translate buffer from format" "guess")))) (save-excursion (goto-char (point-min)) (format-decode format (buffer-size) t))) @@ -331,7 +331,7 @@ Arg FORMAT is optional; if omitted the format will be determined by looking for identifying regular expressions at the beginning of the region." (interactive (list (region-beginning) (region-end) - (format-read "Translate region from format (default guess): "))) + (format-read (format-prompt "Translate region from format" "guess")))) (save-excursion (goto-char from) (format-decode format (- to from) nil))) diff --git a/lisp/frame.el b/lisp/frame.el index 2c73737a541..dc7c628e81e 100644 --- a/lisp/frame.el +++ b/lisp/frame.el @@ -808,12 +808,16 @@ also select the new frame." new-frame)) (defvar before-make-frame-hook nil - "Functions to run before `make-frame' creates a new frame.") + "Functions to run before `make-frame' creates a new frame. +Note that these functions are usually not run for the initial +frame, unless you add them to the hook in your early-init file.") (defvar after-make-frame-functions nil "Functions to run after `make-frame' created a new frame. The functions are run with one argument, the newly created -frame.") +frame. +Note that these functions are usually not run for the initial +frame, unless you add them to the hook in your early-init file.") (defvar after-setting-font-hook nil "Functions to run after a frame's font has been changed.") @@ -1633,6 +1637,7 @@ live frame and defaults to the selected one." (declare-function x-frame-geometry "xfns.c" (&optional frame)) (declare-function w32-frame-geometry "w32fns.c" (&optional frame)) (declare-function ns-frame-geometry "nsfns.m" (&optional frame)) +(declare-function haiku-frame-geometry "haikufns.c" (&optional frame)) (defun frame-geometry (&optional frame) "Return geometric attributes of FRAME. @@ -1682,6 +1687,8 @@ and width values are in pixels. (w32-frame-geometry frame)) ((eq frame-type 'ns) (ns-frame-geometry frame)) + ((eq frame-type 'haiku) + (haiku-frame-geometry frame)) (t (list '(outer-position 0 . 0) @@ -1806,6 +1813,7 @@ of frames like calls to map a frame or change its visibility." (declare-function x-frame-edges "xfns.c" (&optional frame type)) (declare-function w32-frame-edges "w32fns.c" (&optional frame type)) (declare-function ns-frame-edges "nsfns.m" (&optional frame type)) +(declare-function haiku-frame-edges "haikufns.c" (&optional frame type)) (defun frame-edges (&optional frame type) "Return coordinates of FRAME's edges. @@ -1829,12 +1837,15 @@ FRAME." (w32-frame-edges frame type)) ((eq frame-type 'ns) (ns-frame-edges frame type)) + ((eq frame-type 'haiku) + (haiku-frame-edges frame type)) (t (list 0 0 (frame-width frame) (frame-height frame)))))) (declare-function w32-mouse-absolute-pixel-position "w32fns.c") (declare-function x-mouse-absolute-pixel-position "xfns.c") (declare-function ns-mouse-absolute-pixel-position "nsfns.m") +(declare-function haiku-mouse-absolute-pixel-position "haikufns.c") (defun mouse-absolute-pixel-position () "Return absolute position of mouse cursor in pixels. @@ -1849,12 +1860,15 @@ position (0, 0) of the selected frame's terminal." (w32-mouse-absolute-pixel-position)) ((eq frame-type 'ns) (ns-mouse-absolute-pixel-position)) + ((eq frame-type 'haiku) + (haiku-mouse-absolute-pixel-position)) (t (cons 0 0))))) (declare-function ns-set-mouse-absolute-pixel-position "nsfns.m" (x y)) (declare-function w32-set-mouse-absolute-pixel-position "w32fns.c" (x y)) (declare-function x-set-mouse-absolute-pixel-position "xfns.c" (x y)) +(declare-function haiku-set-mouse-absolute-pixel-position "haikufns.c" (x y)) (defun set-mouse-absolute-pixel-position (x y) "Move mouse pointer to absolute pixel position (X, Y). @@ -1867,7 +1881,9 @@ position (0, 0) of the selected frame's terminal." ((eq frame-type 'x) (x-set-mouse-absolute-pixel-position x y)) ((eq frame-type 'w32) - (w32-set-mouse-absolute-pixel-position x y))))) + (w32-set-mouse-absolute-pixel-position x y)) + ((eq frame-type 'haiku) + (haiku-set-mouse-absolute-pixel-position x y))))) (defun frame-monitor-attributes (&optional frame) "Return the attributes of the physical monitor dominating FRAME. @@ -1960,6 +1976,7 @@ workarea attribute." (declare-function x-frame-list-z-order "xfns.c" (&optional display)) (declare-function w32-frame-list-z-order "w32fns.c" (&optional display)) (declare-function ns-frame-list-z-order "nsfns.m" (&optional display)) +(declare-function haiku-frame-list-z-order "haikufns.c" (&optional display)) (defun frame-list-z-order (&optional display) "Return list of Emacs' frames, in Z (stacking) order. @@ -1979,7 +1996,9 @@ Return nil if DISPLAY contains no Emacs frame." ((eq frame-type 'w32) (w32-frame-list-z-order display)) ((eq frame-type 'ns) - (ns-frame-list-z-order display))))) + (ns-frame-list-z-order display)) + ((eq frame-type 'haiku) + (haiku-frame-list-z-order display))))) (declare-function x-frame-restack "xfns.c" (frame1 frame2 &optional above)) (declare-function w32-frame-restack "w32fns.c" (frame1 frame2 &optional above)) @@ -2060,8 +2079,8 @@ frame's display)." ((eq frame-type 'w32) (with-no-warnings (> w32-num-mouse-buttons 0))) - ((memq frame-type '(x ns)) - t) ;; We assume X and NeXTstep *always* have a pointing device + ((memq frame-type '(x ns haiku)) + t) ;; We assume X, NeXTstep and Haiku *always* have a pointing device (t (or (and (featurep 'xt-mouse) xterm-mouse-mode) @@ -2086,7 +2105,7 @@ frames and several different fonts at once. This is true for displays that use a window system such as X, and false for text-only terminals. DISPLAY can be a display name, a frame, or nil (meaning the selected frame's display)." - (not (null (memq (framep-on-display display) '(x w32 ns))))) + (not (null (memq (framep-on-display display) '(x w32 ns haiku))))) (defun display-images-p (&optional display) "Return non-nil if DISPLAY can display images. @@ -2137,7 +2156,7 @@ DISPLAY should be either a frame or a display name (a string). If DISPLAY is omitted or nil, it defaults to the selected frame's display." (let ((frame-type (framep-on-display display))) (cond - ((memq frame-type '(x w32 ns)) + ((memq frame-type '(x w32 ns haiku)) (x-display-screens display)) (t 1)))) @@ -2157,7 +2176,7 @@ with DISPLAY. To get information for each physical monitor, use `display-monitor-attributes-list'." (let ((frame-type (framep-on-display display))) (cond - ((memq frame-type '(x w32 ns)) + ((memq frame-type '(x w32 ns haiku)) (x-display-pixel-height display)) (t (frame-height (if (framep display) display (selected-frame))))))) @@ -2177,7 +2196,7 @@ with DISPLAY. To get information for each physical monitor, use `display-monitor-attributes-list'." (let ((frame-type (framep-on-display display))) (cond - ((memq frame-type '(x w32 ns)) + ((memq frame-type '(x w32 ns haiku)) (x-display-pixel-width display)) (t (frame-width (if (framep display) display (selected-frame))))))) @@ -2215,7 +2234,7 @@ For graphical terminals, note that on \"multi-monitor\" setups this refers to the height in millimeters for all physical monitors associated with DISPLAY. To get information for each physical monitor, use `display-monitor-attributes-list'." - (and (memq (framep-on-display display) '(x w32 ns)) + (and (memq (framep-on-display display) '(x w32 ns haiku)) (or (cddr (assoc (or display (frame-parameter nil 'display)) display-mm-dimensions-alist)) (cddr (assoc t display-mm-dimensions-alist)) @@ -2236,7 +2255,7 @@ For graphical terminals, note that on \"multi-monitor\" setups this refers to the width in millimeters for all physical monitors associated with DISPLAY. To get information for each physical monitor, use `display-monitor-attributes-list'." - (and (memq (framep-on-display display) '(x w32 ns)) + (and (memq (framep-on-display display) '(x w32 ns haiku)) (or (cadr (assoc (or display (frame-parameter nil 'display)) display-mm-dimensions-alist)) (cadr (assoc t display-mm-dimensions-alist)) @@ -2254,7 +2273,7 @@ DISPLAY can be a display name or a frame. If DISPLAY is omitted or nil, it defaults to the selected frame's display." (let ((frame-type (framep-on-display display))) (cond - ((memq frame-type '(x w32 ns)) + ((memq frame-type '(x w32 ns haiku)) (x-display-backing-store display)) (t 'not-useful)))) @@ -2267,7 +2286,7 @@ DISPLAY can be a display name or a frame. If DISPLAY is omitted or nil, it defaults to the selected frame's display." (let ((frame-type (framep-on-display display))) (cond - ((memq frame-type '(x w32 ns)) + ((memq frame-type '(x w32 ns haiku)) (x-display-save-under display)) (t 'not-useful)))) @@ -2280,7 +2299,7 @@ DISPLAY can be a display name or a frame. If DISPLAY is omitted or nil, it defaults to the selected frame's display." (let ((frame-type (framep-on-display display))) (cond - ((memq frame-type '(x w32 ns)) + ((memq frame-type '(x w32 ns haiku)) (x-display-planes display)) ((eq frame-type 'pc) 4) @@ -2295,7 +2314,7 @@ DISPLAY can be a display name or a frame. If DISPLAY is omitted or nil, it defaults to the selected frame's display." (let ((frame-type (framep-on-display display))) (cond - ((memq frame-type '(x w32 ns)) + ((memq frame-type '(x w32 ns haiku)) (x-display-color-cells display)) ((eq frame-type 'pc) 16) @@ -2312,7 +2331,7 @@ DISPLAY can be a display name or a frame. If DISPLAY is omitted or nil, it defaults to the selected frame's display." (let ((frame-type (framep-on-display display))) (cond - ((memq frame-type '(x w32 ns)) + ((memq frame-type '(x w32 ns haiku)) (x-display-visual-class display)) ((and (memq frame-type '(pc t)) (tty-display-color-p display)) diff --git a/lisp/gnus/gmm-utils.el b/lisp/gnus/gmm-utils.el index bcf8dd014bc..68a90989046 100644 --- a/lisp/gnus/gmm-utils.el +++ b/lisp/gnus/gmm-utils.el @@ -239,6 +239,7 @@ DEFAULT-MAP specifies the default key map for ICON-LIST." "Create function NAME. If FUNCTION exists, then NAME becomes an alias for FUNCTION. Otherwise, create function NAME with ARG-LIST and BODY." + (declare (indent defun)) (let ((defined-p (fboundp function))) (if defined-p `(defalias ',name ',function) diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el index 6426d825465..169a351c2c7 100644 --- a/lisp/gnus/gnus-agent.el +++ b/lisp/gnus/gnus-agent.el @@ -475,17 +475,16 @@ manipulated as follows: (gnus-run-hooks 'gnus-agent-mode-hook (intern (format "gnus-agent-%s-mode-hook" buffer))))) -(defvar gnus-agent-group-mode-map (make-sparse-keymap)) -(gnus-define-keys gnus-agent-group-mode-map - "Ju" gnus-agent-fetch-groups - "Jc" gnus-enter-category-buffer - "Jj" gnus-agent-toggle-plugged - "Js" gnus-agent-fetch-session - "JY" gnus-agent-synchronize-flags - "JS" gnus-group-send-queue - "Ja" gnus-agent-add-group - "Jr" gnus-agent-remove-group - "Jo" gnus-agent-toggle-group-plugged) +(defvar-keymap gnus-agent-group-mode-map + "J u" #'gnus-agent-fetch-groups + "J c" #'gnus-enter-category-buffer + "J j" #'gnus-agent-toggle-plugged + "J s" #'gnus-agent-fetch-session + "J Y" #'gnus-agent-synchronize-flags + "J S" #'gnus-group-send-queue + "J a" #'gnus-agent-add-group + "J r" #'gnus-agent-remove-group + "J o" #'gnus-agent-toggle-group-plugged) (defun gnus-agent-group-make-menu-bar () (unless (boundp 'gnus-agent-group-menu) @@ -504,16 +503,15 @@ manipulated as follows: ["Synchronize flags" gnus-agent-synchronize-flags t] )))) -(defvar gnus-agent-summary-mode-map (make-sparse-keymap)) -(gnus-define-keys gnus-agent-summary-mode-map - "Jj" gnus-agent-toggle-plugged - "Ju" gnus-agent-summary-fetch-group - "JS" gnus-agent-fetch-group - "Js" gnus-agent-summary-fetch-series - "J#" gnus-agent-mark-article - "J\M-#" gnus-agent-unmark-article - "@" gnus-agent-toggle-mark - "Jc" gnus-agent-catchup) +(defvar-keymap gnus-agent-summary-mode-map + "J j" #'gnus-agent-toggle-plugged + "J u" #'gnus-agent-summary-fetch-group + "J S" #'gnus-agent-fetch-group + "J s" #'gnus-agent-summary-fetch-series + "J #" #'gnus-agent-mark-article + "J M-#" #'gnus-agent-unmark-article + "@" #'gnus-agent-toggle-mark + "J c" #'gnus-agent-catchup) (defun gnus-agent-summary-make-menu-bar () (unless (boundp 'gnus-agent-summary-menu) @@ -527,11 +525,10 @@ manipulated as follows: ["Fetch downloadable" gnus-agent-summary-fetch-group t] ["Catchup undownloaded" gnus-agent-catchup t])))) -(defvar gnus-agent-server-mode-map (make-sparse-keymap)) -(gnus-define-keys gnus-agent-server-mode-map - "Jj" gnus-agent-toggle-plugged - "Ja" gnus-agent-add-server - "Jr" gnus-agent-remove-server) +(defvar-keymap gnus-agent-server-mode-map + "J j" #'gnus-agent-toggle-plugged + "J a" #'gnus-agent-add-server + "J r" #'gnus-agent-remove-server) (defun gnus-agent-server-make-menu-bar () (unless (boundp 'gnus-agent-server-menu) @@ -2597,25 +2594,20 @@ General format specifiers can also be used. See Info node (defvar gnus-category-line-format-spec nil) (defvar gnus-category-mode-line-format-spec nil) -(defvar gnus-category-mode-map nil) - -(unless gnus-category-mode-map - (setq gnus-category-mode-map (make-sparse-keymap)) - (suppress-keymap gnus-category-mode-map) - - (gnus-define-keys gnus-category-mode-map - "q" gnus-category-exit - "k" gnus-category-kill - "c" gnus-category-copy - "a" gnus-category-add - "e" gnus-agent-customize-category - "p" gnus-category-edit-predicate - "g" gnus-category-edit-groups - "s" gnus-category-edit-score - "l" gnus-category-list - - "\C-c\C-i" gnus-info-find-node - "\C-c\C-b" gnus-bug)) +(defvar-keymap gnus-category-mode-map + :suppress t + "q" #'gnus-category-exit + "k" #'gnus-category-kill + "c" #'gnus-category-copy + "a" #'gnus-category-add + "e" #'gnus-agent-customize-category + "p" #'gnus-category-edit-predicate + "g" #'gnus-category-edit-groups + "s" #'gnus-category-edit-score + "l" #'gnus-category-list + + "C-c C-i" #'gnus-info-find-node + "C-c C-b" #'gnus-bug) (defcustom gnus-category-menu-hook nil "Hook run after the creation of the menu." diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index b97cd711c4e..b7701f10a5e 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -768,28 +768,37 @@ Obsolete; use the face `gnus-signature' for customizations instead." :group 'gnus-article-highlight :group 'gnus-article-signature) +(defface gnus-header + '((t :inherit variable-pitch-text)) + "Base face used for all Gnus header faces. +All the other `gnus-header-' faces inherit from this face." + :version "29.1" + :group 'gnus-article-headers + :group 'gnus-article-highlight) + (defface gnus-header-from '((((class color) (background dark)) - (:foreground "PaleGreen1")) + (:foreground "PaleGreen1" :inherit gnus-header)) (((class color) (background light)) - (:foreground "red3")) + (:foreground "red3" :inherit gnus-header)) (t - (:italic t))) + (:italic t :inherit gnus-header))) "Face used for displaying from headers." + :version "29.1" :group 'gnus-article-headers :group 'gnus-article-highlight) (defface gnus-header-subject '((((class color) (background dark)) - (:foreground "SeaGreen1")) + (:foreground "SeaGreen1" :inherit gnus-header)) (((class color) (background light)) - (:foreground "red4")) + (:foreground "red4" :inherit gnus-header)) (t - (:bold t :italic t))) + (:bold t :italic t :inherit gnus-header))) "Face used for displaying subject headers." :group 'gnus-article-headers :group 'gnus-article-highlight) @@ -797,7 +806,7 @@ Obsolete; use the face `gnus-signature' for customizations instead." (defface gnus-header-newsgroups '((((class color) (background dark)) - (:foreground "yellow" :italic t)) + (:foreground "yellow" :italic t :inherit gnus-header)) (((class color) (background light)) (:foreground "MidnightBlue" :italic t)) @@ -812,12 +821,12 @@ articles." (defface gnus-header-name '((((class color) (background dark)) - (:foreground "SpringGreen2")) + (:foreground "SpringGreen2" :inherit gnus-header)) (((class color) (background light)) - (:foreground "maroon")) + (:foreground "maroon" :inherit gnus-header)) (t - (:bold t))) + (:bold t :inherit gnus-header))) "Face used for displaying header names." :group 'gnus-article-headers :group 'gnus-article-highlight) @@ -825,12 +834,13 @@ articles." (defface gnus-header-content '((((class color) (background dark)) - (:foreground "SpringGreen1" :italic t)) + (:foreground "SpringGreen1" :italic t :inherit gnus-header)) (((class color) (background light)) - (:foreground "indianred4" :italic t)) + (:foreground "indianred4" :italic t :inherit gnus-header)) (t - (:italic t))) "Face used for displaying header content." + (:italic t :inherit gnus-header))) + "Face used for displaying header content." :group 'gnus-article-headers :group 'gnus-article-highlight) @@ -1167,6 +1177,19 @@ predicate. See Info node `(gnus)Customizing Articles'." :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) +(defcustom gnus-treat-emojize-symbols nil + "Display emoji versions of symbol. +Some symbols have both a non-emoji presentation and an emoji +presentation. This treatment will make Gnus display the latter +as emojis even when they weren't sent as such. + +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." + :version "29.1" + :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") + :type gnus-article-treat-custom) + (defcustom gnus-treat-unsplit-urls nil "Remove newlines from within URLs. Valid values are nil, t, `head', `first', `last', an integer or a @@ -1360,11 +1383,11 @@ This variable has no effect if `gnus-treat-unfold-headers' is nil." (const :tag "all" t) (regexp))) -(defcustom gnus-treat-fold-headers nil +(defcustom gnus-treat-fold-headers 'head "Fold headers. Valid values are nil, t, `head', `first', `last', an integer or a predicate. See Info node `(gnus)Customizing Articles'." - :version "22.1" + :version "29.1" :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) @@ -1650,6 +1673,7 @@ regexp." (defvar gnus-article-mime-handle-alist-1 nil) (defvar gnus-treatment-function-alist '((gnus-treat-strip-cr gnus-article-remove-cr) + (gnus-treat-emojize-symbols gnus-article-emojize-symbols) (gnus-treat-x-pgp-sig gnus-article-verify-x-pgp-sig) (gnus-treat-strip-banner gnus-article-strip-banner) (gnus-treat-strip-headers-in-body gnus-article-strip-headers-in-body) @@ -2188,6 +2212,14 @@ unfolded." (replace-match " " t t)))) (goto-char (point-max))))))) +(defun gnus--variable-pitch-p (face) + (when face + (or (eq face 'variable-pitch) + (let ((parent (face-attribute face :inherit))) + (if (eq parent 'unspecified) + nil + (seq-some #'gnus--variable-pitch-p (ensure-list parent))))))) + (defun gnus-article-treat-fold-headers () "Fold message headers." (interactive nil gnus-article-mode gnus-summary-mode) @@ -2195,7 +2227,10 @@ unfolded." (while (not (eobp)) (save-restriction (mail-header-narrow-to-field) - (mail-header-fold-field) + (if (not (gnus--variable-pitch-p (get-text-property (point) 'face))) + (mail-header-fold-field) + (forward-char 1) + (pixel-fill-region (point) (point-max) (pixel-fill-width))) (goto-char (point-max)))))) (defun gnus-treat-smiley () @@ -2360,6 +2395,20 @@ fill width." (while (search-forward "\r" nil t) (replace-match "\n" t t))))) +(defun article-emojize-symbols () + "Display symbols (that have an emoji version) as emojis." + (interactive nil gnus-article-mode) + (when-let ((font (and (display-multi-font-p) + (car (internal-char-font nil ?😀))))) + (save-excursion + (let ((inhibit-read-only t)) + (goto-char (point-min)) + (while (re-search-forward "[[:multibyte:]]" nil t) + ;; If there's already a grapheme cluster here, skip it. + (when (and (not (find-composition (point))) + (font-has-char-p font (char-after (match-beginning 0)))) + (insert "\N{VARIATION SELECTOR-16}"))))))) + (defun article-remove-trailing-blank-lines () "Remove all trailing blank lines from the article." (interactive nil gnus-article-mode) @@ -3933,8 +3982,8 @@ This format is defined by the `gnus-article-time-format' variable." ;; No split name was found. ((null split-name) (read-file-name - (concat prompt " (default " - (file-name-nondirectory default-name) "): ") + (format-prompt prompt + (file-name-nondirectory default-name)) (file-name-directory default-name) default-name)) ;; A single group name is returned. @@ -3943,8 +3992,8 @@ This format is defined by the `gnus-article-time-format' variable." (funcall function split-name headers (symbol-value variable))) (read-file-name - (concat prompt " (default " - (file-name-nondirectory default-name) "): ") + (format-prompt prompt + (file-name-nondirectory default-name)) (file-name-directory default-name) default-name)) ;; A single split name was found @@ -3956,9 +4005,8 @@ This format is defined by the `gnus-article-time-format' variable." (file-name-as-directory name)) ((file-exists-p name) name) (t gnus-article-save-directory)))) - (read-file-name - (concat prompt " (default " name "): ") - dir name))) + (read-file-name (format-prompt prompt name) + dir name))) ;; A list of splits was found. (t (setq split-name (nreverse split-name)) @@ -4342,6 +4390,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is article-fill-long-lines article-capitalize-sentences article-remove-cr + article-emojize-symbols article-remove-leading-whitespace article-display-x-face article-display-face @@ -4387,44 +4436,44 @@ If variable `gnus-use-long-file-name' is non-nil, it is ;;; Gnus article mode ;;; -(set-keymap-parent gnus-article-mode-map button-buffer-map) - -(gnus-define-keys gnus-article-mode-map - " " gnus-article-goto-next-page - [?\S-\ ] gnus-article-goto-prev-page - "\177" gnus-article-goto-prev-page - [delete] gnus-article-goto-prev-page - "\C-c^" gnus-article-refer-article - "h" gnus-article-show-summary - "s" gnus-article-show-summary - "\C-c\C-m" gnus-article-mail - "?" gnus-article-describe-briefly - "<" beginning-of-buffer - ">" end-of-buffer - "\C-c\C-i" gnus-info-find-node - "\C-c\C-b" gnus-bug - "R" gnus-article-reply-with-original - "F" gnus-article-followup-with-original - "\C-hk" gnus-article-describe-key - "\C-hc" gnus-article-describe-key-briefly - "\C-hb" gnus-article-describe-bindings - - "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 - "\M-g" gnus-article-read-summary-keys) +(defvar gnus-article-send-map nil) + +(define-keymap :keymap gnus-article-mode-map :suppress t + :parent button-buffer-map + "SPC" #'gnus-article-goto-next-page + "S-SPC" #'gnus-article-goto-prev-page + "DEL" #'gnus-article-goto-prev-page + "<delete>" #'gnus-article-goto-prev-page + "C-c ^" #'gnus-article-refer-article + "h" #'gnus-article-show-summary + "s" #'gnus-article-show-summary + "C-c C-m" #'gnus-article-mail + "?" #'gnus-article-describe-briefly + "<" #'beginning-of-buffer + ">" #'end-of-buffer + "C-c C-i" #'gnus-info-find-node + "C-c C-b" #'gnus-bug + "R" #'gnus-article-reply-with-original + "F" #'gnus-article-followup-with-original + "C-h k" #'gnus-article-describe-key + "C-h c" #'gnus-article-describe-key-briefly + "C-h b" #'gnus-article-describe-bindings + + "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 + "M-g" #'gnus-article-read-summary-keys + + "S" (define-keymap :prefix 'gnus-article-send-map + "W" #'gnus-article-wide-reply-with-original + "<t>" #'gnus-article-read-summary-send-keys)) (substitute-key-definition #'undefined #'gnus-article-read-summary-keys gnus-article-mode-map) -(defvar gnus-article-send-map) -(gnus-define-keys (gnus-article-send-map "S" gnus-article-mode-map) - "W" gnus-article-wide-reply-with-original - [t] gnus-article-read-summary-send-keys) - (defun gnus-article-make-menu-bar () (unless (boundp 'gnus-article-commands-menu) (gnus-summary-make-menu-bar)) @@ -4449,6 +4498,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is ["Treat overstrike" gnus-article-treat-overstrike t] ["Treat ANSI sequences" gnus-article-treat-ansi-sequences t] ["Remove carriage return" gnus-article-remove-cr t] + ["Emojize Symbols" gnus-article-emojize-symbols t] ["Remove leading whitespace" gnus-article-remove-leading-whitespace t] ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t] ["Remove base64" gnus-article-de-base64-unreadable t] @@ -4509,7 +4559,8 @@ commands: (setq show-trailing-whitespace nil) ;; Arrange a callback from `mm-inline-message' if we're ;; displaying a message/rfc822 part. - (setq-local mm-inline-message-prepare-function #'gnus-mime--inline-message) + (setq-local mm-inline-message-prepare-function + #'gnus-mime--inline-message-function) (mm-enable-multibyte)) (defun gnus-article-setup-buffer () @@ -4549,7 +4600,6 @@ commands: (let ((summary gnus-summary-buffer)) (with-current-buffer name (setq-local gnus-article-edit-mode nil) - (gnus-article-stop-animations) (when gnus-article-mime-handles (mm-destroy-parts gnus-article-mime-handles) (setq gnus-article-mime-handles nil)) @@ -4575,6 +4625,7 @@ commands: (current-buffer)))))) (defun gnus-article-stop-animations () + (declare (obsolete nil "29.1")) (cancel-function-timers 'image-animate-timeout)) (defun gnus-stop-downloads () @@ -6045,7 +6096,7 @@ If nil, don't show those extra buttons." (defun gnus-mime-display-mixed (handles) (mapcar #'gnus-mime-display-part handles)) -(defun gnus-mime--inline-message (handle charset) +(defun gnus-mime--inline-message-function (handle charset) (let ((handles (let (gnus-article-mime-handles ;; disable prepare hook @@ -7222,50 +7273,42 @@ other groups." (defvar gnus-article-edit-done-function nil) -(defvar gnus-article-edit-mode-map nil) - -;; Should we be using derived.el for this? -(unless gnus-article-edit-mode-map - (setq gnus-article-edit-mode-map (make-keymap)) - (set-keymap-parent gnus-article-edit-mode-map text-mode-map) - - (gnus-define-keys gnus-article-edit-mode-map - "\C-c?" describe-mode - "\C-c\C-c" gnus-article-edit-done - "\C-c\C-k" gnus-article-edit-exit - "\C-c\C-f\C-t" message-goto-to - "\C-c\C-f\C-o" message-goto-from - "\C-c\C-f\C-b" message-goto-bcc - ;;"\C-c\C-f\C-w" message-goto-fcc - "\C-c\C-f\C-c" message-goto-cc - "\C-c\C-f\C-s" message-goto-subject - "\C-c\C-f\C-r" message-goto-reply-to - "\C-c\C-f\C-n" message-goto-newsgroups - "\C-c\C-f\C-d" message-goto-distribution - "\C-c\C-f\C-f" message-goto-followup-to - "\C-c\C-f\C-m" message-goto-mail-followup-to - "\C-c\C-f\C-k" message-goto-keywords - "\C-c\C-f\C-u" message-goto-summary - "\C-c\C-f\C-i" message-insert-or-toggle-importance - "\C-c\C-f\C-a" message-generate-unsubscribed-mail-followup-to - "\C-c\C-b" message-goto-body - "\C-c\C-i" message-goto-signature - - "\C-c\C-t" message-insert-to - "\C-c\C-n" message-insert-newsgroups - "\C-c\C-o" message-sort-headers - "\C-c\C-e" message-elide-region - "\C-c\C-v" message-delete-not-region - "\C-c\C-z" message-kill-to-signature - "\M-\r" message-newline-and-reformat - "\C-c\C-a" mml-attach-file - "\C-a" message-beginning-of-line - "\t" message-tab - "\M-;" comment-region) - - (gnus-define-keys (gnus-article-edit-wash-map - "\C-c\C-w" gnus-article-edit-mode-map) - "f" gnus-article-edit-full-stops)) +(defvar-keymap gnus-article-edit-mode-map + :full t :parent text-mode-map + "C-c ?" #'describe-mode + "C-c C-c" #'gnus-article-edit-done + "C-c C-k" #'gnus-article-edit-exit + "C-c C-f C-t" #'message-goto-to + "C-c C-f C-o" #'message-goto-from + "C-c C-f C-b" #'message-goto-bcc + "C-c C-f C-c" #'message-goto-cc + "C-c C-f C-s" #'message-goto-subject + "C-c C-f C-r" #'message-goto-reply-to + "C-c C-f C-n" #'message-goto-newsgroups + "C-c C-f C-d" #'message-goto-distribution + "C-c C-f C-f" #'message-goto-followup-to + "C-c C-f RET" #'message-goto-mail-followup-to + "C-c C-f C-k" #'message-goto-keywords + "C-c C-f C-u" #'message-goto-summary + "C-c C-f TAB" #'message-insert-or-toggle-importance + "C-c C-f C-a" #'message-generate-unsubscribed-mail-followup-to + "C-c C-b" #'message-goto-body + "C-c TAB" #'message-goto-signature + + "C-c C-t" #'message-insert-to + "C-c C-n" #'message-insert-newsgroups + "C-c C-o" #'message-sort-headers + "C-c C-e" #'message-elide-region + "C-c C-v" #'message-delete-not-region + "C-c C-z" #'message-kill-to-signature + "M-RET" #'message-newline-and-reformat + "C-c C-a" #'mml-attach-file + "C-a" #'message-beginning-of-line + "TAB" #'message-tab + "M-;" #'comment-region + + "C-c C-w" (define-keymap :prefix 'gnus-article-edit-wash-map + "f" #'gnus-article-edit-full-stops)) (easy-menu-define gnus-article-edit-mode-field-menu gnus-article-edit-mode-map "" diff --git a/lisp/gnus/gnus-bookmark.el b/lisp/gnus/gnus-bookmark.el index 83e482f14c1..e9696b66a9f 100644 --- a/lisp/gnus/gnus-bookmark.el +++ b/lisp/gnus/gnus-bookmark.el @@ -418,32 +418,29 @@ That is, all information but the name." (defvar gnus-bookmark-bmenu-bookmark-column nil) (defvar gnus-bookmark-bmenu-hidden-bookmarks ()) -(defvar gnus-bookmark-bmenu-mode-map nil) - -(if gnus-bookmark-bmenu-mode-map - nil - (setq gnus-bookmark-bmenu-mode-map (make-keymap)) - (suppress-keymap gnus-bookmark-bmenu-mode-map t) - (define-key gnus-bookmark-bmenu-mode-map "q" 'quit-window) - (define-key gnus-bookmark-bmenu-mode-map "\C-m" 'gnus-bookmark-bmenu-select) - (define-key gnus-bookmark-bmenu-mode-map "v" 'gnus-bookmark-bmenu-select) - (define-key gnus-bookmark-bmenu-mode-map "d" 'gnus-bookmark-bmenu-delete) - (define-key gnus-bookmark-bmenu-mode-map "k" 'gnus-bookmark-bmenu-delete) - (define-key gnus-bookmark-bmenu-mode-map "\C-d" 'gnus-bookmark-bmenu-delete-backwards) - (define-key gnus-bookmark-bmenu-mode-map "x" 'gnus-bookmark-bmenu-execute-deletions) - (define-key gnus-bookmark-bmenu-mode-map " " 'next-line) - (define-key gnus-bookmark-bmenu-mode-map "n" 'next-line) - (define-key gnus-bookmark-bmenu-mode-map "p" 'previous-line) - (define-key gnus-bookmark-bmenu-mode-map "\177" 'gnus-bookmark-bmenu-backup-unmark) - (define-key gnus-bookmark-bmenu-mode-map "?" 'describe-mode) - (define-key gnus-bookmark-bmenu-mode-map "u" 'gnus-bookmark-bmenu-unmark) - (define-key gnus-bookmark-bmenu-mode-map "m" 'gnus-bookmark-bmenu-mark) - (define-key gnus-bookmark-bmenu-mode-map "l" 'gnus-bookmark-bmenu-load) - (define-key gnus-bookmark-bmenu-mode-map "s" 'gnus-bookmark-bmenu-save) - (define-key gnus-bookmark-bmenu-mode-map "t" 'gnus-bookmark-bmenu-toggle-infos) - (define-key gnus-bookmark-bmenu-mode-map "a" 'gnus-bookmark-bmenu-show-details) - (define-key gnus-bookmark-bmenu-mode-map [mouse-2] - 'gnus-bookmark-bmenu-select-by-mouse)) + +(defvar-keymap gnus-bookmark-bmenu-mode-map + :full t + :suppress 'nodigits + "q" #'quit-window + "RET" #'gnus-bookmark-bmenu-select + "v" #'gnus-bookmark-bmenu-select + "d" #'gnus-bookmark-bmenu-delete + "k" #'gnus-bookmark-bmenu-delete + "C-d" #'gnus-bookmark-bmenu-delete-backwards + "x" #'gnus-bookmark-bmenu-execute-deletions + "SPC" #'next-line + "n" #'next-line + "p" #'previous-line + "DEL" #'gnus-bookmark-bmenu-backup-unmark + "?" #'describe-mode + "u" #'gnus-bookmark-bmenu-unmark + "m" #'gnus-bookmark-bmenu-mark + "l" #'gnus-bookmark-bmenu-load + "s" #'gnus-bookmark-bmenu-save + "t" #'gnus-bookmark-bmenu-toggle-infos + "a" #'gnus-bookmark-bmenu-show-details + "<mouse-2>" #'gnus-bookmark-bmenu-select-by-mouse) ;; Bookmark Buffer Menu mode is suitable only for specially formatted ;; data. diff --git a/lisp/gnus/gnus-dired.el b/lisp/gnus/gnus-dired.el index e9eddae942f..00769a5da6e 100644 --- a/lisp/gnus/gnus-dired.el +++ b/lisp/gnus/gnus-dired.el @@ -53,12 +53,10 @@ (autoload 'message-buffers "message") (autoload 'gnus-print-buffer "gnus-sum") -(defvar gnus-dired-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\C-c\C-m\C-a" 'gnus-dired-attach) - (define-key map "\C-c\C-m\C-l" 'gnus-dired-find-file-mailcap) - (define-key map "\C-c\C-m\C-p" 'gnus-dired-print) - map)) +(defvar-keymap gnus-dired-mode-map + "C-c C-m C-a" #'gnus-dired-attach + "C-c C-m C-l" #'gnus-dired-find-file-mailcap + "C-c C-m C-p" #'gnus-dired-print) ;; FIXME: Make it customizable, change the default to `mail-user-agent' when ;; this file is renamed (e.g. to `dired-mime.el'). @@ -206,7 +204,8 @@ If ARG is non-nil, open it in a new buffer." (find-file file-name))) (if (file-symlink-p file-name) (error "File is a symlink to a nonexistent target") - (error "File no longer exists; type `g' to update Dired buffer")))) + (error (substitute-command-keys + "File no longer exists; type \\`g' to update Dired buffer"))))) (defun gnus-dired-print (&optional file-name print-to) "In dired, print FILE-NAME according to the mailcap file. @@ -246,9 +245,10 @@ of the file to save in." (error "MIME print only implemented via Gnus"))) (ps-despool print-to)))) ((file-symlink-p file-name) - (error "File is a symlink to a nonexistent target")) - (t - (error "File no longer exists; type `g' to update Dired buffer")))) + (error "File is a symlink to a nonexistent target")) + (t + (error (substitute-command-keys + "File no longer exists; type \\`g' to update Dired buffer"))))) (provide 'gnus-dired) diff --git a/lisp/gnus/gnus-draft.el b/lisp/gnus/gnus-draft.el index 9a0f21359f8..7c56db0ba45 100644 --- a/lisp/gnus/gnus-draft.el +++ b/lisp/gnus/gnus-draft.el @@ -33,15 +33,12 @@ ;;; Draft minor mode -(defvar gnus-draft-mode-map - (let ((map (make-sparse-keymap))) - (gnus-define-keys map - "Dt" gnus-draft-toggle-sending - "e" gnus-draft-edit-message ;; Use `B w' for `gnus-summary-edit-article' - "De" gnus-draft-edit-message - "Ds" gnus-draft-send-message - "DS" gnus-draft-send-all-messages) - map)) +(defvar-keymap gnus-draft-mode-map + "D t" #'gnus-draft-toggle-sending + "e" #' gnus-draft-edit-message ;; Use `B w' for `gnus-summary-edit-article' + "D e" #'gnus-draft-edit-message + "D s" #'gnus-draft-send-message + "D S" #'gnus-draft-send-all-messages) (defun gnus-draft-make-menu-bar () (unless (boundp 'gnus-draft-menu) diff --git a/lisp/gnus/gnus-eform.el b/lisp/gnus/gnus-eform.el index 3fd8bf51de4..c727926731b 100644 --- a/lisp/gnus/gnus-eform.el +++ b/lisp/gnus/gnus-eform.el @@ -48,13 +48,10 @@ (defvar gnus-edit-form-buffer "*Gnus edit form*") (defvar gnus-edit-form-done-function nil) -(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)) +(defvar-keymap gnus-edit-form-mode-map + :parent emacs-lisp-mode-map + "C-c C-c" #'gnus-edit-form-done + "C-c C-k" #'gnus-edit-form-exit) (defun gnus-edit-form-make-menu-bar () (unless (boundp 'gnus-edit-form-menu) diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index b1e486b0627..2ec001faee7 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -62,7 +62,7 @@ (defcustom gnus-keep-same-level nil "Non-nil means that the newsgroup after this one will be on the same level. -When you type, for instance, `n' after reading the last article in the +When you type, for instance, \\`n' after reading the last article in the current newsgroup, you will go to the next newsgroup. If this variable is nil, the next newsgroup will be the next from the group buffer. @@ -573,209 +573,209 @@ simple manner." ;;; Gnus group mode ;;; -(gnus-define-keys gnus-group-mode-map - " " gnus-group-read-group - "=" gnus-group-select-group - "\r" gnus-group-select-group - "\M-\r" gnus-group-quick-select-group - "\M- " gnus-group-visible-select-group - [(meta control return)] gnus-group-select-group-ephemerally - "j" gnus-group-jump-to-group - "n" gnus-group-next-unread-group - "p" gnus-group-prev-unread-group - "\177" gnus-group-prev-unread-group - [delete] gnus-group-prev-unread-group - "N" gnus-group-next-group - "P" gnus-group-prev-group - "\M-n" gnus-group-next-unread-group-same-level - "\M-p" gnus-group-prev-unread-group-same-level - "," gnus-group-best-unread-group - "." gnus-group-first-unread-group - "u" gnus-group-toggle-subscription-at-point - "U" gnus-group-toggle-subscription - "c" gnus-group-catchup-current - "C" gnus-group-catchup-current-all - "\M-c" gnus-group-clear-data - "l" gnus-group-list-groups - "L" gnus-group-list-all-groups - "m" gnus-group-mail - "i" gnus-group-news - "g" gnus-group-get-new-news - "\M-g" gnus-group-get-new-news-this-group - "R" gnus-group-restart - "r" gnus-group-read-init-file - "B" gnus-group-browse-foreign-server - "b" gnus-group-check-bogus-groups - "F" gnus-group-find-new-groups - "\C-c\C-d" gnus-group-describe-group - "\M-d" gnus-group-describe-all-groups - "\C-c\C-a" gnus-group-apropos - "\C-c\M-\C-a" gnus-group-description-apropos - "a" gnus-group-post-news - "\ek" gnus-group-edit-local-kill - "\eK" gnus-group-edit-global-kill - "\C-k" gnus-group-kill-group - "\C-y" gnus-group-yank-group - "\C-w" gnus-group-kill-region - "\C-x\C-t" gnus-group-transpose-groups - "\C-c\C-l" gnus-group-list-killed - "\C-c\C-x" gnus-group-expire-articles - "\C-c\M-\C-x" gnus-group-expire-all-groups - "V" gnus-version - "s" gnus-group-save-newsrc - "z" gnus-group-suspend - "q" gnus-group-exit - "Q" gnus-group-quit - "?" gnus-group-describe-briefly - "\C-c\C-i" gnus-info-find-node - "\M-e" gnus-group-edit-group-method - "^" gnus-group-enter-server-mode - [mouse-2] gnus-mouse-pick-group - [follow-link] mouse-face - "<" beginning-of-buffer - ">" end-of-buffer - "\C-c\C-b" gnus-bug - "\C-c\C-s" gnus-group-sort-groups - "t" gnus-topic-mode - "\C-c\M-g" gnus-activate-all-groups - "\M-&" gnus-group-universal-argument - "#" gnus-group-mark-group - "\M-#" gnus-group-unmark-group) - -(gnus-define-keys (gnus-group-cloud-map "~" gnus-group-mode-map) - "u" gnus-cloud-upload-all-data - "~" gnus-cloud-upload-all-data - "d" gnus-cloud-download-all-data - "\r" gnus-cloud-download-all-data) - -(gnus-define-keys (gnus-group-mark-map "M" gnus-group-mode-map) - "m" gnus-group-mark-group - "u" gnus-group-unmark-group - "w" gnus-group-mark-region - "b" gnus-group-mark-buffer - "r" gnus-group-mark-regexp - "U" gnus-group-unmark-all-groups) - -(gnus-define-keys (gnus-group-sieve-map "D" gnus-group-mode-map) - "u" gnus-sieve-update - "g" gnus-sieve-generate) - -(gnus-define-keys (gnus-group-group-map "G" gnus-group-mode-map) - "d" gnus-group-make-directory-group - "h" gnus-group-make-help-group - "u" gnus-group-make-useful-group - "l" gnus-group-nnimap-edit-acl - "m" gnus-group-make-group - "E" gnus-group-edit-group - "e" gnus-group-edit-group-method - "p" gnus-group-edit-group-parameters - "v" gnus-group-add-to-virtual - "V" gnus-group-make-empty-virtual - "D" gnus-group-enter-directory - "f" gnus-group-make-doc-group - "w" gnus-group-make-web-group - "G" gnus-group-read-ephemeral-search-group - "g" gnus-group-make-search-group - "M" gnus-group-read-ephemeral-group - "r" gnus-group-rename-group - "R" gnus-group-make-rss-group - "c" gnus-group-customize - "z" gnus-group-compact-group - "x" gnus-group-expunge-group - "\177" gnus-group-delete-group - [delete] gnus-group-delete-group) - -(gnus-define-keys (gnus-group-sort-map "S" gnus-group-group-map) - "s" gnus-group-sort-groups - "a" gnus-group-sort-groups-by-alphabet - "u" gnus-group-sort-groups-by-unread - "l" gnus-group-sort-groups-by-level - "v" gnus-group-sort-groups-by-score - "r" gnus-group-sort-groups-by-rank - "m" gnus-group-sort-groups-by-method - "n" gnus-group-sort-groups-by-real-name) - -(gnus-define-keys (gnus-group-sort-selected-map "P" gnus-group-group-map) - "s" gnus-group-sort-selected-groups - "a" gnus-group-sort-selected-groups-by-alphabet - "u" gnus-group-sort-selected-groups-by-unread - "l" gnus-group-sort-selected-groups-by-level - "v" gnus-group-sort-selected-groups-by-score - "r" gnus-group-sort-selected-groups-by-rank - "m" gnus-group-sort-selected-groups-by-method - "n" gnus-group-sort-selected-groups-by-real-name) - -(gnus-define-keys (gnus-group-list-map "A" gnus-group-mode-map) - "k" gnus-group-list-killed - "z" gnus-group-list-zombies - "s" gnus-group-list-groups - "u" gnus-group-list-all-groups - "A" gnus-group-list-active - "a" gnus-group-apropos - "d" gnus-group-description-apropos - "m" gnus-group-list-matching - "M" gnus-group-list-all-matching - "l" gnus-group-list-level - "c" gnus-group-list-cached - "?" gnus-group-list-dormant - "!" gnus-group-list-ticked) - -(gnus-define-keys (gnus-group-list-limit-map "/" gnus-group-list-map) - "k" gnus-group-list-limit - "z" gnus-group-list-limit - "s" gnus-group-list-limit - "u" gnus-group-list-limit - "A" gnus-group-list-limit - "m" gnus-group-list-limit - "M" gnus-group-list-limit - "l" gnus-group-list-limit - "c" gnus-group-list-limit - "?" gnus-group-list-limit - "!" gnus-group-list-limit) - -(gnus-define-keys (gnus-group-list-flush-map "f" gnus-group-list-map) - "k" gnus-group-list-flush - "z" gnus-group-list-flush - "s" gnus-group-list-flush - "u" gnus-group-list-flush - "A" gnus-group-list-flush - "m" gnus-group-list-flush - "M" gnus-group-list-flush - "l" gnus-group-list-flush - "c" gnus-group-list-flush - "?" gnus-group-list-flush - "!" gnus-group-list-flush) - -(gnus-define-keys (gnus-group-list-plus-map "p" gnus-group-list-map) - "k" gnus-group-list-plus - "z" gnus-group-list-plus - "s" gnus-group-list-plus - "u" gnus-group-list-plus - "A" gnus-group-list-plus - "m" gnus-group-list-plus - "M" gnus-group-list-plus - "l" gnus-group-list-plus - "c" gnus-group-list-plus - "?" gnus-group-list-plus - "!" gnus-group-list-plus) - -(gnus-define-keys (gnus-group-score-map "W" gnus-group-mode-map) - "f" gnus-score-flush-cache - "e" gnus-score-edit-all-score) - -(gnus-define-keys (gnus-group-help-map "H" gnus-group-mode-map) - "d" gnus-group-describe-group - "v" gnus-version) - -(gnus-define-keys (gnus-group-sub-map "S" gnus-group-mode-map) - "l" gnus-group-set-current-level - "t" gnus-group-toggle-subscription-at-point - "s" gnus-group-toggle-subscription - "k" gnus-group-kill-group - "y" gnus-group-yank-group - "w" gnus-group-kill-region - "\C-k" gnus-group-kill-level - "z" gnus-group-kill-all-zombies) +(define-keymap :keymap gnus-group-mode-map + "SPC" #'gnus-group-read-group + "=" #'gnus-group-select-group + "RET" #'gnus-group-select-group + "M-RET" #'gnus-group-quick-select-group + "M-SPC" #'gnus-group-visible-select-group + "C-M-<return>" #'gnus-group-select-group-ephemerally + "j" #'gnus-group-jump-to-group + "n" #'gnus-group-next-unread-group + "p" #'gnus-group-prev-unread-group + "DEL" #'gnus-group-prev-unread-group + "<delete>" #'gnus-group-prev-unread-group + "N" #'gnus-group-next-group + "P" #'gnus-group-prev-group + "M-n" #'gnus-group-next-unread-group-same-level + "M-p" #'gnus-group-prev-unread-group-same-level + "," #'gnus-group-best-unread-group + "." #'gnus-group-first-unread-group + "u" #'gnus-group-toggle-subscription-at-point + "U" #'gnus-group-toggle-subscription + "c" #'gnus-group-catchup-current + "C" #'gnus-group-catchup-current-all + "M-c" #'gnus-group-clear-data + "l" #'gnus-group-list-groups + "L" #'gnus-group-list-all-groups + "m" #'gnus-group-mail + "i" #'gnus-group-news + "g" #'gnus-group-get-new-news + "M-g" #'gnus-group-get-new-news-this-group + "R" #'gnus-group-restart + "r" #'gnus-group-read-init-file + "B" #'gnus-group-browse-foreign-server + "b" #'gnus-group-check-bogus-groups + "F" #'gnus-group-find-new-groups + "C-c C-d" #'gnus-group-describe-group + "M-d" #'gnus-group-describe-all-groups + "C-c C-a" #'gnus-group-apropos + "C-c C-M-a" #'gnus-group-description-apropos + "a" #'gnus-group-post-news + "ESC k" #'gnus-group-edit-local-kill + "ESC K" #'gnus-group-edit-global-kill + "C-k" #'gnus-group-kill-group + "C-y" #'gnus-group-yank-group + "C-w" #'gnus-group-kill-region + "C-x C-t" #'gnus-group-transpose-groups + "C-c C-l" #'gnus-group-list-killed + "C-c C-x" #'gnus-group-expire-articles + "C-c C-M-x" #'gnus-group-expire-all-groups + "V" #'gnus-version + "s" #'gnus-group-save-newsrc + "z" #'gnus-group-suspend + "q" #'gnus-group-exit + "Q" #'gnus-group-quit + "?" #'gnus-group-describe-briefly + "C-c C-i" #'gnus-info-find-node + "M-e" #'gnus-group-edit-group-method + "^" #'gnus-group-enter-server-mode + "<mouse-2>" #'gnus-mouse-pick-group + "<follow-link>" 'mouse-face + "<" #'beginning-of-buffer + ">" #'end-of-buffer + "C-c C-b" #'gnus-bug + "C-c C-s" #'gnus-group-sort-groups + "t" #'gnus-topic-mode + "C-c M-g" #'gnus-activate-all-groups + "M-&" #'gnus-group-universal-argument + "#" #'gnus-group-mark-group + "M-#" #'gnus-group-unmark-group + + "~" (define-keymap :prefix 'gnus-group-cloud-map + "u" #'gnus-cloud-upload-all-data + "~" #'gnus-cloud-upload-all-data + "d" #'gnus-cloud-download-all-data + "RET" #'gnus-cloud-download-all-data) + + "M" (define-keymap :prefix 'gnus-group-mark-map + "m" #'gnus-group-mark-group + "u" #'gnus-group-unmark-group + "w" #'gnus-group-mark-region + "b" #'gnus-group-mark-buffer + "r" #'gnus-group-mark-regexp + "U" #'gnus-group-unmark-all-groups) + + "D" (define-keymap :prefix 'gnus-group-sieve-map + "u" #'gnus-sieve-update + "g" #'gnus-sieve-generate) + + "G" (define-keymap :prefix 'gnus-group-group-map + "d" #'gnus-group-make-directory-group + "h" #'gnus-group-make-help-group + "u" #'gnus-group-make-useful-group + "l" #'gnus-group-nnimap-edit-acl + "m" #'gnus-group-make-group + "E" #'gnus-group-edit-group + "e" #'gnus-group-edit-group-method + "p" #'gnus-group-edit-group-parameters + "v" #'gnus-group-add-to-virtual + "V" #'gnus-group-make-empty-virtual + "D" #'gnus-group-enter-directory + "f" #'gnus-group-make-doc-group + "w" #'gnus-group-make-web-group + "G" #'gnus-group-read-ephemeral-search-group + "g" #'gnus-group-make-search-group + "M" #'gnus-group-read-ephemeral-group + "r" #'gnus-group-rename-group + "R" #'gnus-group-make-rss-group + "c" #'gnus-group-customize + "z" #'gnus-group-compact-group + "x" #'gnus-group-expunge-group + "DEL" #'gnus-group-delete-group + "<delete>" #'gnus-group-delete-group + + "S" (define-keymap :prefix 'gnus-group-sort-map + "s" #'gnus-group-sort-groups + "a" #'gnus-group-sort-groups-by-alphabet + "u" #'gnus-group-sort-groups-by-unread + "l" #'gnus-group-sort-groups-by-level + "v" #'gnus-group-sort-groups-by-score + "r" #'gnus-group-sort-groups-by-rank + "m" #'gnus-group-sort-groups-by-method + "n" #'gnus-group-sort-groups-by-real-name) + + "P" (define-keymap :prefix 'gnus-group-sort-selected-map + "s" #'gnus-group-sort-selected-groups + "a" #'gnus-group-sort-selected-groups-by-alphabet + "u" #'gnus-group-sort-selected-groups-by-unread + "l" #'gnus-group-sort-selected-groups-by-level + "v" #'gnus-group-sort-selected-groups-by-score + "r" #'gnus-group-sort-selected-groups-by-rank + "m" #'gnus-group-sort-selected-groups-by-method + "n" #'gnus-group-sort-selected-groups-by-real-name)) + + "A" (define-keymap :prefix 'gnus-group-list-map + "k" #'gnus-group-list-killed + "z" #'gnus-group-list-zombies + "s" #'gnus-group-list-groups + "u" #'gnus-group-list-all-groups + "A" #'gnus-group-list-active + "a" #'gnus-group-apropos + "d" #'gnus-group-description-apropos + "m" #'gnus-group-list-matching + "M" #'gnus-group-list-all-matching + "l" #'gnus-group-list-level + "c" #'gnus-group-list-cached + "?" #'gnus-group-list-dormant + "!" #'gnus-group-list-ticked + + "/" (define-keymap :prefix 'gnus-group-list-limit-map + "k" #'gnus-group-list-limit + "z" #'gnus-group-list-limit + "s" #'gnus-group-list-limit + "u" #'gnus-group-list-limit + "A" #'gnus-group-list-limit + "m" #'gnus-group-list-limit + "M" #'gnus-group-list-limit + "l" #'gnus-group-list-limit + "c" #'gnus-group-list-limit + "?" #'gnus-group-list-limit + "!" #'gnus-group-list-limit) + + "f" (define-keymap :prefix 'gnus-group-list-flush-map + "k" #'gnus-group-list-flush + "z" #'gnus-group-list-flush + "s" #'gnus-group-list-flush + "u" #'gnus-group-list-flush + "A" #'gnus-group-list-flush + "m" #'gnus-group-list-flush + "M" #'gnus-group-list-flush + "l" #'gnus-group-list-flush + "c" #'gnus-group-list-flush + "?" #'gnus-group-list-flush + "!" #'gnus-group-list-flush) + + "p" (define-keymap :prefix 'gnus-group-list-plus-map + "k" #'gnus-group-list-plus + "z" #'gnus-group-list-plus + "s" #'gnus-group-list-plus + "u" #'gnus-group-list-plus + "A" #'gnus-group-list-plus + "m" #'gnus-group-list-plus + "M" #'gnus-group-list-plus + "l" #'gnus-group-list-plus + "c" #'gnus-group-list-plus + "?" #'gnus-group-list-plus + "!" #'gnus-group-list-plus)) + + "W" (define-keymap :prefix 'gnus-group-score-map + "f" #'gnus-score-flush-cache + "e" #'gnus-score-edit-all-score) + + "H" (define-keymap :prefix 'gnus-group-help-map + "d" #'gnus-group-describe-group + "v" #'gnus-version) + + "S" (define-keymap :prefix 'gnus-group-sub-map + "l" #'gnus-group-set-current-level + "t" #'gnus-group-toggle-subscription-at-point + "s" #'gnus-group-toggle-subscription + "k" #'gnus-group-kill-group + "y" #'gnus-group-yank-group + "w" #'gnus-group-kill-region + "C-k" #'gnus-group-kill-level + "z" #'gnus-group-kill-all-zombies)) (defun gnus-topic-mode-p () "Return non-nil in `gnus-topic-mode'." diff --git a/lisp/gnus/gnus-html.el b/lisp/gnus/gnus-html.el index be62bfd81f5..ef376f138e7 100644 --- a/lisp/gnus/gnus-html.el +++ b/lisp/gnus/gnus-html.el @@ -71,21 +71,17 @@ fit these criteria." :group 'gnus-art :type 'float) -(defvar gnus-html-image-map - (let ((map (make-sparse-keymap))) - (define-key map "u" 'gnus-article-copy-string) - (define-key map "i" 'gnus-html-insert-image) - (define-key map "v" 'gnus-html-browse-url) - map)) - -(defvar gnus-html-displayed-image-map - (let ((map (make-sparse-keymap))) - (define-key map "a" 'gnus-html-show-alt-text) - (define-key map "i" 'gnus-html-browse-image) - (define-key map "\r" 'gnus-html-browse-url) - (define-key map "u" 'gnus-article-copy-string) - (define-key map [tab] 'button-forward) - map)) +(defvar-keymap gnus-html-image-map + "u" #'gnus-article-copy-string + "i" #'gnus-html-insert-image + "v" #'gnus-html-browse-url) + +(defvar-keymap gnus-html-displayed-image-map + "a" #'gnus-html-show-alt-text + "i" #'gnus-html-browse-image + "RET" #'gnus-html-browse-url + "u" #'gnus-article-copy-string + "<tab>" #'forward-button) (defun gnus-html-encode-url (url) "Encode URL." diff --git a/lisp/gnus/gnus-icalendar.el b/lisp/gnus/gnus-icalendar.el index b6e5e7f786a..81e46d7a51e 100644 --- a/lisp/gnus/gnus-icalendar.el +++ b/lisp/gnus/gnus-icalendar.el @@ -194,7 +194,11 @@ (caddr event)))) (cl-labels - ((attendee-role (prop) (plist-get (cadr prop) 'ROLE)) + ((attendee-role (prop) + ;; RFC5546: default ROLE is REQ-PARTICIPANT + (and prop + (or (plist-get (cadr prop) 'ROLE) + "REQ-PARTICIPANT"))) (attendee-name (prop) (or (plist-get (cadr prop) 'CN) @@ -225,7 +229,10 @@ (gnus-icalendar-event--find-attendee ical attendee-name-or-email))) (attendee-names (gnus-icalendar-event--get-attendee-names ical)) - (role (plist-get (cadr attendee) 'ROLE)) + ;; RFC5546: default ROLE is REQ-PARTICIPANT + (role (and attendee + (or (plist-get (cadr attendee) 'ROLE) + "REQ-PARTICIPANT"))) (participation-type (pcase role ("REQ-PARTICIPANT" 'required) ("OPT-PARTICIPANT" 'optional) @@ -345,10 +352,16 @@ status will be retrieved from the first matching attendee record." (mapc #'process-event-line (split-string ical-request "\n")) + ;; RFC5546 refers to uninvited attendees as "party crashers". + ;; This situation is common if the invitation is sent to a group + ;; of people via a mailing list. (unless (gnus-icalendar-find-if (lambda (x) (string-match "^ATTENDEE" x)) reply-event-lines) (lwarn 'gnus-icalendar :warning - "Could not find an event attendee matching given identity")) + "Could not find an event attendee matching given identity") + (push (format "ATTENDEE;RSVP=TRUE;PARTSTAT=%s;CN=%s:MAILTO:%s" + attendee-status user-full-name user-mail-address) + reply-event-lines)) (mapconcat #'identity `("BEGIN:VEVENT" ,@(nreverse reply-event-lines) @@ -847,10 +860,14 @@ These will be used to retrieve the RSVP information from ical events." button t gnus-data ,data)))) -(defun gnus-icalendar-send-buffer-by-mail (buffer-name subject) +(defun gnus-icalendar-send-buffer-by-mail (buffer-name subject organizer) (let ((message-signature nil)) (with-current-buffer gnus-summary-buffer (gnus-summary-reply) + ;; Reply to the organizer, not to whoever sent the invitation. person + ;; Some calendar systems use specific email address as organizer to + ;; receive these responses. + (message-replace-header "To" organizer) (message-goto-body) (mml-insert-multipart "alternative") (mml-insert-empty-tag 'part 'type "text/plain") @@ -866,7 +883,8 @@ These will be used to retrieve the RSVP information from ical events." (event (caddr data)) (reply (gnus-icalendar-with-decoded-handle handle (gnus-icalendar-event-reply-from-buffer - (current-buffer) status (gnus-icalendar-identities))))) + (current-buffer) status (gnus-icalendar-identities)))) + (organizer (gnus-icalendar-event:organizer event))) (when reply (cl-labels @@ -883,7 +901,7 @@ These will be used to retrieve the RSVP information from ical events." (delete-region (point-min) (point-max)) (insert reply) (fold-icalendar-buffer) - (gnus-icalendar-send-buffer-by-mail (buffer-name) subject)) + (gnus-icalendar-send-buffer-by-mail (buffer-name) subject organizer)) ;; Back in article buffer (setq-local gnus-icalendar-reply-status status) @@ -897,10 +915,16 @@ These will be used to retrieve the RSVP information from ical events." (gnus-icalendar-event:sync-to-org event gnus-icalendar-reply-status)) (cl-defmethod gnus-icalendar-event:inline-reply-buttons ((event gnus-icalendar-event) handle) - (when (gnus-icalendar-event:rsvp event) - `(("Accept" gnus-icalendar-reply (,handle accepted ,event)) - ("Tentative" gnus-icalendar-reply (,handle tentative ,event)) - ("Decline" gnus-icalendar-reply (,handle declined ,event))))) + (let ((accept-btn "Accept") + (tentative-btn "Tentative") + (decline-btn "Decline")) + (unless (gnus-icalendar-event:rsvp event) + (setq accept-btn "Uninvited Accept" + tentative-btn "Uninvited Tentative" + decline-btn "Uninvited Decline")) + `((,accept-btn gnus-icalendar-reply (,handle accepted ,event)) + (,tentative-btn gnus-icalendar-reply (,handle tentative ,event)) + (,decline-btn gnus-icalendar-reply (,handle declined ,event))))) (cl-defmethod gnus-icalendar-event:inline-reply-buttons ((_event gnus-icalendar-event-reply) _handle) "No buttons for REPLY events." @@ -1038,13 +1062,14 @@ These will be used to retrieve the RSVP information from ical events." (add-to-list 'mm-automatic-display "text/calendar") (add-to-list 'mm-inline-media-tests '("text/calendar" gnus-icalendar-mm-inline identity)) - (gnus-define-keys (gnus-summary-calendar-map "i" gnus-summary-mode-map) - "a" gnus-icalendar-reply-accept - "t" gnus-icalendar-reply-tentative - "d" gnus-icalendar-reply-decline - "c" gnus-icalendar-event-check-agenda - "e" gnus-icalendar-event-export - "s" gnus-icalendar-event-show) + (define-key gnus-summary-mode-map "i" + (define-keymap :prefix 'gnus-summary-calendar-map + "a" #'gnus-icalendar-reply-accept + "t" #'gnus-icalendar-reply-tentative + "d" #'gnus-icalendar-reply-decline + "c" #'gnus-icalendar-event-check-agenda + "e" #'gnus-icalendar-event-export + "s" #'gnus-icalendar-event-show)) (require 'gnus-art) (add-to-list 'gnus-mime-action-alist diff --git a/lisp/gnus/gnus-kill.el b/lisp/gnus/gnus-kill.el index 525823e72ce..7137efd7309 100644 --- a/lisp/gnus/gnus-kill.el +++ b/lisp/gnus/gnus-kill.el @@ -66,18 +66,15 @@ of time." ;;; Gnus Kill File Mode ;;; -(defvar gnus-kill-file-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map emacs-lisp-mode-map) - (gnus-define-keymap map - "\C-c\C-k\C-s" gnus-kill-file-kill-by-subject - "\C-c\C-k\C-a" gnus-kill-file-kill-by-author - "\C-c\C-k\C-t" gnus-kill-file-kill-by-thread - "\C-c\C-k\C-x" gnus-kill-file-kill-by-xref - "\C-c\C-a" gnus-kill-file-apply-buffer - "\C-c\C-e" gnus-kill-file-apply-last-sexp - "\C-c\C-c" gnus-kill-file-exit) - map)) +(defvar-keymap gnus-kill-file-mode-map + :parent emacs-lisp-mode-map + "C-c C-k C-s" #'gnus-kill-file-kill-by-subject + "C-c C-k C-a" #'gnus-kill-file-kill-by-author + "C-c C-k C-t" #'gnus-kill-file-kill-by-thread + "C-c C-k C-x" #'gnus-kill-file-kill-by-xref + "C-c C-a" #'gnus-kill-file-apply-buffer + "C-c C-e" #'gnus-kill-file-apply-last-sexp + "C-c C-c" #'gnus-kill-file-exit) (define-derived-mode gnus-kill-file-mode emacs-lisp-mode "Kill" "Major mode for editing kill files. diff --git a/lisp/gnus/gnus-ml.el b/lisp/gnus/gnus-ml.el index ee3abf2f7be..a5358e9ff42 100644 --- a/lisp/gnus/gnus-ml.el +++ b/lisp/gnus/gnus-ml.el @@ -31,16 +31,13 @@ ;;; Mailing list minor mode -(defvar gnus-mailing-list-mode-map - (let ((map (make-sparse-keymap))) - (gnus-define-keys map - "\C-c\C-nh" gnus-mailing-list-help - "\C-c\C-ns" gnus-mailing-list-subscribe - "\C-c\C-nu" gnus-mailing-list-unsubscribe - "\C-c\C-np" gnus-mailing-list-post - "\C-c\C-no" gnus-mailing-list-owner - "\C-c\C-na" gnus-mailing-list-archive) - map)) +(defvar-keymap gnus-mailing-list-mode-map + "C-c C-n h" #'gnus-mailing-list-help + "C-c C-n s" #'gnus-mailing-list-subscribe + "C-c C-n u" #'gnus-mailing-list-unsubscribe + "C-c C-n p" #'gnus-mailing-list-post + "C-c C-n o" #'gnus-mailing-list-owner + "C-c C-n a" #'gnus-mailing-list-archive) (defvar gnus-mailing-list-menu) diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el index 8a3272042f3..c60faa13263 100644 --- a/lisp/gnus/gnus-msg.el +++ b/lisp/gnus/gnus-msg.el @@ -349,39 +349,39 @@ only affect the Gcc copy, but not the original message." ;;; Gnus Posting Functions ;;; -(gnus-define-keys (gnus-summary-send-map "S" gnus-summary-mode-map) - "p" gnus-summary-post-news - "i" gnus-summary-news-other-window - "f" gnus-summary-followup - "F" gnus-summary-followup-with-original - "c" gnus-summary-cancel-article - "s" gnus-summary-supersede-article - "r" gnus-summary-reply - "y" gnus-summary-yank-message - "R" gnus-summary-reply-with-original - "L" gnus-summary-reply-to-list-with-original - "w" gnus-summary-wide-reply - "W" gnus-summary-wide-reply-with-original - "v" gnus-summary-very-wide-reply - "V" gnus-summary-very-wide-reply-with-original - "n" gnus-summary-followup-to-mail - "N" gnus-summary-followup-to-mail-with-original - "m" gnus-summary-mail-other-window - "u" gnus-uu-post-news - "A" gnus-summary-attach-article - "\M-c" gnus-summary-mail-crosspost-complaint - "Br" gnus-summary-reply-broken-reply-to - "BR" gnus-summary-reply-broken-reply-to-with-original - "om" gnus-summary-mail-forward - "op" gnus-summary-post-forward - "Om" gnus-uu-digest-mail-forward - "Op" gnus-uu-digest-post-forward) - -(gnus-define-keys (gnus-send-bounce-map "D" gnus-summary-send-map) - "b" gnus-summary-resend-bounced-mail - ;; "c" gnus-summary-send-draft - "r" gnus-summary-resend-message - "e" gnus-summary-resend-message-edit) +(define-keymap :prefix 'gnus-summary-send-map + "p" #'gnus-summary-post-news + "i" #'gnus-summary-news-other-window + "f" #'gnus-summary-followup + "F" #'gnus-summary-followup-with-original + "c" #'gnus-summary-cancel-article + "s" #'gnus-summary-supersede-article + "r" #'gnus-summary-reply + "y" #'gnus-summary-yank-message + "R" #'gnus-summary-reply-with-original + "L" #'gnus-summary-reply-to-list-with-original + "w" #'gnus-summary-wide-reply + "W" #'gnus-summary-wide-reply-with-original + "v" #'gnus-summary-very-wide-reply + "V" #'gnus-summary-very-wide-reply-with-original + "n" #'gnus-summary-followup-to-mail + "N" #'gnus-summary-followup-to-mail-with-original + "m" #'gnus-summary-mail-other-window + "u" #'gnus-uu-post-news + "A" #'gnus-summary-attach-article + "M-c" #'gnus-summary-mail-crosspost-complaint + "B r" #'gnus-summary-reply-broken-reply-to + "B R" #'gnus-summary-reply-broken-reply-to-with-original + "o m" #'gnus-summary-mail-forward + "o p" #'gnus-summary-post-forward + "O m" #'gnus-uu-digest-mail-forward + "O p" #'gnus-uu-digest-post-forward + + "D" (define-keymap :prefix 'gnus-send-bounce-map + "b" #'gnus-summary-resend-bounced-mail + ;; "c" gnus-summary-send-draft + "r" #'gnus-summary-resend-message + "e" #'gnus-summary-resend-message-edit)) ;;; Internal functions. @@ -1305,7 +1305,7 @@ For the \"inline\" alternatives, also see the variable (gnus-inews-insert-gcc) (let ((gcc (message-unquote-tokens (message-tokenize-header (mail-fetch-field "gcc" nil t) - " ,"))) + ","))) (self (with-current-buffer gnus-summary-buffer gnus-gcc-self-resent-messages))) (message-remove-header "gcc") @@ -1572,7 +1572,7 @@ this is a reply." (message-remove-header "gcc") (widen) (setq groups (message-unquote-tokens - (message-tokenize-header gcc " ,\n\t"))) + (message-tokenize-header gcc ",\n\t"))) ;; Copy the article over to some group(s). (while (setq group (pop groups)) (setq method (gnus-inews-group-method group)) @@ -1748,7 +1748,7 @@ this is a reply." (concat "\"" str "\"") str))) (when groups - (insert " "))) + (insert ","))) (insert "\n"))))))) (defun gnus-mailing-list-followup-to () diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el index 9b76f983227..163d543afd1 100644 --- a/lisp/gnus/gnus-registry.el +++ b/lisp/gnus/gnus-registry.el @@ -847,7 +847,8 @@ Overrides existing keywords with FORCE set non-nil." (defun gnus-registry-register-message-ids () "Register the Message-ID of every article in the group." (unless (or (gnus-parameter-registry-ignore gnus-newsgroup-name) - (null gnus-registry-register-all)) + (null gnus-registry-register-all) + (null (eieio-object-p gnus-registry-db))) (dolist (article gnus-newsgroup-articles) (let* ((id (gnus-registry-fetch-message-id-fast article)) (groups (gnus-registry-get-id-key id 'group))) @@ -990,9 +991,9 @@ Uses `gnus-registry-marks' to find what shortcuts to install." gnus-registry-misc-menus) (gnus-message 9 "Defined mark handling function %s" function-name)))))) - (gnus-define-keys-1 - '(gnus-registry-mark-map "M" gnus-summary-mark-map) - keys-plist) + (define-key gnus-summary-mark-map "M" + (apply #'define-keymap :prefix 'gnus-summary-mark-map + keys-plist)) (add-hook 'gnus-summary-menu-hook (lambda () (easy-menu-add-item @@ -1142,7 +1143,7 @@ non-nil." entry) (while (car-safe old) (cl-incf count) - ;; don't use progress reporters for backwards compatibility + ;; todo: use progress reporters. (when (and (< 0 expected) (= 0 (mod count 100))) (message "importing: %d of %d (%.2f%%)" diff --git a/lisp/gnus/gnus-salt.el b/lisp/gnus/gnus-salt.el index dc81dfc5f6c..205e936bc7e 100644 --- a/lisp/gnus/gnus-salt.el +++ b/lisp/gnus/gnus-salt.el @@ -64,15 +64,12 @@ It accepts the same format specs that `gnus-summary-line-format' does." ;;; Internal variables. -(defvar gnus-pick-mode-map - (let ((map (make-sparse-keymap))) - (gnus-define-keys map - " " gnus-pick-next-page - "u" gnus-pick-unmark-article-or-thread - "." gnus-pick-article-or-thread - [down-mouse-2] gnus-pick-mouse-pick-region - "\r" gnus-pick-start-reading) - map)) +(defvar-keymap gnus-pick-mode-map + "SPC" #'gnus-pick-next-page + "u" #'gnus-pick-unmark-article-or-thread + "." #'gnus-pick-article-or-thread + "<down-mouse-2>" #'gnus-pick-mouse-pick-region + "RET" #'gnus-pick-start-reading) (defun gnus-pick-make-menu-bar () (unless (boundp 'gnus-pick-menu) @@ -315,11 +312,8 @@ This must be bound to a button-down mouse event." (defvar gnus-binary-mode-hook nil "Hook run in summary binary mode buffers.") -(defvar gnus-binary-mode-map - (let ((map (make-sparse-keymap))) - (gnus-define-keys map - "g" gnus-binary-show-article) - map)) +(defvar-keymap gnus-binary-mode-map + "g" #'gnus-binary-show-article) (defun gnus-binary-make-menu-bar () (unless (boundp 'gnus-binary-menu) @@ -424,21 +418,17 @@ Two predefined functions are available: (defvar gnus-tree-displayed-thread nil) (defvar gnus-tree-inhibit nil) -(defvar gnus-tree-mode-map - (let ((map (make-keymap))) - (suppress-keymap map) - (gnus-define-keys - map - "\r" gnus-tree-select-article - [mouse-2] gnus-tree-pick-article - "\C-?" gnus-tree-read-summary-keys - "h" gnus-tree-show-summary - - "\C-c\C-i" gnus-info-find-node) - - (substitute-key-definition - 'undefined 'gnus-tree-read-summary-keys map) - map)) +(defvar-keymap gnus-tree-mode-map + :full t :suppress t + "RET" #'gnus-tree-select-article + "<mouse-2>" #'gnus-tree-pick-article + "DEL" #'gnus-tree-read-summary-keys + "h" #'gnus-tree-show-summary + + "C-c C-i" #'gnus-info-find-node) + +(substitute-key-definition 'undefined #'gnus-tree-read-summary-keys + gnus-tree-mode-map) (defun gnus-tree-make-menu-bar () (unless (boundp 'gnus-tree-menu) diff --git a/lisp/gnus/gnus-score.el b/lisp/gnus/gnus-score.el index e0ad9f698d3..a25673a0e75 100644 --- a/lisp/gnus/gnus-score.el +++ b/lisp/gnus/gnus-score.el @@ -502,19 +502,20 @@ of the last successful match.") ;;; Summary mode score maps. -(gnus-define-keys (gnus-summary-score-map "V" gnus-summary-mode-map) - "s" gnus-summary-set-score - "S" gnus-summary-current-score - "c" gnus-score-change-score-file - "C" gnus-score-customize - "m" gnus-score-set-mark-below - "x" gnus-score-set-expunge-below - "R" gnus-summary-rescore - "e" gnus-score-edit-current-scores - "f" gnus-score-edit-file - "F" gnus-score-flush-cache - "t" gnus-score-find-trace - "w" gnus-score-find-favorite-words) +(define-key gnus-summary-mode-map "V" + (define-keymap :prefix 'gnus-summary-score-map + "s" #'gnus-summary-set-score + "S" #'gnus-summary-current-score + "c" #'gnus-score-change-score-file + "C" #'gnus-score-customize + "m" #'gnus-score-set-mark-below + "x" #'gnus-score-set-expunge-below + "R" #'gnus-summary-rescore + "e" #'gnus-score-edit-current-scores + "f" #'gnus-score-edit-file + "F" #'gnus-score-flush-cache + "t" #'gnus-score-find-trace + "w" #'gnus-score-find-favorite-words)) ;; Summary score file commands @@ -1748,7 +1749,7 @@ score in `gnus-newsgroup-scored' by SCORE." (setq type 'after match-func 'string< match (gnus-time-iso8601 - (time-subtract (current-time) + (time-subtract nil (* 86400 (nth 0 kill)))))) ((eq type 'before) (setq match-func 'gnus-string> @@ -1757,7 +1758,7 @@ score in `gnus-newsgroup-scored' by SCORE." (setq type 'before match-func 'gnus-string> match (gnus-time-iso8601 - (time-subtract (current-time) + (time-subtract nil (* 86400 (nth 0 kill)))))) ((eq type 'at) (setq match-func 'string= @@ -2561,16 +2562,17 @@ score in `gnus-newsgroup-scored' by SCORE." (or (caddr s) gnus-score-interactive-default-score)) trace)))) - (insert - "\n\nQuick help: + (insert + (substitute-command-keys + "\n\nQuick help: -Type `e' to edit score file corresponding to the score rule on current line, -`f' to format (pretty print) the score file and edit it, -`t' toggle to truncate long lines in this buffer, -`q' to quit, `k' to kill score trace buffer. +Type \\`e' to edit score file corresponding to the score rule on current line, +\\`f' to format (pretty print) the score file and edit it, +\\`t' toggle to truncate long lines in this buffer, +\\`q' to quit, \\`k' to kill score trace buffer. The first sexp on each line is the score rule, followed by the file name of -the score file and its full name, including the directory.") +the score file and its full name, including the directory.")) (goto-char (point-min)) (gnus-configure-windows 'score-trace))) (set-buffer gnus-summary-buffer) diff --git a/lisp/gnus/gnus-search.el b/lisp/gnus/gnus-search.el index 9c83d5fa376..a79c106062c 100644 --- a/lisp/gnus/gnus-search.el +++ b/lisp/gnus/gnus-search.el @@ -105,9 +105,13 @@ (gnus-add-shutdown #'gnus-search-shutdown 'gnus) -(define-error 'gnus-search-parse-error "Gnus search parsing error") +(define-error 'gnus-search-error "Gnus search error") -(define-error 'gnus-search-config-error "Gnus search configuration error") +(define-error 'gnus-search-parse-error "Gnus search parsing error" + 'gnus-search-error) + +(define-error 'gnus-search-config-error "Gnus search configuration error" + 'gnus-search-error) ;;; User Customizable Variables: @@ -568,9 +572,7 @@ REL-DATE, or (current-time) if REL-DATE is nil." ;; Time parsing doesn't seem to work with slashes. (let ((value (string-replace "/" "-" value)) (now (append '(0 0 0) - (seq-subseq (decode-time (or rel-date - (current-time))) - 3)))) + (seq-subseq (decode-time rel-date) 3)))) ;; Check for relative time parsing. (if (string-match "\\([[:digit:]]+\\)\\([dwmy]\\)" value) (seq-subseq @@ -1018,7 +1020,7 @@ Responsible for handling and, or, and parenthetical expressions.") (single-search (gnus-search-single-p query)) (grouplist (or groups (gnus-search-get-active srv))) q-string artlist group) - (message "Opening server %s" server) + (gnus-message 7 "Opening server %s" server) (gnus-open-server srv) ;; We should only be doing this once, in ;; `nnimap-open-connection', but it's too frustrating to try to @@ -1062,7 +1064,7 @@ Responsible for handling and, or, and parenthetical expressions.") (when (nnimap-change-group (gnus-group-short-name group) server) (with-current-buffer (nnimap-buffer) - (message "Searching %s..." group) + (gnus-message 7 "Searching %s..." group) (let ((result (gnus-search-imap-search-command engine q-string))) (when (car result) @@ -1075,7 +1077,7 @@ Responsible for handling and, or, and parenthetical expressions.") (vector group artn 100)))) (cdr (assoc "SEARCH" (cdr result)))) artlist)))) - (message "Searching %s...done" group)))) + (gnus-message 7 "Searching %s...done" group)))) (nreverse artlist)))) (cl-defmethod gnus-search-imap-search-command ((engine gnus-search-imap) @@ -1084,7 +1086,8 @@ Responsible for handling and, or, and parenthetical expressions.") Currently takes into account support for the LITERAL+ capability. Other capabilities could be tested here." (with-slots (literal-plus) engine - (when literal-plus + (when (and literal-plus + (string-match-p "\n" query)) (setq query (split-string query "\n"))) (cond ((consp query) @@ -1234,8 +1237,7 @@ nil (except that (dd nil yyyy) is not allowed). Massage those numbers into the most recent past occurrence of whichever date elements are present." (pcase-let ((`(,nday ,nmonth ,nyear) - (seq-subseq (decode-time (current-time)) - 3 6)) + (seq-subseq (decode-time) 3 6)) (`(,dday ,dmonth ,dyear) date)) (unless (and dday dmonth dyear) (unless dday (setq dday 1)) @@ -1329,8 +1331,8 @@ Returns a list of [group article score] vectors." (erase-buffer) (if groups - (message "Doing %s query on %s..." program groups) - (message "Doing %s query..." program)) + (gnus-message 7 "Doing %s query on %s..." program groups) + (gnus-message 7 "Doing %s query..." program)) (setq proc (apply #'start-process (format "search-%s" server) buffer program cp-list)) (while (process-live-p proc) @@ -1836,8 +1838,8 @@ Assume \"size\" key is equal to \"larger\"." (mapcar (lambda (x) (let ((group x) artlist) - (message "Searching %s using find-grep..." - (or group server)) + (gnus-message 7 "Searching %s using find-grep..." + (or group server)) (save-window-excursion (set-buffer buffer) (if (> gnus-verbose 6) @@ -1892,8 +1894,8 @@ Assume \"size\" key is equal to \"larger\"." (vector (gnus-group-full-name group server) art 0) artlist)) (forward-line 1))) - (message "Searching %s using find-grep...done" - (or group server)) + (gnus-message 7 "Searching %s using find-grep...done" + (or group server)) artlist))) grouplist)))) @@ -1926,7 +1928,7 @@ Assume \"size\" key is equal to \"larger\"." (apply #'nnheader-message 4 "Search engine for %s improperly configured: %s" server (cdr err)) - (signal 'gnus-search-config-error err))))) + (signal (car err) (cdr err)))))) (alist-get 'search-group-spec specs)) ;; Some search engines do their own limiting, but some don't, so ;; do it again here. This is bad because, if the user is diff --git a/lisp/gnus/gnus-srvr.el b/lisp/gnus/gnus-srvr.el index 5f2fc463330..fa880b7eddb 100644 --- a/lisp/gnus/gnus-srvr.el +++ b/lisp/gnus/gnus-srvr.el @@ -103,7 +103,43 @@ If nil, a faster, but more primitive, buffer is used instead." (defvar gnus-server-mode-line-format-spec nil) (defvar gnus-server-killed-servers nil) -(defvar gnus-server-mode-map nil) +(defvar-keymap gnus-server-mode-map + :full t :suppress t + "SPC" #'gnus-server-read-server-in-server-buffer + "RET" #'gnus-server-read-server + "<mouse-2>" #'gnus-server-pick-server + "q" #'gnus-server-exit + "l" #'gnus-server-list-servers + "k" #'gnus-server-kill-server + "y" #'gnus-server-yank-server + "c" #'gnus-server-copy-server + "a" #'gnus-server-add-server + "e" #'gnus-server-edit-server + "S" #'gnus-server-show-server + "s" #'gnus-server-scan-server + + "O" #'gnus-server-open-server + "M-o" #'gnus-server-open-all-servers + "C" #'gnus-server-close-server + "M-c" #'gnus-server-close-all-servers + "D" #'gnus-server-deny-server + "L" #'gnus-server-offline-server + "R" #'gnus-server-remove-denials + + "n" #'next-line + "p" #'previous-line + + "g" #'gnus-server-regenerate-server + + "G" #'gnus-group-read-ephemeral-search-group + + "z" #'gnus-server-compact-server + + "i" #'gnus-server-toggle-cloud-server + "I" #'gnus-server-set-cloud-method-server + + "C-c C-i" #'gnus-info-find-node + "C-c C-b" #'gnus-bug) (defcustom gnus-server-menu-hook nil "Hook run after the creation of the server mode menu." @@ -145,47 +181,6 @@ If nil, a faster, but more primitive, buffer is used instead." (gnus-run-hooks 'gnus-server-menu-hook))) -(unless gnus-server-mode-map - (setq gnus-server-mode-map (make-keymap)) - (suppress-keymap gnus-server-mode-map) - - (gnus-define-keys gnus-server-mode-map - " " gnus-server-read-server-in-server-buffer - "\r" gnus-server-read-server - [mouse-2] gnus-server-pick-server - "q" gnus-server-exit - "l" gnus-server-list-servers - "k" gnus-server-kill-server - "y" gnus-server-yank-server - "c" gnus-server-copy-server - "a" gnus-server-add-server - "e" gnus-server-edit-server - "S" gnus-server-show-server - "s" gnus-server-scan-server - - "O" gnus-server-open-server - "\M-o" gnus-server-open-all-servers - "C" gnus-server-close-server - "\M-c" gnus-server-close-all-servers - "D" gnus-server-deny-server - "L" gnus-server-offline-server - "R" gnus-server-remove-denials - - "n" next-line - "p" previous-line - - "g" gnus-server-regenerate-server - - "G" gnus-group-read-ephemeral-search-group - - "z" gnus-server-compact-server - - "i" gnus-server-toggle-cloud-server - "I" gnus-server-set-cloud-method-server - - "\C-c\C-i" gnus-info-find-node - "\C-c\C-b" gnus-bug)) - (defface gnus-server-agent '((((class color) (background light)) (:foreground "PaleTurquoise" :bold t)) (((class color) (background dark)) (:foreground "PaleTurquoise" :bold t)) @@ -697,37 +692,31 @@ claim them." function (repeat function))) -(defvar gnus-browse-mode-map nil) - -(unless gnus-browse-mode-map - (setq gnus-browse-mode-map (make-keymap)) - (suppress-keymap gnus-browse-mode-map) - - (gnus-define-keys - gnus-browse-mode-map - " " gnus-browse-read-group - "=" gnus-browse-select-group - "n" gnus-browse-next-group - "p" gnus-browse-prev-group - "\177" gnus-browse-prev-group - [delete] gnus-browse-prev-group - "N" gnus-browse-next-group - "P" gnus-browse-prev-group - "\M-n" gnus-browse-next-group - "\M-p" gnus-browse-prev-group - "\r" gnus-browse-select-group - "u" gnus-browse-toggle-subscription-at-point - "l" gnus-browse-exit - "L" gnus-browse-exit - "q" gnus-browse-exit - "Q" gnus-browse-exit - "d" gnus-browse-describe-group - [delete] gnus-browse-delete-group - "\C-c\C-c" gnus-browse-exit - "?" gnus-browse-describe-briefly - - "\C-c\C-i" gnus-info-find-node - "\C-c\C-b" gnus-bug)) +(defvar-keymap gnus-browse-mode-map + :full t :suppress t + "SPC" #'gnus-browse-read-group + "=" #'gnus-browse-select-group + "n" #'gnus-browse-next-group + "p" #'gnus-browse-prev-group + "DEL" #'gnus-browse-prev-group + "<delete>" #'gnus-browse-prev-group + "N" #'gnus-browse-next-group + "P" #'gnus-browse-prev-group + "M-n" #'gnus-browse-next-group + "M-p" #'gnus-browse-prev-group + "RET" #'gnus-browse-select-group + "u" #'gnus-browse-toggle-subscription-at-point + "l" #'gnus-browse-exit + "L" #'gnus-browse-exit + "q" #'gnus-browse-exit + "Q" #'gnus-browse-exit + "d" #'gnus-browse-describe-group + "<delete>" #'gnus-browse-delete-group + "C-c C-c" #'gnus-browse-exit + "?" #'gnus-browse-describe-briefly + + "C-c C-i" #'gnus-info-find-node + "C-c C-b" #'gnus-bug) (defun gnus-browse-make-menu-bar () (gnus-turn-off-edit-menu 'browse) diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el index c7be958edd1..606bd3a39a4 100644 --- a/lisp/gnus/gnus-start.el +++ b/lisp/gnus/gnus-start.el @@ -663,6 +663,7 @@ the first newsgroup." (defvar mail-sources) (defvar nnmail-scan-directory-mail-source-once) (defvar nnmail-split-history) +(defvar gnus-save-newsrc-file-last-timestamp nil) (defun gnus-close-all-servers () "Close all servers." @@ -707,6 +708,7 @@ the first newsgroup." gnus-current-select-method nil nnmail-split-history nil gnus-extended-servers nil + gnus-save-newsrc-file-last-timestamp nil gnus-ephemeral-servers nil) (gnus-shutdown 'gnus) ;; Kill the startup file. @@ -2731,7 +2733,6 @@ The form should return either t or nil." 'msdos-long-file-names (lambda () t)))) -(defvar gnus-save-newsrc-file-last-timestamp nil) (defun gnus-save-newsrc-file (&optional force) "Save .newsrc file. Use the group string names in `gnus-group-list' to pull info diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index d790655aa90..1bd0e8847e2 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -1907,485 +1907,483 @@ increase the score of each group you read." ;; Non-orthogonal keys -(gnus-define-keys gnus-summary-mode-map - " " gnus-summary-next-page - [?\S-\ ] gnus-summary-prev-page - "\177" gnus-summary-prev-page - [delete] gnus-summary-prev-page - "\r" gnus-summary-scroll-up - "\M-\r" gnus-summary-scroll-down - "n" gnus-summary-next-unread-article - "p" gnus-summary-prev-unread-article - "N" gnus-summary-next-article - "P" gnus-summary-prev-article - "\M-\C-n" gnus-summary-next-same-subject - "\M-\C-p" gnus-summary-prev-same-subject - "\M-n" gnus-summary-next-unread-subject - "\M-p" gnus-summary-prev-unread-subject - "." gnus-summary-first-unread-article - "," gnus-summary-best-unread-article - "[" gnus-summary-prev-unseen-article - "]" gnus-summary-next-unseen-article - "\M-s\M-s" gnus-summary-search-article-forward - "\M-s\M-r" gnus-summary-search-article-backward - "\M-r" gnus-summary-search-article-backward - "\M-S" gnus-summary-repeat-search-article-forward - "\M-R" gnus-summary-repeat-search-article-backward - "<" gnus-summary-beginning-of-article - ">" gnus-summary-end-of-article - "j" gnus-summary-goto-article - "^" gnus-summary-refer-parent-article - "\M-^" gnus-summary-refer-article - "u" gnus-summary-tick-article-forward - "!" gnus-summary-tick-article-forward - "U" gnus-summary-tick-article-backward - "d" gnus-summary-mark-as-read-forward - "D" gnus-summary-mark-as-read-backward - "E" gnus-summary-mark-as-expirable - "\M-u" gnus-summary-clear-mark-forward - "\M-U" gnus-summary-clear-mark-backward - "k" gnus-summary-kill-same-subject-and-select - "\C-k" gnus-summary-kill-same-subject - "\M-\C-k" gnus-summary-kill-thread - "\M-\C-l" gnus-summary-lower-thread - "e" gnus-summary-edit-article - "#" gnus-summary-mark-as-processable - "\M-#" gnus-summary-unmark-as-processable - "\M-\C-t" gnus-summary-toggle-threads - "\M-\C-s" gnus-summary-show-thread - "\M-\C-h" gnus-summary-hide-thread - "\M-\C-f" gnus-summary-next-thread - "\M-\C-b" gnus-summary-prev-thread - [(meta down)] gnus-summary-next-thread - [(meta up)] gnus-summary-prev-thread - "\M-\C-u" gnus-summary-up-thread - "\M-\C-d" gnus-summary-down-thread - "&" gnus-summary-execute-command - "c" gnus-summary-catchup-and-exit - "\C-w" gnus-summary-mark-region-as-read - "\C-t" toggle-truncate-lines - "?" gnus-summary-mark-as-dormant - "\C-c\M-\C-s" gnus-summary-limit-include-expunged - "\C-c\C-s\C-n" gnus-summary-sort-by-number - "\C-c\C-s\C-m\C-n" gnus-summary-sort-by-most-recent-number - "\C-c\C-s\C-l" gnus-summary-sort-by-lines - "\C-c\C-s\C-c" gnus-summary-sort-by-chars - "\C-c\C-s\C-m\C-m" gnus-summary-sort-by-marks - "\C-c\C-s\C-a" gnus-summary-sort-by-author - "\C-c\C-s\C-t" gnus-summary-sort-by-recipient - "\C-c\C-s\C-s" gnus-summary-sort-by-subject - "\C-c\C-s\C-d" gnus-summary-sort-by-date - "\C-c\C-s\C-m\C-d" gnus-summary-sort-by-most-recent-date - "\C-c\C-s\C-i" gnus-summary-sort-by-score - "\C-c\C-s\C-o" gnus-summary-sort-by-original - "\C-c\C-s\C-r" gnus-summary-sort-by-random - "\C-c\C-s\C-u" gnus-summary-sort-by-newsgroups - "\C-c\C-s\C-x" gnus-summary-sort-by-extra - "=" gnus-summary-expand-window - "\C-x\C-s" gnus-summary-reselect-current-group - "\M-g" gnus-summary-rescan-group - "\C-c\C-r" gnus-summary-caesar-message - "f" gnus-summary-followup - "F" gnus-summary-followup-with-original - "C" gnus-summary-cancel-article - "r" gnus-summary-reply - "R" gnus-summary-reply-with-original - "\C-c\C-f" gnus-summary-mail-forward - "o" gnus-summary-save-article - "\C-o" gnus-summary-save-article-mail - "|" gnus-summary-pipe-output - "\M-k" gnus-summary-edit-local-kill - "\M-K" gnus-summary-edit-global-kill +(define-keymap :keymap gnus-summary-mode-map + "SPC" #'gnus-summary-next-page + "S-SPC" #'gnus-summary-prev-page + "DEL" #'gnus-summary-prev-page + "<delete>" #'gnus-summary-prev-page + "RET" #'gnus-summary-scroll-up + "M-RET" #'gnus-summary-scroll-down + "n" #'gnus-summary-next-unread-article + "p" #'gnus-summary-prev-unread-article + "N" #'gnus-summary-next-article + "P" #'gnus-summary-prev-article + "C-M-n" #'gnus-summary-next-same-subject + "C-M-p" #'gnus-summary-prev-same-subject + "M-n" #'gnus-summary-next-unread-subject + "M-p" #'gnus-summary-prev-unread-subject + "." #'gnus-summary-first-unread-article + "," #'gnus-summary-best-unread-article + "[" #'gnus-summary-prev-unseen-article + "]" #'gnus-summary-next-unseen-article + "M-s M-s" #'gnus-summary-search-article-forward + "M-s M-r" #'gnus-summary-search-article-backward + "M-r" #'gnus-summary-search-article-backward + "M-S" #'gnus-summary-repeat-search-article-forward + "M-R" #'gnus-summary-repeat-search-article-backward + "<" #'gnus-summary-beginning-of-article + ">" #'gnus-summary-end-of-article + "j" #'gnus-summary-goto-article + "^" #'gnus-summary-refer-parent-article + "M-^" #'gnus-summary-refer-article + "u" #'gnus-summary-tick-article-forward + "!" #'gnus-summary-tick-article-forward + "U" #'gnus-summary-tick-article-backward + "d" #'gnus-summary-mark-as-read-forward + "D" #'gnus-summary-mark-as-read-backward + "E" #'gnus-summary-mark-as-expirable + "M-u" #'gnus-summary-clear-mark-forward + "M-U" #'gnus-summary-clear-mark-backward + "k" #'gnus-summary-kill-same-subject-and-select + "C-k" #'gnus-summary-kill-same-subject + "C-M-k" #'gnus-summary-kill-thread + "C-M-l" #'gnus-summary-lower-thread + "e" #'gnus-summary-edit-article + "#" #'gnus-summary-mark-as-processable + "M-#" #'gnus-summary-unmark-as-processable + "C-M-t" #'gnus-summary-toggle-threads + "C-M-s" #'gnus-summary-show-thread + "C-M-h" #'gnus-summary-hide-thread + "C-M-f" #'gnus-summary-next-thread + "C-M-b" #'gnus-summary-prev-thread + "M-<down>" #'gnus-summary-next-thread + "M-<up>" #'gnus-summary-prev-thread + "C-M-u" #'gnus-summary-up-thread + "C-M-d" #'gnus-summary-down-thread + "&" #'gnus-summary-execute-command + "c" #'gnus-summary-catchup-and-exit + "C-w" #'gnus-summary-mark-region-as-read + "C-t" #'toggle-truncate-lines + "?" #'gnus-summary-mark-as-dormant + "C-c C-M-s" #'gnus-summary-limit-include-expunged + "C-c C-s C-n" #'gnus-summary-sort-by-number + "C-c C-s C-m C-n" #'gnus-summary-sort-by-most-recent-number + "C-c C-s C-l" #'gnus-summary-sort-by-lines + "C-c C-s C-c" #'gnus-summary-sort-by-chars + "C-c C-s C-m C-m" #'gnus-summary-sort-by-marks + "C-c C-s C-a" #'gnus-summary-sort-by-author + "C-c C-s C-t" #'gnus-summary-sort-by-recipient + "C-c C-s C-s" #'gnus-summary-sort-by-subject + "C-c C-s C-d" #'gnus-summary-sort-by-date + "C-c C-s C-m C-d" #'gnus-summary-sort-by-most-recent-date + "C-c C-s C-i" #'gnus-summary-sort-by-score + "C-c C-s C-o" #'gnus-summary-sort-by-original + "C-c C-s C-r" #'gnus-summary-sort-by-random + "C-c C-s C-u" #'gnus-summary-sort-by-newsgroups + "C-c C-s C-x" #'gnus-summary-sort-by-extra + "=" #'gnus-summary-expand-window + "C-x C-s" #'gnus-summary-reselect-current-group + "M-g" #'gnus-summary-rescan-group + "C-c C-r" #'gnus-summary-caesar-message + "f" #'gnus-summary-followup + "F" #'gnus-summary-followup-with-original + "C" #'gnus-summary-cancel-article + "r" #'gnus-summary-reply + "R" #'gnus-summary-reply-with-original + "C-c C-f" #'gnus-summary-mail-forward + "o" #'gnus-summary-save-article + "C-o" #'gnus-summary-save-article-mail + "|" #'gnus-summary-pipe-output + "M-k" #'gnus-summary-edit-local-kill + "M-K" #'gnus-summary-edit-global-kill ;; "V" gnus-version - "\C-c\C-d" gnus-summary-describe-group - "\C-c\C-p" gnus-summary-make-group-from-search - "q" gnus-summary-exit - "Q" gnus-summary-exit-no-update - "\C-c\C-i" gnus-info-find-node - [mouse-2] gnus-mouse-pick-article - [follow-link] mouse-face - "m" gnus-summary-mail-other-window - "a" gnus-summary-post-news - "x" gnus-summary-limit-to-unread - "s" gnus-summary-isearch-article - "\t" gnus-summary-button-forward - [backtab] gnus-summary-button-backward - "w" gnus-summary-browse-url - "t" gnus-summary-toggle-header - "g" gnus-summary-show-article - "l" gnus-summary-goto-last-article - "\C-c\C-v\C-v" gnus-uu-decode-uu-view - "\C-d" gnus-summary-enter-digest-group - "\M-\C-d" gnus-summary-read-document - "\M-\C-e" gnus-summary-edit-parameters - "\M-\C-a" gnus-summary-customize-parameters - "\C-c\C-b" gnus-bug - "*" gnus-cache-enter-article - "\M-*" gnus-cache-remove-article - "\M-&" gnus-summary-universal-argument - "\C-l" gnus-recenter - "I" gnus-summary-increase-score - "L" gnus-summary-lower-score - "\M-i" gnus-symbolic-argument - "h" gnus-summary-select-article-buffer - - "b" gnus-article-view-part - "\M-t" gnus-summary-toggle-display-buttonized - - "V" gnus-summary-score-map - "X" gnus-uu-extract-map - "S" gnus-summary-send-map) - -;; Sort of orthogonal keymap -(gnus-define-keys (gnus-summary-mark-map "M" gnus-summary-mode-map) - "t" gnus-summary-tick-article-forward - "!" gnus-summary-tick-article-forward - "d" gnus-summary-mark-as-read-forward - "r" gnus-summary-mark-as-read-forward - "c" gnus-summary-clear-mark-forward - " " gnus-summary-clear-mark-forward - "e" gnus-summary-mark-as-expirable - "x" gnus-summary-mark-as-expirable - "?" gnus-summary-mark-as-dormant - "b" gnus-summary-set-bookmark - "B" gnus-summary-remove-bookmark - "#" gnus-summary-mark-as-processable - "\M-#" gnus-summary-unmark-as-processable - "S" gnus-summary-limit-include-expunged - "C" gnus-summary-catchup - "H" gnus-summary-catchup-to-here - "h" gnus-summary-catchup-from-here - "\C-c" gnus-summary-catchup-all - "k" gnus-summary-kill-same-subject-and-select - "K" gnus-summary-kill-same-subject - "P" gnus-uu-mark-map) - -(gnus-define-keys (gnus-summary-mscore-map "V" gnus-summary-mark-map) - "c" gnus-summary-clear-above - "u" gnus-summary-tick-above - "m" gnus-summary-mark-above - "k" gnus-summary-kill-below) - -(gnus-define-keys (gnus-summary-limit-map "/" gnus-summary-mode-map) - "/" gnus-summary-limit-to-subject - "n" gnus-summary-limit-to-articles - "b" gnus-summary-limit-to-bodies - "h" gnus-summary-limit-to-headers - "w" gnus-summary-pop-limit - "s" gnus-summary-limit-to-subject - "a" gnus-summary-limit-to-author - "u" gnus-summary-limit-to-unread - "m" gnus-summary-limit-to-marks - "M" gnus-summary-limit-exclude-marks - "v" gnus-summary-limit-to-score - "*" gnus-summary-limit-include-cached - "D" gnus-summary-limit-include-dormant - "T" gnus-summary-limit-include-thread - "d" gnus-summary-limit-exclude-dormant - "t" gnus-summary-limit-to-age - "." gnus-summary-limit-to-unseen - "x" gnus-summary-limit-to-extra - "p" gnus-summary-limit-to-display-predicate - "E" gnus-summary-limit-include-expunged - "c" gnus-summary-limit-exclude-childless-dormant - "C" gnus-summary-limit-mark-excluded-as-read - "o" gnus-summary-insert-old-articles - "N" gnus-summary-insert-new-articles - "S" gnus-summary-limit-to-singletons - "r" gnus-summary-limit-to-replied - "R" gnus-summary-limit-to-recipient - "A" gnus-summary-limit-to-address) - -(gnus-define-keys (gnus-summary-goto-map "G" gnus-summary-mode-map) - "n" gnus-summary-next-unread-article - "p" gnus-summary-prev-unread-article - "N" gnus-summary-next-article - "P" gnus-summary-prev-article - "\C-n" gnus-summary-next-same-subject - "\C-p" gnus-summary-prev-same-subject - "\M-n" gnus-summary-next-unread-subject - "\M-p" gnus-summary-prev-unread-subject - "f" gnus-summary-first-unread-article - "b" gnus-summary-best-unread-article - "u" gnus-summary-next-unseen-article - "U" gnus-summary-prev-unseen-article - "j" gnus-summary-goto-article - "g" gnus-summary-goto-subject - "l" gnus-summary-goto-last-article - "o" gnus-summary-pop-article) - -(gnus-define-keys (gnus-summary-thread-map "T" gnus-summary-mode-map) - "k" gnus-summary-kill-thread - "E" gnus-summary-expire-thread - "l" gnus-summary-lower-thread - "i" gnus-summary-raise-thread - "T" gnus-summary-toggle-threads - "t" gnus-summary-rethread-current - "^" gnus-summary-reparent-thread - "\M-^" gnus-summary-reparent-children - "s" gnus-summary-show-thread - "S" gnus-summary-show-all-threads - "h" gnus-summary-hide-thread - "H" gnus-summary-hide-all-threads - "n" gnus-summary-next-thread - "p" gnus-summary-prev-thread - "u" gnus-summary-up-thread - "o" gnus-summary-top-thread - "d" gnus-summary-down-thread - "#" gnus-uu-mark-thread - "\M-#" gnus-uu-unmark-thread) - -(gnus-define-keys (gnus-summary-buffer-map "Y" gnus-summary-mode-map) - "g" gnus-summary-prepare - "c" gnus-summary-insert-cached-articles - "d" gnus-summary-insert-dormant-articles - "t" gnus-summary-insert-ticked-articles) - -(gnus-define-keys (gnus-summary-exit-map "Z" gnus-summary-mode-map) - "c" gnus-summary-catchup-and-exit - "C" gnus-summary-catchup-all-and-exit - "E" gnus-summary-exit-no-update - "Q" gnus-summary-exit - "Z" gnus-summary-exit - "n" gnus-summary-catchup-and-goto-next-group - "p" gnus-summary-catchup-and-goto-prev-group - "R" gnus-summary-reselect-current-group - "G" gnus-summary-rescan-group - "N" gnus-summary-next-group - "s" gnus-summary-save-newsrc - "P" gnus-summary-prev-group) - -(gnus-define-keys (gnus-summary-article-map "A" gnus-summary-mode-map) - " " gnus-summary-next-page - "n" gnus-summary-next-page - [?\S-\ ] gnus-summary-prev-page - "\177" gnus-summary-prev-page - [delete] gnus-summary-prev-page - "p" gnus-summary-prev-page - "\r" gnus-summary-scroll-up - "\M-\r" gnus-summary-scroll-down - "<" gnus-summary-beginning-of-article - ">" gnus-summary-end-of-article - "b" gnus-summary-beginning-of-article - "e" gnus-summary-end-of-article - "^" gnus-summary-refer-parent-article - "r" gnus-summary-refer-parent-article - "C" gnus-summary-show-complete-article - "D" gnus-summary-enter-digest-group - "R" gnus-summary-refer-references - "T" gnus-summary-refer-thread - "W" gnus-warp-to-article - "g" gnus-summary-show-article - "s" gnus-summary-isearch-article - "\t" gnus-summary-button-forward - [backtab] gnus-summary-button-backward - "w" gnus-summary-browse-url - "P" gnus-summary-print-article - "S" gnus-sticky-article - "M" gnus-mailing-list-insinuate - "t" gnus-article-babel) - -(gnus-define-keys (gnus-summary-wash-map "W" gnus-summary-mode-map) - "b" gnus-article-add-buttons - "B" gnus-article-add-buttons-to-head - "o" gnus-article-treat-overstrike - "e" gnus-article-emphasize - "w" gnus-article-fill-cited-article - "Q" gnus-article-fill-long-lines - "L" gnus-article-toggle-truncate-lines - "C" gnus-article-capitalize-sentences - "c" gnus-article-remove-cr - "q" gnus-article-de-quoted-unreadable - "6" gnus-article-de-base64-unreadable - "Z" gnus-article-decode-HZ - "A" gnus-article-treat-ansi-sequences - "h" gnus-article-wash-html - "u" gnus-article-unsplit-urls - "s" gnus-summary-force-verify-and-decrypt - "f" gnus-article-display-x-face - "l" gnus-summary-stop-page-breaking - "r" gnus-summary-caesar-message - "m" gnus-summary-morse-message - "t" gnus-summary-toggle-header - "g" gnus-treat-smiley - "v" gnus-summary-verbose-headers - "a" gnus-article-strip-headers-in-body ;; mnemonic: wash archive - "p" gnus-article-verify-x-pgp-sig - "d" gnus-article-treat-smartquotes - "U" gnus-article-treat-non-ascii - "i" gnus-summary-idna-message) - -(gnus-define-keys (gnus-summary-wash-deuglify-map "Y" gnus-summary-wash-map) - ;; mnemonic: deuglif*Y* - "u" gnus-article-outlook-unwrap-lines - "a" gnus-article-outlook-repair-attribution - "c" gnus-article-outlook-rearrange-citation - "f" gnus-article-outlook-deuglify-article) ;; mnemonic: full deuglify - -(gnus-define-keys (gnus-summary-wash-hide-map "W" gnus-summary-wash-map) - "a" gnus-article-hide - "h" gnus-article-hide-headers - "b" gnus-article-hide-boring-headers - "s" gnus-article-hide-signature - "c" gnus-article-hide-citation - "C" gnus-article-hide-citation-in-followups - "l" gnus-article-hide-list-identifiers - "B" gnus-article-strip-banner - "P" gnus-article-hide-pem - "\C-c" gnus-article-hide-citation-maybe) - -(gnus-define-keys (gnus-summary-wash-highlight-map "H" gnus-summary-wash-map) - "a" gnus-article-highlight - "h" gnus-article-highlight-headers - "c" gnus-article-highlight-citation - "s" gnus-article-highlight-signature) - -(gnus-define-keys (gnus-summary-wash-header-map "G" gnus-summary-wash-map) - "f" gnus-article-treat-fold-headers - "u" gnus-article-treat-unfold-headers - "n" gnus-article-treat-fold-newsgroups) - -(gnus-define-keys (gnus-summary-wash-display-map "D" gnus-summary-wash-map) - "x" gnus-article-display-x-face - "d" gnus-article-display-face - "s" gnus-treat-smiley - "D" gnus-article-remove-images - "W" gnus-article-show-images - "F" gnus-article-toggle-fonts - "f" gnus-treat-from-picon - "m" gnus-treat-mail-picon - "n" gnus-treat-newsgroups-picon - "g" gnus-treat-from-gravatar - "h" gnus-treat-mail-gravatar) - -(gnus-define-keys (gnus-summary-wash-mime-map "M" gnus-summary-wash-map) - "w" gnus-article-decode-mime-words - "c" gnus-article-decode-charset - "h" gnus-mime-buttonize-attachments-in-header - "v" gnus-mime-view-all-parts - "b" gnus-article-view-part) - -(gnus-define-keys (gnus-summary-wash-time-map "T" gnus-summary-wash-map) - "z" gnus-article-date-ut - "u" gnus-article-date-ut - "l" gnus-article-date-local - "p" gnus-article-date-english - "e" gnus-article-date-lapsed - "o" gnus-article-date-original - "i" gnus-article-date-iso8601 - "s" gnus-article-date-user) - -(gnus-define-keys (gnus-summary-wash-empty-map "E" gnus-summary-wash-map) - "t" gnus-article-remove-trailing-blank-lines - "l" gnus-article-strip-leading-blank-lines - "m" gnus-article-strip-multiple-blank-lines - "a" gnus-article-strip-blank-lines - "A" gnus-article-strip-all-blank-lines - "s" gnus-article-strip-leading-space - "e" gnus-article-strip-trailing-space - "w" gnus-article-remove-leading-whitespace) - -(gnus-define-keys (gnus-summary-help-map "H" gnus-summary-mode-map) - "v" gnus-version - "d" gnus-summary-describe-group - "h" gnus-summary-describe-briefly - "i" gnus-info-find-node) - -(gnus-define-keys (gnus-summary-backend-map "B" gnus-summary-mode-map) - "e" gnus-summary-expire-articles - "\M-\C-e" gnus-summary-expire-articles-now - "\177" gnus-summary-delete-article - [delete] gnus-summary-delete-article - [backspace] gnus-summary-delete-article - "m" gnus-summary-move-article - "r" gnus-summary-respool-article - "w" gnus-summary-edit-article - "c" gnus-summary-copy-article - "B" gnus-summary-crosspost-article - "q" gnus-summary-respool-query - "t" gnus-summary-respool-trace - "i" gnus-summary-import-article - "I" gnus-summary-create-article - "p" gnus-summary-article-posted-p) - -(gnus-define-keys (gnus-summary-save-map "O" gnus-summary-mode-map) - "o" gnus-summary-save-article - "m" gnus-summary-save-article-mail - "F" gnus-summary-write-article-file - "r" gnus-summary-save-article-rmail - "f" gnus-summary-save-article-file - "b" gnus-summary-save-article-body-file - "B" gnus-summary-write-article-body-file - "h" gnus-summary-save-article-folder - "v" gnus-summary-save-article-vm - "p" gnus-summary-pipe-output - "P" gnus-summary-muttprint) - -(gnus-define-keys (gnus-summary-mime-map "K" gnus-summary-mode-map) - "b" gnus-summary-display-buttonized - "m" gnus-summary-repair-multipart - "v" gnus-article-view-part - "o" gnus-article-save-part - "O" gnus-article-save-part-and-strip - "r" gnus-article-replace-part - "d" gnus-article-delete-part - "t" gnus-article-view-part-as-type - "j" gnus-article-jump-to-part - "c" gnus-article-copy-part - "C" gnus-article-view-part-as-charset - "e" gnus-article-view-part-externally - "H" gnus-article-browse-html-article - "E" gnus-article-encrypt-body - "i" gnus-article-inline-part - "|" gnus-article-pipe-part) - -(gnus-define-keys (gnus-uu-mark-map "P" gnus-summary-mark-map) - "p" gnus-summary-mark-as-processable - "u" gnus-summary-unmark-as-processable - "U" gnus-summary-unmark-all-processable - "v" gnus-uu-mark-over - "s" gnus-uu-mark-series - "r" gnus-uu-mark-region - "g" gnus-uu-unmark-region - "R" gnus-uu-mark-by-regexp - "G" gnus-uu-unmark-by-regexp - "t" gnus-uu-mark-thread - "T" gnus-uu-unmark-thread - "a" gnus-uu-mark-all - "b" gnus-uu-mark-buffer - "S" gnus-uu-mark-sparse - "k" gnus-summary-kill-process-mark - "y" gnus-summary-yank-process-mark - "w" gnus-summary-save-process-mark - "i" gnus-uu-invert-processable) - -(gnus-define-keys (gnus-uu-extract-map "X" gnus-summary-mode-map) - ;;"x" gnus-uu-extract-any - "m" gnus-summary-save-parts - "u" gnus-uu-decode-uu - "U" gnus-uu-decode-uu-and-save - "s" gnus-uu-decode-unshar - "S" gnus-uu-decode-unshar-and-save - "o" gnus-uu-decode-save - "O" gnus-uu-decode-save - "b" gnus-uu-decode-binhex - "B" gnus-uu-decode-binhex - "Y" gnus-uu-decode-yenc - "p" gnus-uu-decode-postscript - "P" gnus-uu-decode-postscript-and-save) - -(gnus-define-keys - (gnus-uu-extract-view-map "v" gnus-uu-extract-map) - "u" gnus-uu-decode-uu-view - "U" gnus-uu-decode-uu-and-save-view - "s" gnus-uu-decode-unshar-view - "S" gnus-uu-decode-unshar-and-save-view - "o" gnus-uu-decode-save-view - "O" gnus-uu-decode-save-view - "b" gnus-uu-decode-binhex-view - "B" gnus-uu-decode-binhex-view - "p" gnus-uu-decode-postscript-view - "P" gnus-uu-decode-postscript-and-save-view) + "C-c C-d" #'gnus-summary-describe-group + "C-c C-p" #'gnus-summary-make-group-from-search + "q" #'gnus-summary-exit + "Q" #'gnus-summary-exit-no-update + "C-c C-i" #'gnus-info-find-node + "<mouse-2>" #'gnus-mouse-pick-article + "<follow-link>" 'mouse-face + "m" #'gnus-summary-mail-other-window + "a" #'gnus-summary-post-news + "x" #'gnus-summary-limit-to-unread + "s" #'gnus-summary-isearch-article + "TAB" #'gnus-summary-button-forward + "<backtab>" #'gnus-summary-button-backward + "w" #'gnus-summary-browse-url + "t" #'gnus-summary-toggle-header + "g" #'gnus-summary-show-article + "l" #'gnus-summary-goto-last-article + "C-c C-v C-v" #'gnus-uu-decode-uu-view + "C-d" #'gnus-summary-enter-digest-group + "C-M-d" #'gnus-summary-read-document + "C-M-e" #'gnus-summary-edit-parameters + "C-M-a" #'gnus-summary-customize-parameters + "C-c C-b" #'gnus-bug + "*" #'gnus-cache-enter-article + "M-*" #'gnus-cache-remove-article + "M-&" #'gnus-summary-universal-argument + "C-l" #'gnus-recenter + "I" #'gnus-summary-increase-score + "L" #'gnus-summary-lower-score + "M-i" #'gnus-symbolic-argument + "h" #'gnus-summary-select-article-buffer + + "b" #'gnus-article-view-part + "M-t" #'gnus-summary-toggle-display-buttonized + + "S" #'gnus-summary-send-map + + ;; Sort of orthogonal keymaps. + "M" (define-keymap :prefix 'gnus-summary-mark-map + "t" #'gnus-summary-tick-article-forward + "!" #'gnus-summary-tick-article-forward + "d" #'gnus-summary-mark-as-read-forward + "r" #'gnus-summary-mark-as-read-forward + "c" #'gnus-summary-clear-mark-forward + "SPC" #'gnus-summary-clear-mark-forward + "e" #'gnus-summary-mark-as-expirable + "x" #'gnus-summary-mark-as-expirable + "?" #'gnus-summary-mark-as-dormant + "b" #'gnus-summary-set-bookmark + "B" #'gnus-summary-remove-bookmark + "#" #'gnus-summary-mark-as-processable + "M-#" #'gnus-summary-unmark-as-processable + "S" #'gnus-summary-limit-include-expunged + "C" #'gnus-summary-catchup + "H" #'gnus-summary-catchup-to-here + "h" #'gnus-summary-catchup-from-here + "C-c" #'gnus-summary-catchup-all + "k" #'gnus-summary-kill-same-subject-and-select + "K" #'gnus-summary-kill-same-subject + + "P" (define-keymap :prefix 'gnus-uu-mark-map + "p" #'gnus-summary-mark-as-processable + "u" #'gnus-summary-unmark-as-processable + "U" #'gnus-summary-unmark-all-processable + "v" #'gnus-uu-mark-over + "s" #'gnus-uu-mark-series + "r" #'gnus-uu-mark-region + "g" #'gnus-uu-unmark-region + "R" #'gnus-uu-mark-by-regexp + "G" #'gnus-uu-unmark-by-regexp + "t" #'gnus-uu-mark-thread + "T" #'gnus-uu-unmark-thread + "a" #'gnus-uu-mark-all + "b" #'gnus-uu-mark-buffer + "S" #'gnus-uu-mark-sparse + "k" #'gnus-summary-kill-process-mark + "y" #'gnus-summary-yank-process-mark + "w" #'gnus-summary-save-process-mark + "i" #'gnus-uu-invert-processable) + + "V" (define-keymap :prefix 'gnus-summary-mscore-map + "c" #'gnus-summary-clear-above + "u" #'gnus-summary-tick-above + "m" #'gnus-summary-mark-above + "k" #'gnus-summary-kill-below)) + + "/" (define-keymap :prefix 'gnus-summary-limit-map + "/" #'gnus-summary-limit-to-subject + "n" #'gnus-summary-limit-to-articles + "b" #'gnus-summary-limit-to-bodies + "h" #'gnus-summary-limit-to-headers + "w" #'gnus-summary-pop-limit + "s" #'gnus-summary-limit-to-subject + "a" #'gnus-summary-limit-to-author + "u" #'gnus-summary-limit-to-unread + "m" #'gnus-summary-limit-to-marks + "M" #'gnus-summary-limit-exclude-marks + "v" #'gnus-summary-limit-to-score + "*" #'gnus-summary-limit-include-cached + "D" #'gnus-summary-limit-include-dormant + "T" #'gnus-summary-limit-include-thread + "d" #'gnus-summary-limit-exclude-dormant + "t" #'gnus-summary-limit-to-age + "." #'gnus-summary-limit-to-unseen + "x" #'gnus-summary-limit-to-extra + "p" #'gnus-summary-limit-to-display-predicate + "E" #'gnus-summary-limit-include-expunged + "c" #'gnus-summary-limit-exclude-childless-dormant + "C" #'gnus-summary-limit-mark-excluded-as-read + "o" #'gnus-summary-insert-old-articles + "N" #'gnus-summary-insert-new-articles + "S" #'gnus-summary-limit-to-singletons + "r" #'gnus-summary-limit-to-replied + "R" #'gnus-summary-limit-to-recipient + "A" #'gnus-summary-limit-to-address) + + "G" (define-keymap :prefix 'gnus-summary-goto-map + "n" #'gnus-summary-next-unread-article + "p" #'gnus-summary-prev-unread-article + "N" #'gnus-summary-next-article + "P" #'gnus-summary-prev-article + "C-n" #'gnus-summary-next-same-subject + "C-p" #'gnus-summary-prev-same-subject + "M-n" #'gnus-summary-next-unread-subject + "M-p" #'gnus-summary-prev-unread-subject + "f" #'gnus-summary-first-unread-article + "b" #'gnus-summary-best-unread-article + "u" #'gnus-summary-next-unseen-article + "U" #'gnus-summary-prev-unseen-article + "j" #'gnus-summary-goto-article + "g" #'gnus-summary-goto-subject + "l" #'gnus-summary-goto-last-article + "o" #'gnus-summary-pop-article) + + "T" (define-keymap :prefix 'gnus-summary-thread-map + "k" #'gnus-summary-kill-thread + "E" #'gnus-summary-expire-thread + "l" #'gnus-summary-lower-thread + "i" #'gnus-summary-raise-thread + "T" #'gnus-summary-toggle-threads + "t" #'gnus-summary-rethread-current + "^" #'gnus-summary-reparent-thread + "M-^" #'gnus-summary-reparent-children + "s" #'gnus-summary-show-thread + "S" #'gnus-summary-show-all-threads + "h" #'gnus-summary-hide-thread + "H" #'gnus-summary-hide-all-threads + "n" #'gnus-summary-next-thread + "p" #'gnus-summary-prev-thread + "u" #'gnus-summary-up-thread + "o" #'gnus-summary-top-thread + "d" #'gnus-summary-down-thread + "#" #'gnus-uu-mark-thread + "M-#" #'gnus-uu-unmark-thread) + + "Y" (define-keymap :prefix 'gnus-summary-buffer-map + "g" #'gnus-summary-prepare + "c" #'gnus-summary-insert-cached-articles + "d" #'gnus-summary-insert-dormant-articles + "t" #'gnus-summary-insert-ticked-articles) + + "Z" (define-keymap :prefix 'gnus-summary-exit-map + "c" #'gnus-summary-catchup-and-exit + "C" #'gnus-summary-catchup-all-and-exit + "E" #'gnus-summary-exit-no-update + "Q" #'gnus-summary-exit + "Z" #'gnus-summary-exit + "n" #'gnus-summary-catchup-and-goto-next-group + "p" #'gnus-summary-catchup-and-goto-prev-group + "R" #'gnus-summary-reselect-current-group + "G" #'gnus-summary-rescan-group + "N" #'gnus-summary-next-group + "s" #'gnus-summary-save-newsrc + "P" #'gnus-summary-prev-group) + + "A" (define-keymap :prefix 'gnus-summary-article-map + "SPC" #'gnus-summary-next-page + "n" #'gnus-summary-next-page + "S-SPC" #'gnus-summary-prev-page + "DEL" #'gnus-summary-prev-page + "<delete>" #'gnus-summary-prev-page + "p" #'gnus-summary-prev-page + "RET" #'gnus-summary-scroll-up + "M-RET" #'gnus-summary-scroll-down + "<" #'gnus-summary-beginning-of-article + ">" #'gnus-summary-end-of-article + "b" #'gnus-summary-beginning-of-article + "e" #'gnus-summary-end-of-article + "^" #'gnus-summary-refer-parent-article + "r" #'gnus-summary-refer-parent-article + "C" #'gnus-summary-show-complete-article + "D" #'gnus-summary-enter-digest-group + "R" #'gnus-summary-refer-references + "T" #'gnus-summary-refer-thread + "W" #'gnus-warp-to-article + "g" #'gnus-summary-show-article + "s" #'gnus-summary-isearch-article + "TAB" #'gnus-summary-button-forward + "<backtab>" #'gnus-summary-button-backward + "w" #'gnus-summary-browse-url + "P" #'gnus-summary-print-article + "S" #'gnus-sticky-article + "M" #'gnus-mailing-list-insinuate + "t" #'gnus-article-babel) + + "W" (define-keymap :prefix 'gnus-summary-wash-map + "b" #'gnus-article-add-buttons + "B" #'gnus-article-add-buttons-to-head + "o" #'gnus-article-treat-overstrike + "e" #'gnus-article-emphasize + "w" #'gnus-article-fill-cited-article + "Q" #'gnus-article-fill-long-lines + "L" #'gnus-article-toggle-truncate-lines + "C" #'gnus-article-capitalize-sentences + "c" #'gnus-article-remove-cr + "q" #'gnus-article-de-quoted-unreadable + "6" #'gnus-article-de-base64-unreadable + "Z" #'gnus-article-decode-HZ + "A" #'gnus-article-treat-ansi-sequences + "h" #'gnus-article-wash-html + "u" #'gnus-article-unsplit-urls + "s" #'gnus-summary-force-verify-and-decrypt + "f" #'gnus-article-display-x-face + "l" #'gnus-summary-stop-page-breaking + "r" #'gnus-summary-caesar-message + "m" #'gnus-summary-morse-message + "t" #'gnus-summary-toggle-header + "g" #'gnus-treat-smiley + "v" #'gnus-summary-verbose-headers + "a" #'gnus-article-strip-headers-in-body ;; mnemonic: wash archive + "p" #'gnus-article-verify-x-pgp-sig + "d" #'gnus-article-treat-smartquotes + "U" #'gnus-article-treat-non-ascii + "i" #'gnus-summary-idna-message + + "Y" (define-keymap :prefix 'gnus-summary-wash-deuglify-map + ;; mnemonic: deuglif*Y* + "u" #'gnus-article-outlook-unwrap-lines + "a" #'gnus-article-outlook-repair-attribution + "c" #'gnus-article-outlook-rearrange-citation + ;; mnemonic: full deuglify + "f" #'gnus-article-outlook-deuglify-article) + + "W" (define-keymap :prefix 'gnus-summary-wash-hide-map + "a" #'gnus-article-hide + "h" #'gnus-article-hide-headers + "b" #'gnus-article-hide-boring-headers + "s" #'gnus-article-hide-signature + "c" #'gnus-article-hide-citation + "C" #'gnus-article-hide-citation-in-followups + "l" #'gnus-article-hide-list-identifiers + "B" #'gnus-article-strip-banner + "P" #'gnus-article-hide-pem + "C-c" #'gnus-article-hide-citation-maybe) + + "H" (define-keymap :prefix 'gnus-summary-wash-highlight-map + "a" #'gnus-article-highlight + "h" #'gnus-article-highlight-headers + "c" #'gnus-article-highlight-citation + "s" #'gnus-article-highlight-signature) + + "G" (define-keymap :prefix 'gnus-summary-wash-header-map + "f" #'gnus-article-treat-fold-headers + "u" #'gnus-article-treat-unfold-headers + "n" #'gnus-article-treat-fold-newsgroups) + + "D" (define-keymap :prefix 'gnus-summary-wash-display-map + "x" #'gnus-article-display-x-face + "d" #'gnus-article-display-face + "s" #'gnus-treat-smiley + "e" #'gnus-article-emojize-symbols + "D" #'gnus-article-remove-images + "W" #'gnus-article-show-images + "F" #'gnus-article-toggle-fonts + "f" #'gnus-treat-from-picon + "m" #'gnus-treat-mail-picon + "n" #'gnus-treat-newsgroups-picon + "g" #'gnus-treat-from-gravatar + "h" #'gnus-treat-mail-gravatar) + + "M" (define-keymap :prefix 'gnus-summary-wash-mime-map + "w" #'gnus-article-decode-mime-words + "c" #'gnus-article-decode-charset + "h" #'gnus-mime-buttonize-attachments-in-header + "v" #'gnus-mime-view-all-parts + "b" #'gnus-article-view-part) + + "T" (define-keymap :prefix 'gnus-summary-wash-time-map + "z" #'gnus-article-date-ut + "u" #'gnus-article-date-ut + "l" #'gnus-article-date-local + "p" #'gnus-article-date-english + "e" #'gnus-article-date-lapsed + "o" #'gnus-article-date-original + "i" #'gnus-article-date-iso8601 + "s" #'gnus-article-date-user) + + "E" (define-keymap :prefix 'gnus-summary-wash-empty-map + "t" #'gnus-article-remove-trailing-blank-lines + "l" #'gnus-article-strip-leading-blank-lines + "m" #'gnus-article-strip-multiple-blank-lines + "a" #'gnus-article-strip-blank-lines + "A" #'gnus-article-strip-all-blank-lines + "s" #'gnus-article-strip-leading-space + "e" #'gnus-article-strip-trailing-space + "w" #'gnus-article-remove-leading-whitespace)) + + "H" (define-keymap :prefix 'gnus-summary-help-map + "v" #'gnus-version + "d" #'gnus-summary-describe-group + "h" #'gnus-summary-describe-briefly + "i" #'gnus-info-find-node) + + "B" (define-keymap :prefix 'gnus-summary-backend-map + "e" #'gnus-summary-expire-articles + "C-M-e" #'gnus-summary-expire-articles-now + "DEL" #'gnus-summary-delete-article + "<delete>" #'gnus-summary-delete-article + "<backspace>" #'gnus-summary-delete-article + "m" #'gnus-summary-move-article + "r" #'gnus-summary-respool-article + "w" #'gnus-summary-edit-article + "c" #'gnus-summary-copy-article + "B" #'gnus-summary-crosspost-article + "q" #'gnus-summary-respool-query + "t" #'gnus-summary-respool-trace + "i" #'gnus-summary-import-article + "I" #'gnus-summary-create-article + "p" #'gnus-summary-article-posted-p) + + "O" (define-keymap :prefix 'gnus-summary-save-map + "o" #'gnus-summary-save-article + "m" #'gnus-summary-save-article-mail + "F" #'gnus-summary-write-article-file + "r" #'gnus-summary-save-article-rmail + "f" #'gnus-summary-save-article-file + "b" #'gnus-summary-save-article-body-file + "B" #'gnus-summary-write-article-body-file + "h" #'gnus-summary-save-article-folder + "v" #'gnus-summary-save-article-vm + "p" #'gnus-summary-pipe-output + "P" #'gnus-summary-muttprint) + + "K" (define-keymap :prefix 'gnus-summary-mime-map + "b" #'gnus-summary-display-buttonized + "m" #'gnus-summary-repair-multipart + "v" #'gnus-article-view-part + "o" #'gnus-article-save-part + "O" #'gnus-article-save-part-and-strip + "r" #'gnus-article-replace-part + "d" #'gnus-article-delete-part + "t" #'gnus-article-view-part-as-type + "j" #'gnus-article-jump-to-part + "c" #'gnus-article-copy-part + "C" #'gnus-article-view-part-as-charset + "e" #'gnus-article-view-part-externally + "H" #'gnus-article-browse-html-article + "E" #'gnus-article-encrypt-body + "i" #'gnus-article-inline-part + "|" #'gnus-article-pipe-part) + + "X" (define-keymap :prefix 'gnus-uu-extract-map + ;;"x" gnus-uu-extract-any + "m" #'gnus-summary-save-parts + "u" #'gnus-uu-decode-uu + "U" #'gnus-uu-decode-uu-and-save + "s" #'gnus-uu-decode-unshar + "S" #'gnus-uu-decode-unshar-and-save + "o" #'gnus-uu-decode-save + "O" #'gnus-uu-decode-save + "b" #'gnus-uu-decode-binhex + "B" #'gnus-uu-decode-binhex + "Y" #'gnus-uu-decode-yenc + "p" #'gnus-uu-decode-postscript + "P" #'gnus-uu-decode-postscript-and-save + + "v" (define-keymap :prefix 'gnus-uu-extract-view-map + "u" #'gnus-uu-decode-uu-view + "U" #'gnus-uu-decode-uu-and-save-view + "s" #'gnus-uu-decode-unshar-view + "S" #'gnus-uu-decode-unshar-and-save-view + "o" #'gnus-uu-decode-save-view + "O" #'gnus-uu-decode-save-view + "b" #'gnus-uu-decode-binhex-view + "B" #'gnus-uu-decode-binhex-view + "p" #'gnus-uu-decode-postscript-view + "P" #'gnus-uu-decode-postscript-and-save-view))) (defvar gnus-article-post-menu nil) @@ -3970,10 +3968,9 @@ Returns \" ? \" if there's bad input or if another error occurs. Input should look like this: \"Sun, 14 Oct 2001 13:34:39 +0200\"." (condition-case () (let* ((messy-date (gnus-date-get-time messy-date)) - (now (current-time)) ;;If we don't find something suitable we'll use this one (my-format "%b %d '%y")) - (let* ((difference (time-subtract now messy-date)) + (let* ((difference (time-subtract nil messy-date)) (templist gnus-user-date-format-alist) (top (eval (caar templist) t))) (while (if (numberp top) (time-less-p top difference) (not top)) @@ -5004,23 +5001,13 @@ If LINE, insert the rebuilt thread starting on line LINE." gnus-article-sort-functions))) (gnus-message 7 "Sorting articles...done")))) -;; Written by Hallvard B Furuseth <h.b.furuseth@usit.uio.no>. -(defmacro gnus-thread-header (thread) - "Return header of first article in THREAD. -Note that THREAD must never, ever be anything else than a variable - -using some other form will lead to serious barfage." - (or (symbolp thread) (signal 'wrong-type-argument '(symbolp thread))) - ;; (8% speedup to gnus-summary-prepare, just for fun :-) - (cond - ((and (boundp 'lexical-binding) lexical-binding) - ;; FIXME: This version could be a "defsubst" rather than a macro. - `(#[257 "\211:\203\16\0\211@;\203\15\0A@@\207" - [] 2] - ,thread)) - (t - ;; Not sure how XEmacs handles these things, so let's keep the old code. - (list 'byte-code "\10\211:\203\17\0\211@;\203\16\0A@@\207" - (vector thread) 2)))) +(defsubst gnus-thread-header (thread) + "Return header of first article in THREAD." + (if (consp thread) + (car (if (stringp (car thread)) + (cadr thread) + thread)) + thread)) (defsubst gnus-article-sort-by-number (h1 h2) "Sort articles by article number." @@ -7208,7 +7195,6 @@ If FORCE (the prefix), also save the .newsrc file(s)." (gnus-dribble-save))) (declare-function gnus-cache-write-active "gnus-cache" (&optional force)) -(declare-function gnus-article-stop-animations "gnus-art" ()) (defun gnus-summary-exit (&optional temporary leave-hidden) "Exit reading current newsgroup, and then return to group selection mode. @@ -7272,7 +7258,6 @@ If FORCE (the prefix), also save the .newsrc file(s)." (not (string= group (gnus-group-group-name)))) (gnus-group-next-unread-group 1)) (setq group-point (point)) - (gnus-article-stop-animations) (unless leave-hidden (gnus-configure-windows 'group 'force)) (if temporary @@ -7332,7 +7317,6 @@ If FORCE (the prefix), also save the .newsrc file(s)." (run-hooks 'gnus-summary-prepare-exit-hook) (when (gnus-buffer-live-p gnus-article-buffer) (with-current-buffer gnus-article-buffer - (gnus-article-stop-animations) (gnus-stop-downloads) (mm-destroy-parts gnus-article-mime-handles) ;; Set it to nil for safety reason. @@ -7364,7 +7348,6 @@ If FORCE (the prefix), also save the .newsrc file(s)." (gnus-group-update-group group nil t)) (when (gnus-group-goto-group group) (gnus-group-next-unread-group 1)) - (gnus-article-stop-animations) (when quit-config (gnus-handle-ephemeral-exit quit-config))))) @@ -8067,9 +8050,7 @@ Return nil if there are no unread articles." Return nil if there are no unread articles." (interactive nil gnus-summary-mode) (prog1 - (when (gnus-summary-first-subject t) - (gnus-summary-show-thread) - (gnus-summary-first-subject t)) + (gnus-summary--goto-and-possibly-unhide t) (gnus-summary-position-point))) (defun gnus-summary-next-unseen-article (&optional backward) @@ -8103,23 +8084,27 @@ Return nil if there are no unread articles." Return nil if there are no unseen articles." (interactive nil gnus-summary-mode) (prog1 - (when (gnus-summary-first-subject nil nil t) - (gnus-summary-show-thread) - (gnus-summary-first-subject nil nil t)) + (gnus-summary--goto-and-possibly-unhide) (gnus-summary-position-point))) +(defun gnus-summary--goto-and-possibly-unhide (&optional unread undownloaded + unseen) + (let ((first (gnus-summary-first-subject unread undownloaded unseen))) + (if (and first + (not (= first (gnus-summary-article-number)))) + (progn + (gnus-summary-show-thread) + (gnus-summary-first-subject unread undownloaded unseen)) + first))) + (defun gnus-summary-first-unseen-or-unread-subject () "Place the point on the subject line of the first unseen and unread article. If all articles have been seen, on the subject line of the first unread article." (interactive nil gnus-summary-mode) (prog1 - (unless (when (gnus-summary-first-subject nil nil t) - (gnus-summary-show-thread) - (gnus-summary-first-subject nil nil t)) - (when (gnus-summary-first-subject t) - (gnus-summary-show-thread) - (gnus-summary-first-subject t))) + (unless (gnus-summary--goto-and-possibly-unhide nil nil t) + (gnus-summary-first-subject t)) (gnus-summary-position-point))) (defun gnus-summary-first-article () @@ -9908,7 +9893,6 @@ article. Normally, the keystroke is `\\[universal-argument] \\[gnus-summary-sho ;; Destroy any MIME parts. (when (gnus-buffer-live-p gnus-article-buffer) (with-current-buffer gnus-article-buffer - (gnus-article-stop-animations) (gnus-stop-downloads) (mm-destroy-parts gnus-article-mime-handles) ;; Set it to nil for safety reason. @@ -10501,7 +10485,6 @@ latter case, they will be copied into the relevant groups." "Create an article in a mail newsgroup." (interactive nil gnus-summary-mode) (let ((group gnus-newsgroup-name) - (now (current-time)) group-art) (unless (gnus-check-backend-function 'request-accept-article group) (error "%s does not support article importing" group)) @@ -10511,7 +10494,7 @@ latter case, they will be copied into the relevant groups." ;; This doesn't look like an article, so we fudge some headers. (insert "From: " (read-string "From: ") "\n" "Subject: " (read-string "Subject: ") "\n" - "Date: " (message-make-date now) "\n" + "Date: " (message-make-date) "\n" "Message-ID: " (message-make-message-id) "\n") (setq group-art (gnus-request-accept-article group nil t)) (kill-buffer (current-buffer))) diff --git a/lisp/gnus/gnus-topic.el b/lisp/gnus/gnus-topic.el index c8bcccdfdde..0855e98917f 100644 --- a/lisp/gnus/gnus-topic.el +++ b/lisp/gnus/gnus-topic.el @@ -1056,63 +1056,56 @@ articles in the topic and its subtopics." ;;; Topic mode, commands and keymap. -(defvar gnus-topic-mode-map nil) -(defvar gnus-group-topic-map nil) - -(unless gnus-topic-mode-map - (setq gnus-topic-mode-map (make-sparse-keymap)) - +(defvar-keymap gnus-topic-mode-map ;; Override certain group mode keys. - (gnus-define-keys gnus-topic-mode-map - "=" gnus-topic-select-group - "\r" gnus-topic-select-group - " " gnus-topic-read-group - "\C-c\C-x" gnus-topic-expire-articles - "c" gnus-topic-catchup-articles - "\C-k" gnus-topic-kill-group - "\C-y" gnus-topic-yank-group - "\M-g" gnus-topic-get-new-news-this-topic - "AT" gnus-topic-list-active - "Gp" gnus-topic-edit-parameters - "#" gnus-topic-mark-topic - "\M-#" gnus-topic-unmark-topic - [tab] gnus-topic-indent - [(meta tab)] gnus-topic-unindent - "\C-i" gnus-topic-indent - "\M-\C-i" gnus-topic-unindent - [mouse-2] gnus-mouse-pick-topic) - - ;; Define a new submap. - (gnus-define-keys (gnus-group-topic-map "T" gnus-group-mode-map) - "#" gnus-topic-mark-topic - "\M-#" gnus-topic-unmark-topic - "n" gnus-topic-create-topic - "m" gnus-topic-move-group - "D" gnus-topic-remove-group - "c" gnus-topic-copy-group - "h" gnus-topic-hide-topic - "s" gnus-topic-show-topic - "j" gnus-topic-jump-to-topic - "M" gnus-topic-move-matching - "C" gnus-topic-copy-matching - "\M-p" gnus-topic-goto-previous-topic - "\M-n" gnus-topic-goto-next-topic - "\C-i" gnus-topic-indent - [tab] gnus-topic-indent - "r" gnus-topic-rename - "\177" gnus-topic-delete - [delete] gnus-topic-delete - "H" gnus-topic-toggle-display-empty-topics) - - (gnus-define-keys (gnus-topic-sort-map "S" gnus-group-topic-map) - "s" gnus-topic-sort-groups - "a" gnus-topic-sort-groups-by-alphabet - "u" gnus-topic-sort-groups-by-unread - "l" gnus-topic-sort-groups-by-level - "e" gnus-topic-sort-groups-by-server - "v" gnus-topic-sort-groups-by-score - "r" gnus-topic-sort-groups-by-rank - "m" gnus-topic-sort-groups-by-method)) + "=" #'gnus-topic-select-group + "RET" #'gnus-topic-select-group + "SPC" #'gnus-topic-read-group + "C-c C-x" #'gnus-topic-expire-articles + "c" #'gnus-topic-catchup-articles + "C-k" #'gnus-topic-kill-group + "C-y" #'gnus-topic-yank-group + "M-g" #'gnus-topic-get-new-news-this-topic + "A T" #'gnus-topic-list-active + "G p" #'gnus-topic-edit-parameters + "#" #'gnus-topic-mark-topic + "M-#" #'gnus-topic-unmark-topic + "<tab>" #'gnus-topic-indent + "M-<tab>" #'gnus-topic-unindent + "TAB" #'gnus-topic-indent + "C-M-i" #'gnus-topic-unindent + "<mouse-2>" #'gnus-mouse-pick-topic + + "T" (define-keymap :prefix 'gnus-group-topic-map + "#" #'gnus-topic-mark-topic + "M-#" #'gnus-topic-unmark-topic + "n" #'gnus-topic-create-topic + "m" #'gnus-topic-move-group + "D" #'gnus-topic-remove-group + "c" #'gnus-topic-copy-group + "h" #'gnus-topic-hide-topic + "s" #'gnus-topic-show-topic + "j" #'gnus-topic-jump-to-topic + "M" #'gnus-topic-move-matching + "C" #'gnus-topic-copy-matching + "M-p" #'gnus-topic-goto-previous-topic + "M-n" #'gnus-topic-goto-next-topic + "TAB" #'gnus-topic-indent + "<tab>" #'gnus-topic-indent + "r" #'gnus-topic-rename + "DEL" #'gnus-topic-delete + "<delete>" #'gnus-topic-delete + "H" #'gnus-topic-toggle-display-empty-topics + + "S" (define-keymap :prefix 'gnus-topic-sort-map + "s" #'gnus-topic-sort-groups + "a" #'gnus-topic-sort-groups-by-alphabet + "u" #'gnus-topic-sort-groups-by-unread + "l" #'gnus-topic-sort-groups-by-level + "e" #'gnus-topic-sort-groups-by-server + "v" #'gnus-topic-sort-groups-by-score + "r" #'gnus-topic-sort-groups-by-rank + "m" #'gnus-topic-sort-groups-by-method))) (defun gnus-topic-make-menu-bar () (unless (boundp 'gnus-topic-menu) diff --git a/lisp/gnus/gnus-undo.el b/lisp/gnus/gnus-undo.el index 07cf5d495a6..a82b1f87a3e 100644 --- a/lisp/gnus/gnus-undo.el +++ b/lisp/gnus/gnus-undo.el @@ -75,15 +75,12 @@ ;;; Minor mode definition. -(defvar gnus-undo-mode-map - (let ((map (make-sparse-keymap))) - (gnus-define-keys map - "\M-\C-_" gnus-undo - "\C-_" gnus-undo - "\C-xu" gnus-undo - ;; Many people are used to type `C-/' on GUI frames and get `C-_'. - [(control /)] gnus-undo) - map)) +(defvar-keymap gnus-undo-mode-map + "C-M-_" #'gnus-undo + "C-_" #'gnus-undo + "C-x u" #'gnus-undo + ;; many people are used to type `C-/' on GUI frames and get `C-_'. + "C-/" #'gnus-undo) (defun gnus-undo-make-menu-bar () ;; This is disabled for the time being. diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index fb285962d6f..a777157f894 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -300,25 +300,26 @@ Symbols are also allowed; their print names are used instead." (defmacro gnus-local-set-keys (&rest plist) "Set the keys in PLIST in the current keymap." - (declare (indent 1)) + (declare (obsolete define-keymap "29.1") (indent 1)) `(gnus-define-keys-1 (current-local-map) ',plist)) (defmacro gnus-define-keys (keymap &rest plist) "Define all keys in PLIST in KEYMAP." - (declare (indent 1)) + (declare (obsolete define-keymap "29.1") (indent 1)) `(gnus-define-keys-1 ,(if (symbolp keymap) keymap `',keymap) (quote ,plist))) (defmacro gnus-define-keys-safe (keymap &rest plist) "Define all keys in PLIST in KEYMAP without overwriting previous definitions." - (declare (indent 1)) + (declare (obsolete define-keymap "29.1") (indent 1)) `(gnus-define-keys-1 (quote ,keymap) (quote ,plist) t)) (defmacro gnus-define-keymap (keymap &rest plist) "Define all keys in PLIST in KEYMAP." - (declare (indent 1)) + (declare (obsolete define-keymap "29.1") (indent 1)) `(gnus-define-keys-1 ,keymap (quote ,plist))) (defun gnus-define-keys-1 (keymap plist &optional safe) + (declare (obsolete define-keymap "29.1")) (when (null keymap) (error "Can't set keys in a null keymap")) (cond ((symbolp keymap) (error "First arg should be a keymap object")) @@ -1310,9 +1311,7 @@ SPEC is a predicate specifier that contains stuff like `or', `and', initial-input history def) "Call `gnus-completing-read-function'." (funcall gnus-completing-read-function - (concat prompt (when def - (concat " (default " def ")")) - ": ") + (format-prompt prompt def) collection require-match initial-input history def)) (defun gnus-emacs-completing-read (prompt collection &optional require-match diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index 1d19a2ac565..afe07ee46f9 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -1467,11 +1467,11 @@ address was listed in gnus-group-split Addresses (see below).") :variable-group gnus-group-parameter :parameter-type '(gnus-email-address :tag "To List") :parameter-document "\ -This address will be used when doing a `a' in the group. +This address will be used when doing a \\`a' in the group. It is totally ignored when doing a followup--except that if it is present in a news group, you'll get mail group semantics when doing -`f'. +\\`f'. The gnus-group-split mail splitting mechanism will behave as if this address was listed in gnus-group-split Addresses (see below).") @@ -2537,7 +2537,7 @@ are always t.") ;; Only used in gnus-util, which has an autoload. ("rmailsum" rmail-update-summary) ("gnus-xmas" gnus-xmas-splash) - ("score-mode" :interactive t gnus-score-mode) + ("score-mode" :interactive t gnus-score-mode gnus-score-edit-all-score) ("gnus-mh" gnus-summary-save-article-folder gnus-Folder-save-name gnus-folder-save-name) ("gnus-mh" :interactive (gnus-summary-mode) gnus-summary-save-in-folder) @@ -2609,7 +2609,11 @@ are always t.") gnus-uu-decode-uu-and-save-view gnus-uu-decode-unshar-view gnus-uu-decode-unshar-and-save-view gnus-uu-decode-save-view gnus-uu-decode-binhex-view gnus-uu-unmark-thread - gnus-uu-mark-over gnus-uu-post-news gnus-uu-invert-processable) + gnus-uu-mark-over gnus-uu-post-news gnus-uu-invert-processable + gnus-uu-decode-postscript-and-save-view + gnus-uu-decode-postscript-view gnus-uu-decode-postscript-and-save + gnus-uu-decode-yenc gnus-uu-unmark-by-regexp gnus-uu-unmark-region + gnus-uu-decode-postscript) ("gnus-uu" gnus-uu-delete-work-dir gnus-uu-unmark-thread) ("gnus-msg" (gnus-summary-send-map keymap) gnus-article-mail gnus-copy-article-buffer gnus-extended-version) @@ -2656,6 +2660,7 @@ are always t.") gnus-article-hide-headers gnus-article-hide-boring-headers gnus-article-treat-overstrike gnus-article-remove-cr gnus-article-remove-trailing-blank-lines + gnus-article-emojize-symbols gnus-article-display-x-face gnus-article-de-quoted-unreadable gnus-article-de-base64-unreadable gnus-article-decode-HZ @@ -2667,7 +2672,34 @@ are always t.") gnus-article-edit-mode gnus-article-edit-article gnus-article-edit-done gnus-article-decode-encoded-words gnus-start-date-timer gnus-stop-date-timer - gnus-mime-view-all-parts) + gnus-mime-view-all-parts gnus-article-pipe-part + gnus-article-inline-part gnus-article-encrypt-body + gnus-article-browse-html-article gnus-article-view-part-externally + gnus-article-view-part-as-charset gnus-article-copy-part + gnus-article-jump-to-part gnus-article-view-part-as-type + gnus-article-delete-part gnus-article-replace-part + gnus-article-save-part-and-strip gnus-article-save-part + gnus-article-remove-leading-whitespace gnus-article-strip-trailing-space + gnus-article-strip-leading-space gnus-article-strip-all-blank-lines + gnus-article-strip-blank-lines gnus-article-strip-multiple-blank-lines + gnus-article-date-user gnus-article-date-iso8601 + gnus-article-date-english gnus-article-date-ut + gnus-article-decode-charset gnus-article-decode-mime-words + gnus-article-toggle-fonts gnus-article-show-images + gnus-article-remove-images gnus-article-display-face + gnus-article-treat-fold-newsgroups gnus-article-treat-unfold-headers + gnus-article-treat-fold-headers gnus-article-highlight-signature + gnus-article-highlight-headers gnus-article-highlight + gnus-article-strip-banner gnus-article-hide-list-identifiers + gnus-article-hide gnus-article-outlook-rearrange-citation + gnus-article-treat-non-ascii gnus-article-treat-smartquotes + gnus-article-verify-x-pgp-sig gnus-article-strip-headers-in-body + gnus-treat-smiley gnus-article-treat-ansi-sequences + gnus-article-capitalize-sentences gnus-article-toggle-truncate-lines + gnus-article-fill-long-lines gnus-article-emphasize + gnus-article-add-buttons-to-head gnus-article-add-button + gnus-article-babel gnus-sticky-article gnus-article-view-part + gnus-article-add-buttons) ("gnus-int" gnus-request-type) ("gnus-start" gnus-newsrc-parse-options gnus-1 gnus-no-server-1 gnus-dribble-enter gnus-read-init-file gnus-dribble-touch @@ -3118,9 +3150,9 @@ g -- Group name." "Check whether GROUP supports function FUNC. GROUP can either be a string (a group name) or a select method." (ignore-errors - (let ((method (if (stringp group) - (car (gnus-find-method-for-group group)) - group))) + (when-let ((method (if (stringp group) + (car (gnus-find-method-for-group group)) + group))) (unless (featurep method) (require method)) (fboundp (intern (format "%s-%s" method func)))))) @@ -3754,6 +3786,8 @@ just the host name." (setq foreign server group (substring group (+ 1 colon)))) (setq foreign (concat foreign ":"))) + ;; Remove braces from name (common in IMAP groups). + (setq group (replace-regexp-in-string "[][]+" "" group)) ;; Collapse group name leaving LEVELS uncollapsed elements (let* ((slist (split-string group "/")) (slen (length slist)) diff --git a/lisp/gnus/mail-source.el b/lisp/gnus/mail-source.el index af0a1983766..efdddea69f6 100644 --- a/lisp/gnus/mail-source.el +++ b/lisp/gnus/mail-source.el @@ -224,12 +224,9 @@ Leave mails for this many days" :value 14))))) (const :format "" :value :plugged) (boolean :tag "Plugged")))))))) -(defcustom mail-source-ignore-errors nil - "Ignore errors when querying mail sources. -If nil, the user will be prompted when an error occurs. If non-nil, -the error will be ignored." - :version "22.1" - :type 'boolean) +(make-obsolete-variable 'mail-source-ignore-errors + "configure `gnus-verbose' instead" + "29.1") (defcustom mail-source-primary-source nil "Primary source for incoming mail. @@ -554,18 +551,16 @@ Return the number of files that were found." (condition-case err (funcall function source callback) (error - (if (and (not mail-source-ignore-errors) - (not - (yes-or-no-p - (format "Mail source %s error (%s). Continue? " + (gnus-error + 5 + (format "Mail source %s error (%s)" (if (memq ':password source) (let ((s (copy-sequence source))) (setcar (cdr (memq ':password s)) "********") s) source) - (cadr err))))) - (error "Cannot get new mail")) + (cadr err))) 0))))))))) (declare-function gnus-message "gnus-util" (level &rest args)) diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index bbf1c78a01f..c2d14296f94 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -48,6 +48,8 @@ (require 'puny) (require 'rmc) ; read-multiple-choice (require 'subr-x) +(require 'yank-media) +(require 'mailcap) (autoload 'mailclient-send-it "mailclient") @@ -2870,84 +2872,78 @@ Consider adding this function to `message-header-setup-hook'" ;;; Set up keymap. -(defvar message-mode-map nil) - -(unless message-mode-map - (setq message-mode-map (make-keymap)) - (set-keymap-parent message-mode-map text-mode-map) - (define-key message-mode-map "\C-c?" #'describe-mode) - - (define-key message-mode-map "\C-c\C-f\C-t" #'message-goto-to) - (define-key message-mode-map "\C-c\C-f\C-o" #'message-goto-from) - (define-key message-mode-map "\C-c\C-f\C-b" #'message-goto-bcc) - (define-key message-mode-map "\C-c\C-f\C-w" #'message-goto-fcc) - (define-key message-mode-map "\C-c\C-f\C-c" #'message-goto-cc) - (define-key message-mode-map "\C-c\C-f\C-s" #'message-goto-subject) - (define-key message-mode-map "\C-c\C-f\C-r" #'message-goto-reply-to) - (define-key message-mode-map "\C-c\C-f\C-n" #'message-goto-newsgroups) - (define-key message-mode-map "\C-c\C-f\C-d" #'message-goto-distribution) - (define-key message-mode-map "\C-c\C-f\C-f" #'message-goto-followup-to) - (define-key message-mode-map "\C-c\C-f\C-m" #'message-goto-mail-followup-to) - (define-key message-mode-map "\C-c\C-f\C-k" #'message-goto-keywords) - (define-key message-mode-map "\C-c\C-f\C-u" #'message-goto-summary) - (define-key message-mode-map "\C-c\C-f\C-i" - #'message-insert-or-toggle-importance) - (define-key message-mode-map "\C-c\C-f\C-a" - #'message-generate-unsubscribed-mail-followup-to) +(defvar-keymap message-mode-map + :full t :parent text-mode-map + :doc "Message Mode keymap." + "C-c ?" #'describe-mode + + "C-c C-f C-t" #'message-goto-to + "C-c C-f C-o" #'message-goto-from + "C-c C-f C-b" #'message-goto-bcc + "C-c C-f C-w" #'message-goto-fcc + "C-c C-f C-c" #'message-goto-cc + "C-c C-f C-s" #'message-goto-subject + "C-c C-f C-r" #'message-goto-reply-to + "C-c C-f C-n" #'message-goto-newsgroups + "C-c C-f C-d" #'message-goto-distribution + "C-c C-f C-f" #'message-goto-followup-to + "C-c C-f C-m" #'message-goto-mail-followup-to + "C-c C-f C-k" #'message-goto-keywords + "C-c C-f C-u" #'message-goto-summary + "C-c C-f C-i" #'message-insert-or-toggle-importance + "C-c C-f C-a" #'message-generate-unsubscribed-mail-followup-to ;; modify headers (and insert notes in body) - (define-key message-mode-map "\C-c\C-fs" #'message-change-subject) + "C-c C-f s" #'message-change-subject ;; - (define-key message-mode-map "\C-c\C-fx" #'message-cross-post-followup-to) + "C-c C-f x" #'message-cross-post-followup-to ;; prefix+message-cross-post-followup-to = same w/o cross-post - (define-key message-mode-map "\C-c\C-ft" #'message-reduce-to-to-cc) - (define-key message-mode-map "\C-c\C-fa" #'message-add-archive-header) + "C-c C-f t" #'message-reduce-to-to-cc + "C-c C-f a" #'message-add-archive-header ;; mark inserted text - (define-key message-mode-map "\C-c\M-m" #'message-mark-inserted-region) - (define-key message-mode-map "\C-c\M-f" #'message-mark-insert-file) - - (define-key message-mode-map "\C-c\C-b" #'message-goto-body) - (define-key message-mode-map "\C-c\C-i" #'message-goto-signature) - - (define-key message-mode-map "\C-c\C-t" #'message-insert-to) - (define-key message-mode-map "\C-c\C-fw" #'message-insert-wide-reply) - (define-key message-mode-map "\C-c\C-n" #'message-insert-newsgroups) - (define-key message-mode-map "\C-c\C-l" #'message-to-list-only) - (define-key message-mode-map "\C-c\C-f\C-e" #'message-insert-expires) - - (define-key message-mode-map "\C-c\C-u" #'message-insert-or-toggle-importance) - (define-key message-mode-map "\C-c\M-n" - #'message-insert-disposition-notification-to) - - (define-key message-mode-map "\C-c\C-y" #'message-yank-original) - (define-key message-mode-map "\C-c\M-\C-y" #'message-yank-buffer) - (define-key message-mode-map "\C-c\C-q" #'message-fill-yanked-message) - (define-key message-mode-map "\C-c\C-w" #'message-insert-signature) - (define-key message-mode-map "\C-c\M-h" #'message-insert-headers) - (define-key message-mode-map "\C-c\C-r" #'message-caesar-buffer-body) - (define-key message-mode-map "\C-c\C-o" #'message-sort-headers) - (define-key message-mode-map "\C-c\M-r" #'message-rename-buffer) - - (define-key message-mode-map "\C-c\C-c" #'message-send-and-exit) - (define-key message-mode-map "\C-c\C-s" #'message-send) - (define-key message-mode-map "\C-c\C-k" #'message-kill-buffer) - (define-key message-mode-map "\C-c\C-d" #'message-dont-send) - (define-key message-mode-map "\C-c\n" #'gnus-delay-article) - - (define-key message-mode-map "\C-c\M-k" #'message-kill-address) - (define-key message-mode-map "\C-c\C-e" #'message-elide-region) - (define-key message-mode-map "\C-c\C-v" #'message-delete-not-region) - (define-key message-mode-map "\C-c\C-z" #'message-kill-to-signature) - (define-key message-mode-map "\M-\r" #'message-newline-and-reformat) - (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) - - (define-key message-mode-map "\M-n" #'message-display-abbrev)) + "C-c M-m" #'message-mark-inserted-region + "C-c M-f" #'message-mark-insert-file + + "C-c C-b" #'message-goto-body + "C-c C-i" #'message-goto-signature + + "C-c C-t" #'message-insert-to + "C-c C-f w" #'message-insert-wide-reply + "C-c C-n" #'message-insert-newsgroups + "C-c C-l" #'message-to-list-only + "C-c C-f C-e" #'message-insert-expires + "C-c C-u" #'message-insert-or-toggle-importance + "C-c M-n" #'message-insert-disposition-notification-to + + "C-c C-y" #'message-yank-original + "C-c C-M-y" #'message-yank-buffer + "C-c C-q" #'message-fill-yanked-message + "C-c C-w" #'message-insert-signature + "C-c M-h" #'message-insert-headers + "C-c C-r" #'message-caesar-buffer-body + "C-c C-o" #'message-sort-headers + "C-c M-r" #'message-rename-buffer + + "C-c C-c" #'message-send-and-exit + "C-c C-s" #'message-send + "C-c C-k" #'message-kill-buffer + "C-c C-d" #'message-dont-send + "C-c C-j" #'gnus-delay-article + + "C-c M-k" #'message-kill-address + "C-c C-e" #'message-elide-region + "C-c C-v" #'message-delete-not-region + "C-c C-z" #'message-kill-to-signature + "M-RET" #'message-newline-and-reformat + "<remap> <split-line>" #'message-split-line + + "C-c C-a" #'mml-attach-file + "C-c C-p" #'message-insert-screenshot + + "C-a" #'message-beginning-of-line + "TAB" #'message-tab + + "M-n" #'message-display-abbrev) (easy-menu-define message-mode-menu message-mode-map "Message Menu." @@ -3161,6 +3157,7 @@ Like `text-mode', but with these additional commands: (setq-local message-checksum nil) (setq-local message-mime-part 0) (message-setup-fill-variables) + (yank-media-handler "image/.*" #'message--yank-media-image-handler) (when message-fill-column (setq fill-column message-fill-column) (turn-on-auto-fill)) @@ -4766,23 +4763,25 @@ Valid types are `send', `return', `exit', `kill' and `postpone'." t "\ The message size, " - (/ (buffer-size) 1000) "KB, is too large. + (/ (buffer-size) 1000) + (substitute-command-keys "KB, is too large. Some mail gateways (MTA's) bounce large messages. To avoid the -problem, answer `y', and the message will be split into several -smaller pieces, the size of each is about " +problem, answer \\`y', and the message will be split into several +smaller pieces, the size of each is about ") (/ message-send-mail-partially-limit 1000) - "KB except the last + (substitute-command-keys + "KB except the last one. However, some mail readers (MUA's) can't read split messages, i.e., -mails in message/partially format. Answer `n', and the message +mails in message/partially format. Answer \\`n', and the message will be sent in one piece. The size limit is controlled by `message-send-mail-partially-limit'. If you always want Gnus to send messages in one piece, set `message-send-mail-partially-limit' to nil. -"))) +")))) (progn (message "Sending via mail...") (if message-send-mail-real-function @@ -5358,7 +5357,7 @@ Otherwise, generate and save a value for `canlock-password' first." (zerop (length (setq to (completing-read - "Followups to (default no Followup-To header): " + (format-prompt "Followups to" "no Followup-To header") (mapcar #'list (cons "poster" (message-tokenize-header @@ -5829,15 +5828,15 @@ In posting styles use `(\"Expires\" (make-expires-date 30))'." ;; You might for example insert a "." somewhere (not next to another dot ;; or string boundary), or modify the "fsf" string. (defun message-unique-id () - ;; Don't use microseconds from (current-time), they may be unsupported. + ;; Don't use fractional seconds from timestamp; they may be unsupported. ;; Instead we use this randomly inited counter. (setq message-unique-id-char - (% (1+ (or message-unique-id-char - (random (ash 1 20)))) - ;; (current-time) returns 16-bit ints, - ;; and 2^16*25 just fits into 4 digits i base 36. - (* 25 25))) - (let ((tm (current-time))) + ;; 2^16 * 25 just fits into 4 digits i base 36. + (let ((base (* 25 25))) + (if message-unique-id-char + (% (1+ message-unique-id-char) base) + (random base)))) + (let ((tm (time-convert nil 'integer))) (concat (if (or (eq system-type 'ms-dos) ;; message-number-base36 doesn't handle bigints. @@ -5847,10 +5846,12 @@ In posting styles use `(\"Expires\" (make-expires-date 30))'." (aset user (match-beginning 0) ?_)) user) (message-number-base36 (user-uid) -1)) - (message-number-base36 (+ (car tm) - (ash (% message-unique-id-char 25) 16)) 4) - (message-number-base36 (+ (nth 1 tm) - (ash (/ message-unique-id-char 25) 16)) 4) + (message-number-base36 (+ (ash tm -16) + (ash (% message-unique-id-char 25) 16)) + 4) + (message-number-base36 (+ (logand tm #xffff) + (ash (/ message-unique-id-char 25) 16)) + 4) ;; Append a given name, because while the generated ID is unique ;; to this newsreader, other newsreaders might otherwise generate ;; the same ID via another algorithm. @@ -5947,12 +5948,9 @@ In posting styles use `(\"Expires\" (make-expires-date 30))'." (defun message-make-expires () "Return an Expires header based on `message-expires'." - (let ((current (current-time)) - (future (* 1.0 message-expires 60 60 24))) + (let ((future (* 60 60 24 message-expires))) ;; Add the future to current. - (setcar current (+ (car current) (round (/ future (expt 2 16))))) - (setcar (cdr current) (+ (nth 1 current) (% (round future) (expt 2 16)))) - (message-make-date current))) + (message-make-date (time-add nil future)))) (defun message-make-path () "Return uucp path." @@ -8879,24 +8877,29 @@ used to take the screenshot." (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--yank-media-image-handler 'image/png image) (message ""))) +(defun message--yank-media-image-handler (type image) + (set-mark (point)) + (insert-image + (create-image image (mailcap-mime-type-to-extension type) t + :max-width (truncate (* (frame-pixel-width) 0.8)) + :max-height (truncate (* (frame-pixel-height) 0.8)) + :scale 1) + (format "<#part type=\"%s\" disposition=inline data-encoding=base64 raw=t>\n%s\n<#/part>" + type + ;; 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))) + nil nil t) + (insert "\n\n")) + (declare-function gnus-url-unhex-string "gnus-util") (defun message-parse-mailto-url (url) diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el index aca4bf2062d..d781407cdcd 100644 --- a/lisp/gnus/mm-decode.el +++ b/lisp/gnus/mm-decode.el @@ -446,10 +446,11 @@ If not set, `default-directory' will be used." :type 'integer :group 'mime-display) -(defcustom mm-external-terminal-program "xterm" - "The program to start an external terminal." - :version "22.1" - :type 'string +(defcustom mm-external-terminal-program '("xterm" "-e") + "The program to start an external terminal. +This should be a list of strings." + :version "29.1" + :type '(choice string (repeat string)) :group 'mime-display) ;;; Internal variables. @@ -957,10 +958,16 @@ external if displayed external." (unwind-protect (if window-system (set-process-sentinel - (start-process "*display*" nil - mm-external-terminal-program - "-e" shell-file-name - shell-command-switch command) + (apply #'start-process "*display*" nil + (append + (if (listp mm-external-terminal-program) + mm-external-terminal-program + ;; Be backwards-compatible. + (list mm-external-terminal-program + "-e")) + (list shell-file-name + shell-command-switch + command))) (lambda (process _state) (if (eq 'exit (process-status process)) (run-at-time diff --git a/lisp/gnus/mm-util.el b/lisp/gnus/mm-util.el index 92e04f9d2ee..ddc228e4900 100644 --- a/lisp/gnus/mm-util.el +++ b/lisp/gnus/mm-util.el @@ -31,7 +31,7 @@ (defun mm-ucs-to-char (codepoint) "Convert Unicode codepoint to character." - (or (decode-char 'ucs codepoint) ?#)) + (or codepoint ?#)) (defvar mm-coding-system-list nil) (defun mm-get-coding-system-list () diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el index 5f35e73cd7c..e60d777e0d2 100644 --- a/lisp/gnus/mml.el +++ b/lisp/gnus/mml.el @@ -1143,48 +1143,40 @@ If HANDLES is non-nil, use it instead reparsing the buffer." ;;; Mode for inserting and editing MML forms ;;; -(defvar mml-mode-map - (let ((sign (make-sparse-keymap)) - (encrypt (make-sparse-keymap)) - (signpart (make-sparse-keymap)) - (encryptpart (make-sparse-keymap)) - (map (make-sparse-keymap)) - (main (make-sparse-keymap))) - (define-key map "\C-s" 'mml-secure-message-sign) - (define-key map "\C-c" 'mml-secure-message-encrypt) - (define-key map "\C-e" 'mml-secure-message-sign-encrypt) - (define-key map "\C-p\C-s" 'mml-secure-sign) - (define-key map "\C-p\C-c" 'mml-secure-encrypt) - (define-key sign "p" 'mml-secure-message-sign-pgpmime) - (define-key sign "o" 'mml-secure-message-sign-pgp) - (define-key sign "s" 'mml-secure-message-sign-smime) - (define-key signpart "p" 'mml-secure-sign-pgpmime) - (define-key signpart "o" 'mml-secure-sign-pgp) - (define-key signpart "s" 'mml-secure-sign-smime) - (define-key encrypt "p" 'mml-secure-message-encrypt-pgpmime) - (define-key encrypt "o" 'mml-secure-message-encrypt-pgp) - (define-key encrypt "s" 'mml-secure-message-encrypt-smime) - (define-key encryptpart "p" 'mml-secure-encrypt-pgpmime) - (define-key encryptpart "o" 'mml-secure-encrypt-pgp) - (define-key encryptpart "s" 'mml-secure-encrypt-smime) - (define-key map "\C-n" 'mml-unsecure-message) - (define-key map "f" 'mml-attach-file) - (define-key map "b" 'mml-attach-buffer) - (define-key map "e" 'mml-attach-external) - (define-key map "q" 'mml-quote-region) - (define-key map "m" 'mml-insert-multipart) - (define-key map "p" 'mml-insert-part) - (define-key map "v" 'mml-validate) - (define-key map "P" 'mml-preview) - (define-key map "s" sign) - (define-key map "S" signpart) - (define-key map "c" encrypt) - (define-key map "C" encryptpart) - ;;(define-key map "n" 'mml-narrow-to-part) - ;; `M-m' conflicts with `back-to-indentation'. - ;; (define-key main "\M-m" map) - (define-key main "\C-c\C-m" map) - main)) +(defvar-keymap mml-mode-map + "C-c C-m" + (define-keymap + "C-s" #'mml-secure-message-sign + "C-c" #'mml-secure-message-encrypt + "C-e" #'mml-secure-message-sign-encrypt + "C-p C-s" #'mml-secure-sign + "C-p C-c" #'mml-secure-encrypt + + "s" (define-keymap + "p" #'mml-secure-message-sign-pgpmime + "o" #'mml-secure-message-sign-pgp + "s" #'mml-secure-message-sign-smime) + "S" (define-keymap + "p" #'mml-secure-sign-pgpmime + "o" #'mml-secure-sign-pgp + "s" #'mml-secure-sign-smime) + "c" (define-keymap + "p" #'mml-secure-message-encrypt-pgpmime + "o" #'mml-secure-message-encrypt-pgp + "s" #'mml-secure-message-encrypt-smime) + "C" (define-keymap + "p" #'mml-secure-encrypt-pgpmime + "o" #'mml-secure-encrypt-pgp + "s" #'mml-secure-encrypt-smime) + "C-n" #'mml-unsecure-message + "f" #'mml-attach-file + "b" #'mml-attach-buffer + "e" #'mml-attach-external + "q" #'mml-quote-region + "m" #'mml-insert-multipart + "p" #'mml-insert-part + "v" #'mml-validate + "P" #'mml-preview)) (easy-menu-define mml-menu mml-mode-map "" @@ -1409,6 +1401,13 @@ to specify options." :version "22.1" ;; Gnus 5.10.9 :group 'message) +(defcustom mml-attach-file-at-the-end nil + "If non-nil, \\[mml-attach-file] attaches files at the end of the message. +If nil, files are attached at point." + :type 'boolean + :version "29.1" + :group 'message) + ;;;###autoload (defun mml-attach-file (file &optional type description disposition) "Attach a file to the outgoing MIME message. @@ -1423,6 +1422,8 @@ specifies how the attachment is intended to be displayed. It can be either \"inline\" (displayed automatically within the message body) or \"attachment\" (separate from the body). +Also see the `mml-attach-file-at-the-end' variable. + If given a prefix interactively, no prompting will be done for the TYPE, DESCRIPTION or DISPOSITION values. Instead defaults will be computed and used." @@ -1440,8 +1441,11 @@ will be computed and used." (mml-minibuffer-read-disposition type nil file)))) (list file type description disposition))) ;; If in the message header, attach at the end and leave point unchanged. - (let ((head (unless (message-in-body-p) (point)))) - (if head (goto-char (point-max))) + (let ((at-end (and (or (not (message-in-body-p)) + mml-attach-file-at-the-end) + (point)))) + (when at-end + (goto-char (point-max))) (mml-insert-empty-tag 'part 'type type ;; icicles redefines read-file-name and returns a @@ -1451,13 +1455,13 @@ will be computed and used." 'description description) ;; When using Mail mode, make sure it does the mime encoding ;; when you send the message. - (or (eq mail-user-agent 'message-user-agent) - (setq mail-encode-mml t)) - (when head + (unless (eq mail-user-agent 'message-user-agent) + (setq mail-encode-mml t)) + (when at-end (unless (pos-visible-in-window-p) (message "The file \"%s\" has been attached at the end of the message" (file-name-nondirectory file))) - (goto-char head)))) + (goto-char at-end)))) (defun mml-dnd-attach-file (uri _action) "Attach a drag and drop file. diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el index 6b627a4b756..b7082696b2c 100644 --- a/lisp/gnus/nnimap.el +++ b/lisp/gnus/nnimap.el @@ -429,8 +429,18 @@ during splitting, which may be slow." now (nnimap-last-command-time nnimap-object)))) (with-local-quit - (ignore-errors ;E.g. "buffer foo has no process". - (nnimap-send-command "NOOP"))))))))) + (ignore-errors ;E.g. "buffer foo has no process". + (nnimap-send-command "NOOP")) + ;; If our connection has died in the meantime, clean it + ;; and its buffer up. + (unless (process-live-p (get-buffer-process buffer)) + (setq nnimap-process-buffers + (delq buffer nnimap-process-buffers)) + (setq nnimap-connection-alist + (seq-filter (lambda (elt) + (null (eq buffer (cdr elt)))) + nnimap-connection-alist)) + (kill-buffer buffer))))))))) (defun nnimap-open-connection (buffer) ;; Be backwards-compatible -- the earlier value of nnimap-stream was @@ -662,10 +672,17 @@ during splitting, which may be slow." (deffoo nnimap-close-server (&optional server defs) (when (nnoo-change-server 'nnimap server defs) - (ignore-errors - (delete-process (get-buffer-process (nnimap-buffer)))) - (nnoo-close-server 'nnimap server) - t)) + (let ((buf (nnimap-buffer))) + (ignore-errors + (delete-process (get-buffer-process buf))) + (setq nnimap-process-buffers + (delq buf nnimap-process-buffers) + nnimap-connection-alist + (seq-filter (lambda (elt) + (null (eq buf (cdr elt)))) + nnimap-connection-alist)) + (nnoo-close-server 'nnimap server) + t))) (deffoo nnimap-request-close () t) @@ -1937,10 +1954,13 @@ Return the server's response to the SELECT or EXAMINE command." (when entry (if (and (buffer-live-p (cadr entry)) (get-buffer-process (cadr entry)) - (memq (process-status (get-buffer-process (cadr entry))) - '(open run))) + (process-live-p (get-buffer-process (cadr entry)))) (get-buffer-process (cadr entry)) - (setq nnimap-connection-alist (delq entry nnimap-connection-alist)) + (setq nnimap-connection-alist (delq entry nnimap-connection-alist) + nnimap-process-buffers + (delq (cadr entry) nnimap-process-buffers)) + (when (buffer-live-p (cadr entry)) + (kill-buffer (cadr entry))) nil)))) ;; Leave room for `open-network-stream' to issue a couple of IMAP diff --git a/lisp/gnus/nnselect.el b/lisp/gnus/nnselect.el index ecec705b326..252e9f66838 100644 --- a/lisp/gnus/nnselect.el +++ b/lisp/gnus/nnselect.el @@ -779,6 +779,10 @@ Return an article list." (args (alist-get 'nnselect-args specs))) (condition-case-unless-debug err (funcall func args) + ;; Don't swallow gnus-search errors; the user should be made + ;; aware of them. + (gnus-search-error + (signal (car err) (cdr err))) (error (gnus-error 3 "nnselect-run: %s on %s gave error %s" func args err) [])))) diff --git a/lisp/gnus/nntp.el b/lisp/gnus/nntp.el index 615a3c931bf..25289655bf2 100644 --- a/lisp/gnus/nntp.el +++ b/lisp/gnus/nntp.el @@ -331,9 +331,7 @@ retried once before actually displaying the error report." (when nntp-record-commands (nntp-record-command "*** CALLED nntp-report ***")) - (nnheader-report 'nntp args) - - (apply #'error args))) + (nnheader-report 'nntp args))) (defsubst nntp-copy-to-buffer (buffer start end) "Copy string from unibyte current buffer to multibyte buffer." diff --git a/lisp/gnus/spam.el b/lisp/gnus/spam.el index d00f0a60b66..508ef5424ea 100644 --- a/lisp/gnus/spam.el +++ b/lisp/gnus/spam.el @@ -663,13 +663,13 @@ order for SpamAssassin to recognize the new registered spam." ;;; Key bindings for spam control. -(gnus-define-keys gnus-summary-mode-map - "St" spam-generic-score - "Sx" gnus-summary-mark-as-spam - "Mst" spam-generic-score - "Msx" gnus-summary-mark-as-spam - "\M-d" gnus-summary-mark-as-spam - "$" gnus-summary-mark-as-spam) +(define-keymap :keymap gnus-summary-mode-map + "S t" #'spam-generic-score + "S x" #'gnus-summary-mark-as-spam + "M s t" #'spam-generic-score + "M s x" #'gnus-summary-mark-as-spam + "M-d" #'gnus-summary-mark-as-spam + "$" #'gnus-summary-mark-as-spam) (defvar spam-cache-lookups t "Whether spam.el will try to cache lookups using `spam-caches'.") diff --git a/lisp/help-at-pt.el b/lisp/help-at-pt.el index 233c50504bf..8eb397bc82d 100644 --- a/lisp/help-at-pt.el +++ b/lisp/help-at-pt.el @@ -229,11 +229,11 @@ this option, or use \"In certain situations\" and specify no text properties, to enable buffer local values." never)) :initialize 'custom-initialize-default - :set #'(lambda (variable value) - (set-default variable value) - (if (eq value 'never) - (help-at-pt-cancel-timer) - (help-at-pt-set-timer))) + :set (lambda (variable value) + (set-default variable value) + (if (eq value 'never) + (help-at-pt-cancel-timer) + (help-at-pt-set-timer))) :set-after '(help-at-pt-timer-delay) :require 'help-at-pt) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 2b759a5a5c5..32698420e1f 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -249,7 +249,8 @@ handling of autoloaded functions." ;; calling that. (let ((describe-function-orig-buffer (or describe-function-orig-buffer - (current-buffer)))) + (current-buffer))) + (help-buffer-under-preparation t)) (help-setup-xref (list (lambda (function buffer) @@ -1078,7 +1079,8 @@ it is displayed along with the global value." (if (symbolp v) (symbol-name v)))) (list (if (equal val "") v (intern val))))) - (let (file-name) + (let (file-name + (help-buffer-under-preparation t)) (unless (buffer-live-p buffer) (setq buffer (current-buffer))) (unless (frame-live-p frame) (setq frame (selected-frame))) (if (not (symbolp variable)) @@ -1461,77 +1463,78 @@ If FRAME is omitted or nil, use the selected frame." (interactive (list (read-face-name "Describe face" (or (face-at-point t) 'default) t))) - (help-setup-xref (list #'describe-face face) - (called-interactively-p 'interactive)) - (unless face - (setq face 'default)) - (if (not (listp face)) - (setq face (list face))) - (with-help-window (help-buffer) - (with-current-buffer standard-output - (dolist (f face (buffer-string)) - (if (stringp f) (setq f (intern f))) - ;; We may get called for anonymous faces (i.e., faces - ;; expressed using prop-value plists). Those can't be - ;; usefully customized, so ignore them. - (when (symbolp f) - (insert "Face: " (symbol-name f)) - (if (not (facep f)) - (insert " undefined face.\n") - (let ((customize-label "customize this face") - file-name) - (insert (concat " (" (propertize "sample" 'font-lock-face f) ")")) - (princ (concat " (" customize-label ")\n")) - ;; FIXME not sure how much of this belongs here, and - ;; how much in `face-documentation'. The latter is - ;; not used much, but needs to return nil for - ;; undocumented faces. - (let ((alias (get f 'face-alias)) - (face f) - obsolete) - (when alias - (setq face alias) - (insert - (format-message - "\n %s is an alias for the face `%s'.\n%s" - f alias - (if (setq obsolete (get f 'obsolete-face)) - (format-message - " This face is obsolete%s; use `%s' instead.\n" - (if (stringp obsolete) - (format " since %s" obsolete) - "") - alias) - "")))) - (insert "\nDocumentation:\n" - (substitute-command-keys - (or (face-documentation face) - "Not documented as a face.")) - "\n\n")) - (with-current-buffer standard-output - (save-excursion - (re-search-backward - (concat "\\(" customize-label "\\)") nil t) - (help-xref-button 1 'help-customize-face f))) - (setq file-name (find-lisp-object-file-name f 'defface)) - (if (not file-name) - (setq help-mode--current-data (list :symbol f)) - (setq help-mode--current-data (list :symbol f - :file file-name)) - (princ (substitute-command-keys "Defined in `")) - (princ (help-fns-short-filename file-name)) - (princ (substitute-command-keys "'")) - ;; Make a hyperlink to the library. - (save-excursion - (re-search-backward - (substitute-command-keys "`\\([^`']+\\)'") nil t) - (help-xref-button 1 'help-face-def f file-name)) - (princ ".") - (terpri) - (terpri)))) - (terpri) - (help-fns--run-describe-functions - help-fns-describe-face-functions f frame)))))) + (let ((help-buffer-under-preparation t)) + (help-setup-xref (list #'describe-face face) + (called-interactively-p 'interactive)) + (unless face + (setq face 'default)) + (if (not (listp face)) + (setq face (list face))) + (with-help-window (help-buffer) + (with-current-buffer standard-output + (dolist (f face (buffer-string)) + (if (stringp f) (setq f (intern f))) + ;; We may get called for anonymous faces (i.e., faces + ;; expressed using prop-value plists). Those can't be + ;; usefully customized, so ignore them. + (when (symbolp f) + (insert "Face: " (symbol-name f)) + (if (not (facep f)) + (insert " undefined face.\n") + (let ((customize-label "customize this face") + file-name) + (insert (concat " (" (propertize "sample" 'font-lock-face f) ")")) + (princ (concat " (" customize-label ")\n")) + ;; FIXME not sure how much of this belongs here, and + ;; how much in `face-documentation'. The latter is + ;; not used much, but needs to return nil for + ;; undocumented faces. + (let ((alias (get f 'face-alias)) + (face f) + obsolete) + (when alias + (setq face alias) + (insert + (format-message + "\n %s is an alias for the face `%s'.\n%s" + f alias + (if (setq obsolete (get f 'obsolete-face)) + (format-message + " This face is obsolete%s; use `%s' instead.\n" + (if (stringp obsolete) + (format " since %s" obsolete) + "") + alias) + "")))) + (insert "\nDocumentation:\n" + (substitute-command-keys + (or (face-documentation face) + "Not documented as a face.")) + "\n\n")) + (with-current-buffer standard-output + (save-excursion + (re-search-backward + (concat "\\(" customize-label "\\)") nil t) + (help-xref-button 1 'help-customize-face f))) + (setq file-name (find-lisp-object-file-name f 'defface)) + (if (not file-name) + (setq help-mode--current-data (list :symbol f)) + (setq help-mode--current-data (list :symbol f + :file file-name)) + (princ (substitute-command-keys "Defined in `")) + (princ (help-fns-short-filename file-name)) + (princ (substitute-command-keys "'")) + ;; Make a hyperlink to the library. + (save-excursion + (re-search-backward + (substitute-command-keys "`\\([^`']+\\)'") nil t) + (help-xref-button 1 'help-face-def f file-name)) + (princ ".") + (terpri) + (terpri)))) + (terpri) + (help-fns--run-describe-functions + help-fns-describe-face-functions f frame))))))) (add-hook 'help-fns-describe-face-functions #'help-fns--face-custom-version-info) @@ -1561,7 +1564,7 @@ If FRAME is omitted or nil, use the selected frame." (:fontset . "Fontset") (:extend . "Extend") (:inherit . "Inherit"))) - (max-width (apply #'max (mapcar #'(lambda (x) (length (cdr x))) + (max-width (apply #'max (mapcar (lambda (x) (length (cdr x))) attrs)))) (dolist (a attrs) (let ((attr (face-attribute face (car a) frame))) @@ -1602,43 +1605,44 @@ current buffer and the selected frame, respectively." (if found (symbol-name v-or-f))))) (list (if (equal 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))) - (unless (frame-live-p frame) (setq frame (selected-frame))) - (with-current-buffer (help-buffer) - ;; Push the previous item on the stack before clobbering the output buffer. - (help-setup-xref nil nil) - (let* ((docs - (nreverse - (delq nil - (mapcar (pcase-lambda (`(,name ,testfn ,descfn)) - (when (funcall testfn symbol) - ;; Don't record the current entry in the stack. - (setq help-xref-stack-item nil) - (cons name - (funcall descfn symbol buffer frame)))) - describe-symbol-backends)))) - (single (null (cdr docs)))) - (while (cdr docs) - (goto-char (point-min)) - (let ((inhibit-read-only t) - (name (caar docs)) ;Name of doc currently at BOB. - (doc (cdr (cadr docs)))) ;Doc to add at BOB. - (when doc - (insert doc) - (delete-region (point) - (progn (skip-chars-backward " \t\n") (point))) - (insert "\n\n" (make-separator-line) "\n") - (when name - (insert (symbol-name symbol) - " is also a " name "." "\n\n")))) - (setq docs (cdr docs))) - (unless single - ;; Don't record the `describe-variable' item in the stack. - (setq help-xref-stack-item nil) - (help-setup-xref (list #'describe-symbol symbol) nil)) - (goto-char (point-min))))) + (let ((help-buffer-under-preparation t)) + (if (not (symbolp symbol)) + (user-error "You didn't specify a function or variable")) + (unless (buffer-live-p buffer) (setq buffer (current-buffer))) + (unless (frame-live-p frame) (setq frame (selected-frame))) + (with-current-buffer (help-buffer) + ;; Push the previous item on the stack before clobbering the output buffer. + (help-setup-xref nil nil) + (let* ((docs + (nreverse + (delq nil + (mapcar (pcase-lambda (`(,name ,testfn ,descfn)) + (when (funcall testfn symbol) + ;; Don't record the current entry in the stack. + (setq help-xref-stack-item nil) + (cons name + (funcall descfn symbol buffer frame)))) + describe-symbol-backends)))) + (single (null (cdr docs)))) + (while (cdr docs) + (goto-char (point-min)) + (let ((inhibit-read-only t) + (name (caar docs)) ;Name of doc currently at BOB. + (doc (cdr (cadr docs)))) ;Doc to add at BOB. + (when doc + (insert doc) + (delete-region (point) + (progn (skip-chars-backward " \t\n") (point))) + (insert "\n\n" (make-separator-line) "\n") + (when name + (insert (symbol-name symbol) + " is also a " name "." "\n\n")))) + (setq docs (cdr docs))) + (unless single + ;; Don't record the `describe-variable' item in the stack. + (setq help-xref-stack-item nil) + (help-setup-xref (list #'describe-symbol symbol) nil)) + (goto-char (point-min)))))) ;;;###autoload (defun describe-syntax (&optional buffer) @@ -1647,15 +1651,16 @@ The descriptions are inserted in a help buffer, which is then displayed. BUFFER defaults to the current buffer." (interactive) (setq buffer (or buffer (current-buffer))) - (help-setup-xref (list #'describe-syntax buffer) - (called-interactively-p 'interactive)) - (with-help-window (help-buffer) - (let ((table (with-current-buffer buffer (syntax-table)))) - (with-current-buffer standard-output - (describe-vector table 'internal-describe-syntax-value) - (while (setq table (char-table-parent table)) - (insert "\nThe parent syntax table is:") - (describe-vector table 'internal-describe-syntax-value)))))) + (let ((help-buffer-under-preparation t)) + (help-setup-xref (list #'describe-syntax buffer) + (called-interactively-p 'interactive)) + (with-help-window (help-buffer) + (let ((table (with-current-buffer buffer (syntax-table)))) + (with-current-buffer standard-output + (describe-vector table 'internal-describe-syntax-value) + (while (setq table (char-table-parent table)) + (insert "\nThe parent syntax table is:") + (describe-vector table 'internal-describe-syntax-value))))))) (defun help-describe-category-set (value) (insert (cond @@ -1672,59 +1677,60 @@ The descriptions are inserted in a buffer, which is then displayed. If BUFFER is non-nil, then describe BUFFER's category table instead. BUFFER should be a buffer or a buffer name." (interactive) - (setq buffer (or buffer (current-buffer))) - (help-setup-xref (list #'describe-categories buffer) - (called-interactively-p 'interactive)) - (with-help-window (help-buffer) - (let* ((table (with-current-buffer buffer (category-table))) - (docs (char-table-extra-slot table 0))) - (if (or (not (vectorp docs)) (/= (length docs) 95)) - (error "Invalid first extra slot in this category table\n")) - (with-current-buffer standard-output - (setq-default help-button-cache (make-marker)) - (insert "Legend of category mnemonics ") - (insert-button "(longer descriptions at the bottom)" - 'action help-button-cache - 'follow-link t - 'help-echo "mouse-2, RET: show full legend") - (insert "\n") - (let ((pos (point)) (items 0) lines n) - (dotimes (i 95) - (if (aref docs i) (setq items (1+ items)))) - (setq lines (1+ (/ (1- items) 4))) - (setq n 0) + (let ((help-buffer-under-preparation t)) + (setq buffer (or buffer (current-buffer))) + (help-setup-xref (list #'describe-categories buffer) + (called-interactively-p 'interactive)) + (with-help-window (help-buffer) + (let* ((table (with-current-buffer buffer (category-table))) + (docs (char-table-extra-slot table 0))) + (if (or (not (vectorp docs)) (/= (length docs) 95)) + (error "Invalid first extra slot in this category table\n")) + (with-current-buffer standard-output + (setq-default help-button-cache (make-marker)) + (insert "Legend of category mnemonics ") + (insert-button "(longer descriptions at the bottom)" + 'action help-button-cache + 'follow-link t + 'help-echo "mouse-2, RET: show full legend") + (insert "\n") + (let ((pos (point)) (items 0) lines n) + (dotimes (i 95) + (if (aref docs i) (setq items (1+ items)))) + (setq lines (1+ (/ (1- items) 4))) + (setq n 0) + (dotimes (i 95) + (let ((elt (aref docs i))) + (when elt + (string-match ".*" elt) + (setq elt (match-string 0 elt)) + (if (>= (length elt) 17) + (setq elt (concat (substring elt 0 14) "..."))) + (if (< (point) (point-max)) + (move-to-column (* 20 (/ n lines)) t)) + (insert (+ i ?\s) ?: elt) + (if (< (point) (point-max)) + (forward-line 1) + (insert "\n")) + (setq n (1+ n)) + (if (= (% n lines) 0) + (goto-char pos)))))) + (goto-char (point-max)) + (insert "\n" + "character(s)\tcategory mnemonics\n" + "------------\t------------------") + (describe-vector table 'help-describe-category-set) + (set-marker help-button-cache (point)) + (insert "Legend of category mnemonics:\n") (dotimes (i 95) (let ((elt (aref docs i))) (when elt - (string-match ".*" elt) - (setq elt (match-string 0 elt)) - (if (>= (length elt) 17) - (setq elt (concat (substring elt 0 14) "..."))) - (if (< (point) (point-max)) - (move-to-column (* 20 (/ n lines)) t)) - (insert (+ i ?\s) ?: elt) - (if (< (point) (point-max)) - (forward-line 1) - (insert "\n")) - (setq n (1+ n)) - (if (= (% n lines) 0) - (goto-char pos)))))) - (goto-char (point-max)) - (insert "\n" - "character(s)\tcategory mnemonics\n" - "------------\t------------------") - (describe-vector table 'help-describe-category-set) - (set-marker help-button-cache (point)) - (insert "Legend of category mnemonics:\n") - (dotimes (i 95) - (let ((elt (aref docs i))) - (when elt - (if (string-match "\n" elt) - (setq elt (substring elt (match-end 0)))) - (insert (+ i ?\s) ": " elt "\n")))) - (while (setq table (char-table-parent table)) - (insert "\nThe parent category table is:") - (describe-vector table 'help-describe-category-set)))))) + (if (string-match "\n" elt) + (setq elt (substring elt (match-end 0)))) + (insert (+ i ?\s) ": " elt "\n")))) + (while (setq table (char-table-parent table)) + (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. @@ -1778,7 +1784,8 @@ keymap value." (unless (and km (keymapp (symbol-value km))) (user-error "Not a keymap: %s" km)) (list km))) - (let (used-gentemp) + (let (used-gentemp + (help-buffer-under-preparation t)) (unless (and (symbolp keymap) (boundp keymap) (keymapp (symbol-value keymap))) @@ -1844,106 +1851,107 @@ 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 (minors) - ;; 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))) - minors))))) - ;; 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") minors)) - (setq minors - (sort minors - (lambda (a b) (string-lessp (cadr a) (cadr b))))) - (when minors - (princ "Enabled minor modes:\n") - (make-local-variable 'help-button-cache) - (with-current-buffer standard-output - (dolist (mode minors) - (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))) - (if (not file-name) - (setq help-mode--current-data (list :symbol mode)) - (princ (format-message " defined in `%s'" - (help-fns-short-filename file-name))) - ;; Make a hyperlink to the library. + (let ((help-buffer-under-preparation t)) + (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 (minors) + ;; 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))) + minors))))) + ;; 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") minors)) + (setq minors + (sort minors + (lambda (a b) (string-lessp (cadr a) (cadr b))))) + (when minors + (princ "Enabled minor modes:\n") + (make-local-variable 'help-button-cache) (with-current-buffer standard-output - (save-excursion - (re-search-backward (substitute-command-keys "`\\([^`']+\\)'") - nil t) - (setq help-mode--current-data (list :symbol mode - :file file-name)) - (help-xref-button 1 'help-function-def mode file-name))))) - (let ((fundoc (help-split-fundoc (documentation major-mode) nil 'doc))) - (with-current-buffer standard-output - (insert ":\n") - (insert fundoc) - (insert (help-fns--list-local-commands))))))) - ;; For the sake of IELM and maybe others - nil) + (dolist (mode minors) + (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))) + (if (not file-name) + (setq help-mode--current-data (list :symbol mode)) + (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) + (setq help-mode--current-data (list :symbol mode + :file file-name)) + (help-xref-button 1 'help-function-def mode file-name))))) + (let ((fundoc (help-split-fundoc (documentation major-mode) nil 'doc))) + (with-current-buffer standard-output + (insert ":\n") + (insert fundoc) + (insert (help-fns--list-local-commands)))))))) + ;; For the sake of IELM and maybe others + nil) (defun help-fns--list-local-commands () (let ((functions nil)) @@ -1998,7 +2006,8 @@ one of them returns non-nil." (event-end key)) ((eq key ?\C-g) (signal 'quit nil)) (t (user-error "You didn't specify a widget")))))) - (let (buf) + (let (buf + (help-buffer-under-preparation t)) ;; Allow describing a widget in a different window. (when (posnp pos) (setq buf (window-buffer (posn-window pos)) diff --git a/lisp/help-macro.el b/lisp/help-macro.el index b3c7e2393a3..ecc7ebab412 100644 --- a/lisp/help-macro.el +++ b/lisp/help-macro.el @@ -93,7 +93,8 @@ and then returns." "Help command." (interactive) (let ((line-prompt - (substitute-command-keys ,help-line))) + (substitute-command-keys ,help-line)) + (help-buffer-under-preparation t)) (when three-step-help (message "%s" line-prompt)) (let* ((help-screen ,help-text) @@ -140,6 +141,7 @@ and then returns." (insert (substitute-command-keys help-screen))) (let ((minor-mode-map-alist new-minor-mode-map-alist)) (help-mode) + (variable-pitch-mode) (setq new-minor-mode-map-alist minor-mode-map-alist)) (goto-char (point-min)) (while (or (memq char (append help-event-list diff --git a/lisp/help-mode.el b/lisp/help-mode.el index 0b404fe89f1..792f2e5af33 100644 --- a/lisp/help-mode.el +++ b/lisp/help-mode.el @@ -35,6 +35,8 @@ (let ((map (make-sparse-keymap))) (set-keymap-parent map (make-composed-keymap button-buffer-map special-mode-map)) + (define-key map "n" 'help-goto-next-page) + (define-key map "p" 'help-goto-previous-page) (define-key map "l" 'help-go-back) (define-key map "r" 'help-go-forward) (define-key map "\C-c\C-b" 'help-go-back) @@ -273,6 +275,10 @@ The format is (FUNCTION ARGS...).") (when (or (< position (point-min)) (> position (point-max))) (widen)) + ;; Save mark for the old location, unless the point is not + ;; actually going to move. + (unless (= (point) position) + (push-mark nil t)) (goto-char position)) (message "Unable to find location in file"))))) @@ -372,6 +378,13 @@ The format is (FUNCTION ARGS...).") (view-buffer-other-window (find-file-noselect file)) (goto-char pos)) 'help-echo (purecopy "mouse-2, RET: show corresponding NEWS announcement")) + +;;;###autoload +(defun help-mode--add-function-link (str fun) + (make-text-button (copy-sequence str) nil + 'type 'help-function + 'help-args (list fun))) + (defvar bookmark-make-record-function) (defvar help-mode--current-data nil) @@ -631,34 +644,7 @@ that." "\\<M-x\\s-+\\(\\sw\\(\\sw\\|\\s_\\)*\\sw\\)" nil t) (let ((sym (intern-soft (match-string 1)))) (if (fboundp sym) - (help-xref-button 1 'help-function sym))))) - ;; Look for commands in whole keymap substitutions: - (save-excursion - ;; Make sure to find the first keymap. - (goto-char (point-min)) - ;; Find a header and the column at which the command - ;; name will be found. - - ;; If the keymap substitution isn't the last thing in - ;; the doc string, and if there is anything on the same - ;; line after it, this code won't recognize the end of it. - (while (re-search-forward "^key +binding\n\\(-+ +\\)-+\n\n" - nil t) - (let ((col (- (match-end 1) (match-beginning 1)))) - (while - (and (not (eobp)) - ;; Stop at a pair of blank lines. - (not (looking-at-p "\n\\s-*\n"))) - ;; Skip a single blank line. - (and (eolp) (forward-line)) - (end-of-line) - (skip-chars-backward "^ \t\n") - (if (and (>= (current-column) col) - (looking-at "\\(\\sw\\|\\s_\\)+$")) - (let ((sym (intern-soft (match-string 0)))) - (if (fboundp sym) - (help-xref-button 0 'help-function sym)))) - (forward-line)))))) + (help-xref-button 1 'help-function sym)))))) (set-syntax-table stab)) ;; Delete extraneous newlines at the end of the docstring (goto-char (point-max)) @@ -795,6 +781,26 @@ See `help-make-xrefs'." (help-xref-go-forward (current-buffer)) (user-error "No next help buffer"))) +(defun help-goto-next-page () + "Go to the next page (if any) in the current buffer. +The help buffers are divided into \"pages\" by the ^L character." + (interactive nil help-mode) + (push-mark) + (forward-page) + (unless (eobp) + (forward-line 1))) + +(defun help-goto-previous-page () + "Go to the previous page (if any) in the current buffer. +(If not at the start of a page, go to the start of the current page.) + +The help buffers are divided into \"pages\" by the ^L character." + (interactive nil help-mode) + (push-mark) + (backward-page (if (looking-back "\f\n" (- (point) 5)) 2 1)) + (unless (bobp) + (forward-line 1))) + (defun help-view-source () "View the source of the current help item." (interactive nil help-mode) diff --git a/lisp/help.el b/lisp/help.el index 941d4cfab12..5114ddefba1 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -50,6 +50,11 @@ (defvar help-window-old-frame nil "Frame selected at the time `with-help-window' is invoked.") +(defvar help-buffer-under-preparation nil + "Whether a *Help* buffer is being prepared. +This variable is bound to t during the preparation of a *Help* +buffer.") + (defvar help-map (let ((map (make-sparse-keymap))) (define-key map (char-to-string help-char) 'help-for-help) @@ -524,30 +529,31 @@ See `lossage-size' to update the number of recorded keystrokes. To record all your input, use `open-dribble-file'." (interactive) - (help-setup-xref (list #'view-lossage) - (called-interactively-p 'interactive)) - (with-help-window (help-buffer) - (princ " ") - (princ (mapconcat (lambda (key) - (cond - ((and (consp key) (null (car key))) - (format ";; %s\n" (if (symbolp (cdr key)) (cdr key) - "anonymous-command"))) - ((or (integerp key) (symbolp key) (listp key)) - (single-key-description key)) - (t - (prin1-to-string key nil)))) - (recent-keys 'include-cmds) - " ")) - (with-current-buffer standard-output - (goto-char (point-min)) - (let ((comment-start ";; ") - (comment-column 24)) - (while (not (eobp)) - (comment-indent) - (forward-line 1))) - ;; Show point near the end of "lossage", as we did in Emacs 24. - (set-marker help-window-point-marker (point))))) + (let ((help-buffer-under-preparation t)) + (help-setup-xref (list #'view-lossage) + (called-interactively-p 'interactive)) + (with-help-window (help-buffer) + (princ " ") + (princ (mapconcat (lambda (key) + (cond + ((and (consp key) (null (car key))) + (format ";; %s\n" (if (symbolp (cdr key)) (cdr key) + "anonymous-command"))) + ((or (integerp key) (symbolp key) (listp key)) + (single-key-description key)) + (t + (prin1-to-string key nil)))) + (recent-keys 'include-cmds) + " ")) + (with-current-buffer standard-output + (goto-char (point-min)) + (let ((comment-start ";; ") + (comment-column 24)) + (while (not (eobp)) + (comment-indent) + (forward-line 1))) + ;; Show point near the end of "lossage", as we did in Emacs 24. + (set-marker help-window-point-marker (point)))))) ;; Key bindings @@ -561,11 +567,13 @@ To record all your input, use `open-dribble-file'." 'font-lock-face 'help-key-binding 'face 'help-key-binding)) -(defcustom describe-bindings-outline nil +(defcustom describe-bindings-outline t "Non-nil enables outlines in the output buffer of `describe-bindings'." :type 'boolean :group 'help - :version "28.1") + :version "29.1") + +(declare-function outline-hide-subtree "outline") (defun describe-bindings (&optional prefix buffer) "Display a buffer showing a list of all defined keys, and their definitions. @@ -577,33 +585,32 @@ The optional argument BUFFER specifies which buffer's bindings to display (default, the current buffer). BUFFER can be a buffer or a buffer name." (interactive) - (or buffer (setq buffer (current-buffer))) - (help-setup-xref (list #'describe-bindings prefix buffer) - (called-interactively-p 'interactive)) - (with-help-window (help-buffer) - ;; Be aware that `describe-buffer-bindings' puts its output into - ;; the current buffer. - (with-current-buffer (help-buffer) - (describe-buffer-bindings buffer prefix) - - (when describe-bindings-outline - (setq-local outline-regexp ".*:$") - (setq-local outline-heading-end-regexp ":\n") - (setq-local outline-level (lambda () 1)) - (setq-local outline-minor-mode-cycle t - outline-minor-mode-highlight t) - (outline-minor-mode 1) - (save-excursion - (let ((inhibit-read-only t)) + (let ((help-buffer-under-preparation t)) + (or buffer (setq buffer (current-buffer))) + (help-setup-xref (list #'describe-bindings prefix buffer) + (called-interactively-p 'interactive)) + (with-help-window (help-buffer) + (with-current-buffer (help-buffer) + (describe-buffer-bindings buffer prefix) + + (when describe-bindings-outline + (setq-local outline-regexp ".*:$") + (setq-local outline-heading-end-regexp ":\n") + (setq-local outline-level (lambda () 1)) + (setq-local outline-minor-mode-cycle t + outline-minor-mode-highlight t) + (setq-local outline-minor-mode-use-buttons t) + (outline-minor-mode 1) + (save-excursion (goto-char (point-min)) - (insert (substitute-command-keys - (concat "\\<outline-minor-mode-cycle-map>Type " - "\\[outline-cycle] or \\[outline-cycle-buffer] " - "on headings to cycle their visibility.\n\n"))) - ;; Hide the longest body - (when (and (re-search-forward "Key translations" nil t) - (fboundp 'outline-cycle)) - (outline-cycle)))))))) + (let ((inhibit-read-only t)) + ;; Hide the longest body. + (when (re-search-forward "Key translations" nil t) + (outline-hide-subtree)) + ;; Hide ^Ls. + (while (search-forward "\n\f\n" nil t) + (put-text-property (1+ (match-beginning 0)) (1- (match-end 0)) + 'invisible t))))))))) (defun where-is (definition &optional insert) "Print message listing key sequences that invoke the command DEFINITION. @@ -903,7 +910,8 @@ current buffer." (let ((raw (if (numberp buffer) (this-single-command-raw-keys) buffer))) (setf (cdar (last key-list)) raw))) (setq buffer nil)) - (let* ((buf (or buffer (current-buffer))) + (let* ((help-buffer-under-preparation t) + (buf (or buffer (current-buffer))) (on-link (mapcar (lambda (kr) (let ((raw (cdr kr))) @@ -1060,6 +1068,14 @@ is currently activated with completion." result)) +(defcustom help-link-key-to-documentation t + "Non-nil means link keys to their command in *Help* buffers. +This affects \\\\=\\[command] substitutions in documentation +strings done by `substitute-command-keys'." + :type 'boolean + :version "29.1" + :group 'help) + (defun substitute-command-keys (string &optional no-face) "Substitute key descriptions for command names in STRING. Each substring of the form \\\\=[COMMAND] is replaced by either a @@ -1067,6 +1083,9 @@ keystroke sequence that invokes COMMAND, or \"M-x COMMAND\" if COMMAND is not on any keys. Keybindings will use the face `help-key-binding', unless the optional argument NO-FACE is non-nil. +Each substring of the form \\\\=`KEYBINDING' will be replaced by +KEYBINDING and use the `help-key-binding' face. + Each substring of the form \\\\={MAPVAR} is replaced by a summary of the value of MAPVAR as a keymap. This summary is similar to the one produced by ‘describe-bindings’. The summary ends in two newlines @@ -1119,6 +1138,23 @@ Otherwise, return a new string." (delete-char 2) (ignore-errors (forward-char 1))) + ((and (= (following-char) ?`) + (save-excursion + (prog1 (search-forward "'" nil t) + (setq end-point (- (point) 2))))) + (goto-char orig-point) + (delete-char 2) + (goto-char (1- end-point)) + (delete-char 1) + ;; (backward-char 1) + (let ((k (buffer-substring-no-properties orig-point (point)))) + (cond ((= (length k) 0) + (error "Empty key sequence in substitution")) + ((not (key-valid-p k)) + (error "Invalid key sequence in substitution: `%s'" k)))) + (add-text-properties orig-point (point) + '( face help-key-binding + font-lock-face help-key-binding))) ;; 1C. \[foo] is replaced with the keybinding. ((and (= (following-char) ?\[) (save-excursion @@ -1150,9 +1186,19 @@ Otherwise, return a new string." (delete-char 1)) ;; Function is on a key. (delete-char (- end-point (point))) - (insert (if no-face - (key-description key) - (help--key-description-fontified key)))))) + + (insert + (if no-face + (key-description key) + (let ((key (help--key-description-fontified key))) + (if (and help-link-key-to-documentation + help-buffer-under-preparation + (functionp fun)) + ;; The `fboundp' fixes bootstrap. + (if (fboundp 'help-mode--add-function-link) + (help-mode--add-function-link key fun) + key) + key))))))) ;; 1D. \{foo} is replaced with a summary of the keymap ;; (symbol-value foo). ;; \<foo> just sets the keymap used for \[cmd]. @@ -1212,8 +1258,8 @@ Otherwise, return a new string." (buffer-string))))) (defvar help--keymaps-seen nil) -(defun describe-map-tree (startmap partial shadow prefix title no-menu - transl always-title mention-shadow) +(defun describe-map-tree (startmap &optional partial shadow prefix title + no-menu transl always-title mention-shadow) "Insert a description of the key bindings in STARTMAP. This is followed by the key bindings of all maps reachable through STARTMAP. @@ -1239,10 +1285,7 @@ maps to look through. If MENTION-SHADOW is non-nil, then when something is shadowed by SHADOW, don't omit it; instead, mention it but say it is -shadowed. - -Any inserted text ends in two newlines (used by -`help-make-xrefs')." +shadowed." (let* ((amaps (accessible-keymaps startmap prefix)) (orig-maps (if no-menu (progn @@ -1259,17 +1302,8 @@ Any inserted text ends in two newlines (used by result)) amaps)) (maps orig-maps) - (print-title (or maps always-title))) - ;; Print title. - (when print-title - (insert (concat (if title - (concat title - (if prefix - (concat " Starting With " - (help--key-description-fontified prefix))) - ":\n")) - "key binding\n" - "--- -------\n"))) + (print-title (or maps always-title)) + (start-point (point))) ;; Describe key bindings. (setq help--keymaps-seen nil) (while (consp maps) @@ -1294,8 +1328,24 @@ Any inserted text ends in two newlines (used by (describe-map (cdr elt) elt-prefix transl partial sub-shadows no-menu mention-shadow))) (setq maps (cdr maps))) - (when print-title - (insert "\n")))) + ;; Print title... + (when (and print-title + ;; ... unless the keymap was empty. + (/= (point) start-point)) + (save-excursion + (goto-char start-point) + (when (eolp) + (delete-region (point) (1+ (point)))) + (insert + (concat + (if title + (concat title + (if prefix + (concat " Starting With " + (help--key-description-fontified prefix))) + ":\n")) + "\nKey Binding\n" + (make-separator-line))))))) (defun help--shadow-lookup (keymap key accept-default remap) "Like `lookup-key', but with command remapping. @@ -1308,48 +1358,37 @@ Return nil if the key sequence is too long." value)) (t value)))) -(defvar help--previous-description-column 0) -(defun help--describe-command (definition) - ;; Converted from describe_command in keymap.c. - ;; If column 16 is no good, go to col 32; - ;; but don't push beyond that--go to next line instead. - (let* ((column (current-column)) - (description-column (cond ((> column 30) - (insert "\n") - 32) - ((or (> column 14) - (and (> column 10) - (= help--previous-description-column 32))) - 32) - (t 16)))) - ;; Avoid using the `help-keymap' face. - (let ((op (point))) - (indent-to description-column 1) - (set-text-properties op (point) '( face nil - font-lock-face nil))) - (setq help--previous-description-column description-column) - (cond ((symbolp definition) - (insert (symbol-name definition) "\n")) - ((or (stringp definition) (vectorp definition)) - (insert "Keyboard Macro\n")) - ((keymapp definition) - (insert "Prefix Command\n")) - (t (insert "??\n"))))) - -(defun help--describe-translation (definition) - ;; Converted from describe_translation in keymap.c. - ;; Avoid using the `help-keymap' face. - (let ((op (point))) - (indent-to 16 1) - (set-text-properties op (point) '( face nil - font-lock-face nil))) +(defun help--describe-command (definition &optional translation) (cond ((symbolp definition) - (insert (symbol-name definition) "\n")) + (if (and (fboundp definition) + help-buffer-under-preparation) + (insert-text-button (symbol-name definition) + 'type 'help-function + 'help-args (list definition)) + (insert (symbol-name definition))) + (insert "\n")) ((or (stringp definition) (vectorp definition)) - (insert (key-description definition nil) "\n")) + (if translation + (insert (key-description definition nil) "\n") + (insert "Keyboard Macro\n"))) ((keymapp definition) (insert "Prefix Command\n")) - (t (insert "??\n")))) + ((byte-code-function-p definition) + (insert "[%s]\n" (buttonize "byte-code" #'disassemble definition))) + ((and (consp definition) + (memq (car definition) '(closure lambda))) + (insert (format "[%s]\n" + (buttonize + (symbol-name (car definition)) + (lambda (_) + (pp-display-expression + definition "*Help Source*" t)) + nil "View definition")))) + (t + (insert "??\n")))) + +(define-obsolete-function-alias 'help--describe-translation + #'help--describe-command "29.1") (defun help--describe-map-compare (a b) (let ((a (car a)) @@ -1363,7 +1402,8 @@ Return nil if the key sequence is too long." (string-version-lessp (symbol-name a) (symbol-name b))) (t nil)))) -(defun describe-map (map prefix transl partial shadow nomenu mention-shadow) +(defun describe-map (map &optional prefix transl partial shadow + nomenu mention-shadow) "Describe the contents of keymap MAP. Assume that this keymap itself is reached by the sequence of prefix keys PREFIX (a string or vector). @@ -1375,14 +1415,22 @@ TRANSL, PARTIAL, SHADOW, NOMENU, MENTION-SHADOW are as in (map (keymap-canonicalize map)) (tail map) (first t) - (describer (if transl - #'help--describe-translation - #'help--describe-command)) done vect) (while (and (consp tail) (not done)) (cond ((or (vectorp (car tail)) (char-table-p (car tail))) - (help--describe-vector (car tail) prefix describer partial - shadow map mention-shadow)) + (let ((columns ())) + (help--describe-vector + (car tail) prefix + (lambda (def) + (let ((start-line (line-beginning-position)) + (end-key (point)) + (column (current-column))) + (help--describe-command def transl) + (push (list column start-line end-key (1- (point))) + columns))) + partial shadow map mention-shadow) + (when columns + (describe-map--align-section columns)))) ((consp (car tail)) (let ((event (caar tail)) definition this-shadowed) @@ -1425,7 +1473,9 @@ TRANSL, PARTIAL, SHADOW, NOMENU, MENTION-SHADOW are as in (push (cons tail prefix) help--keymaps-seen))))) (setq tail (cdr tail))) ;; If we found some sparse map events, sort them. - (let ((vect (sort vect 'help--describe-map-compare))) + (let ((vect (sort vect 'help--describe-map-compare)) + (columns ()) + line-start key-end column) ;; Now output them in sorted order. (while vect (let* ((elem (car vect)) @@ -1433,10 +1483,6 @@ TRANSL, PARTIAL, SHADOW, NOMENU, MENTION-SHADOW are as in (definition (cadr elem)) (shadowed (caddr elem)) (end start)) - (when first - (setq help--previous-description-column 0) - (insert "\n") - (setq first nil)) ;; Find consecutive chars that are identically defined. (when (fixnump start) (while (and (cdr vect) @@ -1451,26 +1497,80 @@ TRANSL, PARTIAL, SHADOW, NOMENU, MENTION-SHADOW are as in (eq this-shadowed next-shadowed)))) (setq vect (cdr vect)) (setq end (caar vect)))) - ;; Now START .. END is the range to describe next. - ;; Insert the string to describe the event START. - (insert (help--key-description-fontified (vector start) prefix)) - (when (not (eq start end)) - (insert " .. " (help--key-description-fontified (vector end) prefix))) - ;; Print a description of the definition of this character. - ;; Called function will take care of spacing out far enough - ;; for alignment purposes. - (if transl - (help--describe-translation definition) - (help--describe-command definition)) - ;; Print a description of the definition of this character. - ;; elt_describer will take care of spacing out far enough for - ;; alignment purposes. - (when shadowed - (goto-char (max (1- (point)) (point-min))) - (insert "\n (this binding is currently shadowed)") - (goto-char (min (1+ (point)) (point-max))))) + (when (or (not (eq start end)) + ;; Don't output keymap prefixes. + (not (keymapp definition))) + (when first + (insert "\n") + (setq first nil)) + ;; Now START .. END is the range to describe next. + ;; Insert the string to describe the event START. + (setq line-start (point)) + (insert (help--key-description-fontified (vector start) prefix)) + (when (not (eq start end)) + (insert " .. " (help--key-description-fontified (vector end) + prefix))) + (setq key-end (point) + column (current-column)) + ;; Print a description of the definition of this character. + ;; Called function will take care of spacing out far enough + ;; for alignment purposes. + (help--describe-command definition transl) + (push (list column line-start key-end (1- (point))) columns) + ;; Print a description of the definition of this character. + ;; elt_describer will take care of spacing out far enough for + ;; alignment purposes. + (when shadowed + (goto-char (max (1- (point)) (point-min))) + (insert "\n (this binding is currently shadowed)") + (goto-char (min (1+ (point)) (point-max)))))) ;; Next item in list. - (setq vect (cdr vect)))))) + (setq vect (cdr vect))) + (when columns + (describe-map--align-section columns))))) + +(defun describe-map--align-section (columns) + (save-excursion + (let ((max-key (apply #'max (mapcar #'car columns)))) + (cond + ;; It's fine to use the minimum, so just do it, but quantize to + ;; two different widths, because having each block align slightly + ;; differently looks untidy. + ((< max-key 16) + (describe-map--fill-columns columns 16)) + ((< max-key 24) + (describe-map--fill-columns columns 24)) + ((< max-key 32) + (describe-map--fill-columns columns 32)) + ;; We have some really wide ones in this block. + (t + (let ((window-width (window-width)) + (max-def (apply #'max (mapcar + (lambda (elem) + (- (nth 3 elem) (nth 2 elem))) + columns)))) + (if (< (+ max-def (max 16 max-key)) window-width) + ;; Can we do the block without continuation lines? Then do that. + (describe-map--fill-columns columns (1+ (max 16 max-key))) + ;; No, do continuation lines for some definitions. + (dolist (elem columns) + (goto-char (caddr elem)) + (if (< (+ (car elem) (- (nth 3 elem) (nth 2 elem))) window-width) + ;; Indent. + (insert-char ?\s (- (1+ max-key) (car elem))) + ;; Continuation. + (insert "\n") + (insert-char ?\t 2)))))))))) + +(defun describe-map--fill-columns (columns width) + (dolist (elem columns) + (goto-char (caddr elem)) + (let ((tabs (- (/ width tab-width) + (/ (car elem) tab-width)))) + (insert-char ?\t tabs) + (insert-char ?\s (if (zerop tabs) + (- width (car elem)) + (mod width tab-width)))))) ;;;; This Lisp version is 100 times slower than its C equivalent: ;; @@ -1606,10 +1706,16 @@ and some others." (add-hook 'temp-buffer-show-hook 'resize-temp-buffer-window 'append) (remove-hook 'temp-buffer-show-hook 'resize-temp-buffer-window))) +(defvar resize-temp-buffer-window-inhibit nil + "Non-nil means `resize-temp-buffer-window' should not resize.") + (defun resize-temp-buffer-window (&optional window) "Resize WINDOW to fit its contents. WINDOW must be a live window and defaults to the selected one. -Do not resize if WINDOW was not created by `display-buffer'. +Do not resize if WINDOW was not created by `display-buffer'. Do +not resize either if a `window-height', `window-width' or +`window-size' entry in `display-buffer-alist' prescribes some +alternative resizing for WINDOW's buffer. If WINDOW is part of a vertical combination, restrain its new size by `temp-buffer-max-height' and do not resize if its minimum @@ -1624,27 +1730,33 @@ provided `fit-frame-to-buffer' is non-nil. This function may call `preserve-window-size' to preserve the size of WINDOW." (setq window (window-normalize-window window t)) - (let ((height (if (functionp temp-buffer-max-height) + (let* ((buffer (window-buffer window)) + (height (if (functionp temp-buffer-max-height) + (with-selected-window window + (funcall temp-buffer-max-height buffer)) + temp-buffer-max-height)) + (width (if (functionp temp-buffer-max-width) (with-selected-window window - (funcall temp-buffer-max-height (window-buffer))) - temp-buffer-max-height)) - (width (if (functionp temp-buffer-max-width) - (with-selected-window window - (funcall temp-buffer-max-width (window-buffer))) - temp-buffer-max-width)) - (quit-cadr (cadr (window-parameter window 'quit-restore)))) - ;; Resize WINDOW iff it was made by `display-buffer'. + (funcall temp-buffer-max-width buffer)) + temp-buffer-max-width)) + (quit-cadr (cadr (window-parameter window 'quit-restore)))) + ;; Resize WINDOW only if it was made by `display-buffer'. (when (or (and (eq quit-cadr 'window) (or (and (window-combined-p window) (not (eq fit-window-to-buffer-horizontally 'only)) - (pos-visible-in-window-p (point-min) window)) + (pos-visible-in-window-p + (with-current-buffer buffer (point-min)) + window) + (not resize-temp-buffer-window-inhibit)) (and (window-combined-p window t) - fit-window-to-buffer-horizontally))) + fit-window-to-buffer-horizontally + (not resize-temp-buffer-window-inhibit)))) (and (eq quit-cadr 'frame) fit-frame-to-buffer - (eq window (frame-root-window window)))) - (fit-window-to-buffer window height nil width nil t)))) + (eq window (frame-root-window window)) + (not resize-temp-buffer-window-inhibit))) + (fit-window-to-buffer window height nil width nil t)))) ;;; Help windows. (defcustom help-window-select nil @@ -1754,13 +1866,13 @@ Return VALUE." (cond ((eq help-setup 'window) ;; ... and is new, ... - "Type \"q\" to delete help window") + "Type \\<help-map>\\[help-quit] to delete help window") ((eq help-setup 'frame) ;; ... on a new frame, ... - "Type \"q\" to quit the help frame") + "Type \\<help-map>\\[help-quit] to quit the help frame") ((eq help-setup 'other) ;; ... or displayed some other buffer before. - "Type \"q\" to restore previous buffer")) + "Type \\<help-map>\\[help-quit] to restore previous buffer")) window t)) ((and (eq (window-frame window) help-window-old-frame) (= (length (window-list nil 'no-mini)) 2)) @@ -1771,7 +1883,7 @@ Return VALUE." ((eq help-setup 'window) "Type \\[delete-other-windows] to delete the help window") ((eq help-setup 'other) - "Type \"q\" in help window to restore its previous buffer")) + "Type \\<help-map>\\[help-quit] in help window to restore its previous buffer")) window 'other)) (t ;; The help window is not selected ... @@ -1779,10 +1891,10 @@ Return VALUE." (cond ((eq help-setup 'window) ;; ... and is new, ... - "Type \"q\" in help window to delete it") + "Type \\<help-map>\\[help-quit] in help window to delete it") ((eq help-setup 'other) ;; ... or displayed some other buffer before. - "Type \"q\" in help window to restore previous buffer")) + "Type \\<help-map>\\[help-quit] in help window to restore previous buffer")) window)))) ;; Return VALUE. value)) diff --git a/lisp/htmlfontify.el b/lisp/htmlfontify.el index 9fe6e825f78..8dc4cce3239 100644 --- a/lisp/htmlfontify.el +++ b/lisp/htmlfontify.el @@ -77,6 +77,7 @@ ;; Changes: moved to changelog (CHANGES) file. ;;; Code: + (eval-when-compile (require 'cl-lib)) (require 'cus-edit) @@ -2307,10 +2308,6 @@ See also `hfy-load-tags-cache'." (interactive "D source directory: ") (hfy-load-tags-cache (directory-file-name srcdir))) -;;(defun hfy-test-read-args (foo bar) -;; (interactive "D source directory: \nD target directory: ") -;; (message "foo: %S\nbar: %S" foo bar)) - (defun hfy-save-kill-buffers (buffer-list &optional dstdir) (dolist (B buffer-list) (set-buffer B) diff --git a/lisp/ibuf-ext.el b/lisp/ibuf-ext.el index 5b69a878e21..2d2365dc34d 100644 --- a/lisp/ibuf-ext.el +++ b/lisp/ibuf-ext.el @@ -1597,7 +1597,10 @@ to move by. The default is `ibuffer-marked-char'." "Hide all of the currently marked lines." (interactive) (if (= (ibuffer-count-marked-lines) 0) - (message "No buffers marked; use `m' to mark a buffer") + (message (substitute-command-keys + (concat + "No buffers marked; use \\<ibuffer-mode-map>" + "\\[ibuffer-mark-forward] to mark a buffer"))) (let ((count (ibuffer-map-marked-lines (lambda (_buf _mark) diff --git a/lisp/ibuffer.el b/lisp/ibuffer.el index 233127b0112..b461197abe9 100644 --- a/lisp/ibuffer.el +++ b/lisp/ibuffer.el @@ -1257,7 +1257,9 @@ Otherwise, toggle lock status." "Unmark all buffers with mark MARK." (interactive "cRemove marks (RET means all):") (if (= (ibuffer-count-marked-lines t) 0) - (message "No buffers marked; use `m' to mark a buffer") + (message (substitute-command-keys + "No buffers marked; use \\<ibuffer-mode-map>\ +\\[ibuffer-mark-forward] to mark a buffer")) (let ((fn (lambda (_buf mk) (unless (eq mk ?\s) (ibuffer-set-mark-1 ?\s)) t))) diff --git a/lisp/icomplete.el b/lisp/icomplete.el index 01033474d38..f909a3b1771 100644 --- a/lisp/icomplete.el +++ b/lisp/icomplete.el @@ -380,13 +380,17 @@ if that doesn't produce a completion match." (defun icomplete-fido-backward-updir () "Delete char before or go up directory, like `ido-mode'." (interactive) - (if (and (eq (char-before) ?/) - (eq (icomplete--category) 'file)) - (save-excursion - (goto-char (1- (point))) - (when (search-backward "/" (point-min) t) - (delete-region (1+ (point)) (point-max)))) - (call-interactively 'backward-delete-char))) + (cond ((and (eq (char-before) ?/) + (eq (icomplete--category) 'file)) + (when (string-equal (icomplete--field-string) "~/") + (delete-region (icomplete--field-beg) (icomplete--field-end)) + (insert (expand-file-name "~/")) + (goto-char (line-end-position))) + (save-excursion + (goto-char (1- (point))) + (when (search-backward "/" (point-min) t) + (delete-region (1+ (point)) (point-max))))) + (t (call-interactively 'backward-delete-char)))) (defvar icomplete-fido-mode-map (let ((map (make-sparse-keymap))) @@ -716,11 +720,6 @@ See `icomplete-mode' and `minibuffer-setup-hook'." (delete-region (overlay-start rfn-eshadow-overlay) (overlay-end rfn-eshadow-overlay))) (let* ((field-string (icomplete--field-string)) - ;; Not sure why, but such requests seem to come - ;; every once in a while. It's not fully - ;; deterministic but `C-x C-f M-DEL M-DEL ...' - ;; seems to trigger it fairly often! - (while-no-input-ignore-events '(selection-request)) (text (while-no-input (icomplete-completions field-string diff --git a/lisp/ido.el b/lisp/ido.el index 7c2d2eb0d75..6767d669880 100644 --- a/lisp/ido.el +++ b/lisp/ido.el @@ -354,8 +354,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 (or value 0))) + :set (lambda (_symbol value) + (ido-mode (or value 0))) :initialize #'custom-initialize-default :require 'ido :link '(emacs-commentary-link "ido.el") @@ -620,9 +620,9 @@ hosts on first use of UNC path." (function-item :tag "Use `NET VIEW'" :value ido-unc-hosts-net-view) (function :tag "Your own function")) - :set #'(lambda (symbol value) - (set symbol value) - (setq ido-unc-hosts-cache t))) + :set (lambda (symbol value) + (set symbol value) + (setq ido-unc-hosts-cache t))) (defcustom ido-downcase-unc-hosts t "Non-nil if UNC host names should be downcased." diff --git a/lisp/ielm.el b/lisp/ielm.el index 39820a893a9..ec7f010a4d5 100644 --- a/lisp/ielm.el +++ b/lisp/ielm.el @@ -148,28 +148,28 @@ such as `edebug-defun' to work with such inputs." This variable is buffer-local.") (defvar ielm-header - "*** Welcome to IELM *** Type (describe-mode) for help.\n" + (substitute-command-keys + "*** Welcome to IELM *** Type (describe-mode) or press \ +\\[describe-mode] for help.\n") "Message to display when IELM is started.") (defvaralias 'inferior-emacs-lisp-mode-map 'ielm-map) -(defvar ielm-map - (let ((map (make-sparse-keymap))) - (define-key map "\t" 'ielm-tab) - (define-key map "\C-m" 'ielm-return) - (define-key map "\e\C-m" 'ielm-return-for-effect) - (define-key map "\C-j" 'ielm-send-input) - (define-key map "\e\C-x" 'eval-defun) ; for consistency with - (define-key map "\e\t" 'completion-at-point) ; lisp-interaction-mode - ;; These bindings are from `lisp-mode-shared-map' -- can you inherit - ;; from more than one keymap?? - (define-key map "\e\C-q" 'indent-sexp) - (define-key map "\177" 'backward-delete-char-untabify) - ;; Some convenience bindings for setting the working buffer - (define-key map "\C-c\C-b" 'ielm-change-working-buffer) - (define-key map "\C-c\C-f" 'ielm-display-working-buffer) - (define-key map "\C-c\C-v" 'ielm-print-working-buffer) - map) - "Keymap for IELM mode.") +(defvar-keymap ielm-map + :doc "Keymap for IELM mode." + "TAB" #'ielm-tab + "RET" #'ielm-return + "M-RET" #'ielm-return-for-effect + "C-j" #'ielm-send-input + "C-M-x" #'eval-defun ; for consistency with + "M-TAB" #'completion-at-point ; lisp-interaction-mode + ;; These bindings are from `lisp-mode-shared-map' -- can you inherit + ;; from more than one keymap?? + "C-M-q" #'indent-sexp + "DEL" #'backward-delete-char-untabify + ;; Some convenience bindings for setting the working buffer + "C-c C-b" #'ielm-change-working-buffer + "C-c C-f" #'ielm-display-working-buffer + "C-c C-v" #'ielm-print-working-buffer) (easy-menu-define ielm-menu ielm-map "IELM mode menu." diff --git a/lisp/image-dired.el b/lisp/image-dired.el index 3ac44dac9fb..6ca0cd8831d 100644 --- a/lisp/image-dired.el +++ b/lisp/image-dired.el @@ -1,7 +1,7 @@ ;;; image-dired.el --- use dired to browse and manipulate your images -*- lexical-binding: t -*- -;; + ;; Copyright (C) 2005-2021 Free Software Foundation, Inc. -;; + ;; Version: 0.4.11 ;; Keywords: multimedia ;; Author: Mathias Dahl <mathias.rem0veth1s.dahl@gmail.com> @@ -22,7 +22,7 @@ ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: -;; + ;; BACKGROUND ;; ========== ;; @@ -59,19 +59,22 @@ ;; PREREQUISITES ;; ============= ;; -;; * The ImageMagick package. Currently, `convert' and `mogrify' are -;; used. Find it here: https://www.imagemagick.org. +;; * The GraphicsMagick or ImageMagick package; Image-Dired uses +;; whichever is available. +;; +;; A) For GraphicsMagick, `gm' is used. +;; Find it here: http://www.graphicsmagick.org/ +;; +;; B) For ImageMagick, `convert' and `mogrify' are used. +;; Find it here: https://www.imagemagick.org. ;; ;; * For non-lossy rotation of JPEG images, the JpegTRAN program is -;; needed. +;; needed. ;; -;; * For `image-dired-get-exif-data' and `image-dired-set-exif-data' to work, -;; the command line tool `exiftool' is needed. It can be found here: -;; https://exiftool.org/. These two functions are, among other -;; things, used for writing comments to image files using -;; `image-dired-thumbnail-set-image-description' and to create -;; "unique" file names using `image-dired-get-exif-file-name' (used by -;; `image-dired-copy-with-exif-file-name'). +;; * For `image-dired-set-exif-data' to work, the command line tool `exiftool' is +;; needed. It can be found here: https://exiftool.org/. This +;; function is, among other things, used for writing comments to +;; image files using `image-dired-thumbnail-set-image-description'. ;; ;; ;; USAGE @@ -89,73 +92,60 @@ ;; =========== ;; ;; * Supports all image formats that Emacs and convert supports, but -;; the thumbnails are hard-coded to JPEG format. +;; the thumbnails are hard-coded to JPEG or PNG format. It uses +;; JPEG by default, but can optionally follow the Thumbnail Managing +;; Standard (v0.9.0, Dec 2020), which mandates PNG. See the user +;; option `image-dired-thumbnail-storage'. ;; ;; * WARNING: The "database" format used might be changed so keep a -;; backup of `image-dired-db-file' when testing new versions. -;; -;; * `image-dired-display-image-mode' does not support animation +;; backup of `image-dired-db-file' when testing new versions. ;; ;; TODO ;; ==== ;; -;; * Support gallery creation when using per-directory thumbnail -;; storage. -;; -;; * Some sort of auto-rotate function based on rotate info in the -;; EXIF data. -;; ;; * Investigate if it is possible to also write the tags to the image -;; files. +;; files. ;; ;; * From thumbs.el: Add an option for clean-up/max-size functionality ;; for thumbnail directory. ;; ;; * From thumbs.el: Add setroot function. ;; -;; * From thumbs.el: Add image resizing, if useful (image-dired's automatic -;; "image fit" might be enough) -;; -;; * From thumbs.el: Add the "modify" commands (emboss, negate, -;; monochrome etc). -;; -;; * Add `image-dired-display-thumbs-ring' and functions to cycle that. Find -;; out which is best, saving old batch just before inserting new, or -;; saving the current batch in the ring when inserting it. Adding it -;; probably needs rewriting `image-dired-display-thumbs' to be more general. +;; * Add `image-dired-display-thumbs-ring' and functions to cycle that. Find out +;; which is best, saving old batch just before inserting new, or +;; saving the current batch in the ring when inserting it. Adding +;; it probably needs rewriting `image-dired-display-thumbs' to be more general. ;; ;; * Find some way of toggling on and off really nice keybindings in -;; dired (for example, using C-n or <down> instead of C-S-n). Richard -;; suggested that we could keep C-t as prefix for image-dired commands -;; as it is currently not used in dired. He also suggested that -;; `dired-next-line' and `dired-previous-line' figure out if -;; image-dired is enabled in the current buffer and, if it is, call -;; `image-dired-dired-next-line' and -;; `image-dired-dired-previous-line', respectively. Update: This is -;; partly done; some bindings have now been added to dired. -;; -;; * Enhanced gallery creation with basic CSS-support and pagination -;; of tag pages with many pictures. -;; -;; * Rewrite `image-dired-modify-mark-on-thumb-original-file' to be -;; less ugly. +;; Dired (for example, using C-n or <down> instead of C-S-n). +;; Richard suggested that we could keep C-t as prefix for +;; image-dired commands as it is currently not used in Dired. He +;; also suggested that `dired-next-line' and `dired-previous-line' +;; figure out if image-dired is enabled in the current buffer and, +;; if it is, call `image-dired-dired-next-line' and `image-dired-dired-previous-line', +;; respectively. Update: This is partly done; some bindings have +;; now been added to Dired. ;; ;; * In some way keep track of buffers and windows and stuff so that -;; it works as the user expects. -;; -;; * More/better documentation -;; +;; it works as the user expects. ;; +;; * More/better documentation. + ;;; Code: (require 'dired) +(require 'exif) (require 'image-mode) (require 'widget) +(require 'xdg) (eval-when-compile (require 'cl-lib) (require 'wid-edit)) + +;;; Customizable variables + (defgroup image-dired nil "Use Dired to browse your images as thumbnails, and more." :prefix "image-dired-" @@ -165,108 +155,105 @@ (defcustom image-dired-dir (locate-user-emacs-file "image-dired/") "Directory where thumbnail images are stored. -The value of this option will be ignored if Image Dired is +The value of this option will be ignored if Image-Dired is customized to use the Thumbnail Managing Standard; they will be saved in \"$XDG_CACHE_HOME/thumbnails/\" instead. See `image-dired-thumbnail-storage'." :type 'directory) (defcustom image-dired-thumbnail-storage 'use-image-dired-dir - "How to store image-dired's thumbnail files. -Image-Dired can store thumbnail files in one of two ways and this is -controlled by this variable. \"Use image-dired dir\" means that the -thumbnails are stored in a central directory. \"Per directory\" -means that each thumbnail is stored in a subdirectory called -\".image-dired\" in the same directory where the image file is. -\"Thumbnail Managing Standard\" means that the thumbnails are -stored and generated according to the Thumbnail Managing Standard -that allows sharing of thumbnails across different programs." + "How `image-dired' stores thumbnail files. +There are two ways that Image-Dired can store and generate +thumbnails. If you set this variable to one of the two following +values, they will be stored in the JPEG format: + +- `use-image-dired-dir' means that the thumbnails are stored in a + central directory. + +- `per-directory' means that each thumbnail is stored in a + subdirectory called \".image-dired\" in the same directory + where the image file is. + +It can also use the \"Thumbnail Managing Standard\", which allows +sharing of thumbnails across different programs. Thumbnails will +be stored in \"$XDG_CACHE_HOME/thumbnails/\" instead of in +`image-dired-dir'. Thumbnails are saved in the PNG format, and +can be one of the following sizes: + +- `standard' means use thumbnails sized 128x128. +- `standard-large' means use thumbnails sized 256x256. +- `standard-x-large' means use thumbnails sized 512x512. +- `standard-xx-large' means use thumbnails sized 1024x1024. + +For more information on the Thumbnail Managing Standard, see: +https://specifications.freedesktop.org/thumbnail-spec/thumbnail-spec-latest.html" :type '(choice :tag "How to store thumbnail files" (const :tag "Use image-dired-dir" use-image-dired-dir) - (const :tag "Thumbnail Managing Standard (normal 128x128)" standard) - (const :tag "Thumbnail Managing Standard (large 256x256)" standard-large) - (const :tag "Per-directory" per-directory))) + (const :tag "Thumbnail Managing Standard (normal 128x128)" + standard) + (const :tag "Thumbnail Managing Standard (large 256x256)" + standard-large) + (const :tag "Thumbnail Managing Standard (larger 512x512)" + standard-x-large) + (const :tag "Thumbnail Managing Standard (extra large 1024x1024)" + standard-xx-large) + (const :tag "Per-directory" per-directory)) + :version "29.1") + +(defconst image-dired--thumbnail-standard-sizes + '( standard standard-large + standard-x-large standard-xx-large) + "List of symbols representing thumbnail sizes in Thumbnail Managing Standard.") (defcustom image-dired-db-file (expand-file-name ".image-dired_db" image-dired-dir) "Database file where file names and their associated tags are stored." :type 'file) -(defcustom image-dired-temp-image-file - (expand-file-name ".image-dired_temp" image-dired-dir) - "Name of temporary image file used by various commands." - :type 'file) - -(defcustom image-dired-gallery-dir - (expand-file-name ".image-dired_gallery" image-dired-dir) - "Directory to store generated gallery html pages. -This path needs to be \"shared\" to the public so that it can access -the index.html page that image-dired creates." - :type 'directory) - -(defcustom image-dired-gallery-image-root-url -"https://your.own.server/image-diredpics" - "URL where the full size images are to be found. -Note that this path has to be configured in your web server. Image-Dired -expects to find pictures in this directory." - :type 'string) - -(defcustom image-dired-gallery-thumb-image-root-url -"https://your.own.server/image-diredthumbs" - "URL where the thumbnail images are to be found. -Note that this path has to be configured in your web server. Image-Dired -expects to find pictures in this directory." - :type 'string) - (defcustom image-dired-cmd-create-thumbnail-program - "convert" + (if (executable-find "gm") "gm" "convert") "Executable used to create thumbnail. Used together with `image-dired-cmd-create-thumbnail-options'." - :type 'file) + :type 'file + :version "29.1") (defcustom image-dired-cmd-create-thumbnail-options - '("-size" "%wx%h" "%f[0]" "-resize" "%wx%h>" "-strip" "jpeg:%t") + (let ((opts '("-size" "%wx%h" "%f[0]" + "-resize" "%wx%h>" + "-strip" "jpeg:%t"))) + (if (executable-find "gm") (cons "convert" opts) opts)) "Options of command used to create thumbnail image. Used with `image-dired-cmd-create-thumbnail-program'. Available format specifiers are: %w which is replaced by `image-dired-thumb-width', %h which is replaced by `image-dired-thumb-height', %f which is replaced by the file name of the original image and %t which is replaced by the file name of the thumbnail file." - :version "26.1" - :type '(repeat (string :tag "Argument"))) - -(defcustom image-dired-cmd-create-temp-image-program "convert" - "Executable used to create temporary image. -Used together with `image-dired-cmd-create-temp-image-options'." - :type 'file) - -(defcustom image-dired-cmd-create-temp-image-options - '("-size" "%wx%h" "%f[0]" "-resize" "%wx%h>" "-strip" "jpeg:%t") - "Options of command used to create temporary image for display window. -Used together with `image-dired-cmd-create-temp-image-program', -Available format specifiers are: %w and %h which are replaced by -the calculated max size for width and height in the image display window, -%f which is replaced by the file name of the original image and %t which -is replaced by the file name of the temporary file." - :version "26.1" + :version "29.1" :type '(repeat (string :tag "Argument"))) (defcustom image-dired-cmd-pngnq-program - (or (executable-find "pngnq") - (executable-find "pngnq-s9")) - "The file name of the `pngnq' program. + ;; Prefer pngquant to pngnq-s9 as it is faster on my machine. + ;; The project also seems more active than the alternatives. + ;; Prefer pngnq-s9 to pngnq as it fixes bugs in pngnq. + ;; The pngnq project seems dead (?) since 2011 or so. + (or (executable-find "pngquant") + (executable-find "pngnq-s9") + (executable-find "pngnq")) + "The file name of the `pngquant' or `pngnq' program. It quantizes colors of PNG images down to 256 colors or fewer using the NeuQuant algorithm." - :version "26.1" + :version "29.1" :type '(choice (const :tag "Not Set" nil) file)) (defcustom image-dired-cmd-pngnq-options - '("-f" "%t") + (if (executable-find "pngquant") + '("--ext" "-nq8.png" "%t") ; same extension as "pngnq" + '("-f" "%t")) "Arguments to pass `image-dired-cmd-pngnq-program'. Available format specifiers are the same as in `image-dired-cmd-create-thumbnail-options'." - :version "26.1" - :type '(repeat (string :tag "Argument"))) + :type '(repeat (string :tag "Argument")) + :version "29.1") (defcustom image-dired-cmd-pngcrush-program (executable-find "pngcrush") "The file name of the `pngcrush' program. @@ -321,23 +308,6 @@ Available format specifiers are the same as in :version "26.1" :type '(repeat (string :tag "Argument"))) -(defcustom image-dired-cmd-rotate-thumbnail-program - "mogrify" - "Executable used to rotate thumbnail. -Used together with `image-dired-cmd-rotate-thumbnail-options'." - :type 'file) - -(defcustom image-dired-cmd-rotate-thumbnail-options - '("-rotate" "%d" "%t") - "Arguments of command used to rotate thumbnail image. -Used with `image-dired-cmd-rotate-thumbnail-program'. -Available format specifiers are: %d which is replaced by the -number of (positive) degrees to rotate the image, normally 90 or 270 -\(for 90 degrees right and left), %t which is replaced by the file name -of the thumbnail file." - :version "26.1" - :type '(repeat (string :tag "Argument"))) - (defcustom image-dired-cmd-rotate-original-program "jpegtran" "Executable used to rotate original image. @@ -383,37 +353,18 @@ which is replaced by the tag value." :version "26.1" :type '(repeat (string :tag "Argument"))) -(defcustom image-dired-cmd-read-exif-data-program - "exiftool" - "Program used to read EXIF data to image. -Used together with `image-dired-cmd-read-exif-data-options'." - :type 'file) - -(defcustom image-dired-cmd-read-exif-data-options - '("-s" "-s" "-s" "-%t" "%f") - "Arguments of command used to read EXIF data. -Used with `image-dired-cmd-read-exif-data-program'. -Available format specifiers are: %f which is replaced -by the image file name and %t which is replaced by the tag name." - :version "26.1" - :type '(repeat (string :tag "Argument"))) - -(defcustom image-dired-gallery-hidden-tags - (list "private" "hidden" "pending") - "List of \"hidden\" tags. -Used by `image-dired-gallery-generate' to leave out \"hidden\" images." - :type '(repeat string)) - (defcustom image-dired-thumb-size (cond ((eq 'standard image-dired-thumbnail-storage) 128) ((eq 'standard-large image-dired-thumbnail-storage) 256) + ((eq 'standard-x-large image-dired-thumbnail-storage) 512) + ((eq 'standard-xx-large image-dired-thumbnail-storage) 1024) (t 100)) "Size of thumbnails, in pixels. This is the default size for both `image-dired-thumb-width' and `image-dired-thumb-height'. -The value of this option will be ignored if Image Dired is +The value of this option will be ignored if Image-Dired is customized to use the Thumbnail Managing Standard; the standard sizes will be used instead. See `image-dired-thumbnail-storage'." :type 'integer) @@ -436,17 +387,28 @@ This is where you see the cursor." :type 'integer) (defcustom image-dired-thumb-visible-marks t - "Make marks visible in thumbnail buffer. + "Make marks and flags visible in thumbnail buffer. If non-nil, apply the `image-dired-thumb-mark' face to marked -images." +images and `image-dired-thumb-flagged' to images flagged for +deletion." :type 'boolean :version "28.1") (defface image-dired-thumb-mark - '((t (:background "orange"))) - "Background-color for marked images in thumbnail buffer." - :group 'image-dired - :version "28.1") + '((((class color) (min-colors 16)) :background "DarkOrange") + (((class color)) :foreground "yellow")) + "Face for marked images in thumbnail buffer." + :version "29.1") + +(defface image-dired-thumb-flagged + '((((class color) (min-colors 88) (background light)) :background "Red3") + (((class color) (min-colors 88) (background dark)) :background "Pink") + (((class color) (min-colors 16) (background light)) :background "Red3") + (((class color) (min-colors 16) (background dark)) :background "Pink") + (((class color) (min-colors 8)) :background "red") + (t :inverse-video t)) + "Face for images flagged for deletion in thumbnail buffer." + :version "29.1") (defcustom image-dired-line-up-method 'dynamic "Default method for line-up of thumbnails in thumbnail buffer. @@ -465,18 +427,6 @@ and No line-up means that no automatic line-up will be done." "Number of thumbnails to display per row in thumb buffer." :type 'integer) -(defcustom image-dired-display-window-width-correction 1 - "Number to be used to correct image display window width. -Change if the default (1) does not work (i.e. if the image does not -completely fit)." - :type 'integer) - -(defcustom image-dired-display-window-height-correction 0 - "Number to be used to correct image display window height. -Change if the default (0) does not work (i.e. if the image does not -completely fit)." - :type 'integer) - (defcustom image-dired-track-movement t "The current state of the tracking and mirroring. For more information, see the documentation for @@ -522,15 +472,45 @@ Including parameters. Used when displaying original image from :type '(choice string (const :tag "Not Set" nil))) -(defcustom image-dired-main-image-directory "~/pics/" +(defcustom image-dired-main-image-directory + (or (xdg-user-dir "PICTURES") "~/pics/") "Name of main image directory, if any. Used by `image-dired-copy-with-exif-file-name'." - :type 'string) + :type 'string + :version "29.1") + +(defcustom image-dired-show-all-from-dir-max-files 500 + "Maximum number of files in directory before prompting. + +If there are more image files than this in a selected directory, +the `image-dired-show-all-from-dir' command will ask for +confirmation before creating the thumbnail buffer. If this +variable is nil, it will never ask." + :type '(choice integer + (const :tag "Disable warning" nil)) + :version "29.1") + +(defcustom image-dired-marking-shows-next t + "If non-nil, marking, unmarking or flagging an image shows the next image. + +This affects the following commands: +\\<image-dired-thumbnail-mode-map> + `image-dired-flag-thumb-original-file' (bound to \\[image-dired-flag-thumb-original-file]) + `image-dired-mark-thumb-original-file' (bound to \\[image-dired-mark-thumb-original-file]) + `image-dired-unmark-thumb-original-file' (bound to \\[image-dired-unmark-thumb-original-file])" + :type 'boolean + :version "29.1") -(defcustom image-dired-show-all-from-dir-max-files 50 - "Maximum number of files to show using `image-dired-show-all-from-dir' -before warning." - :type 'integer) + +;;; Util functions + +(defvar image-dired-debug nil + "Non-nil means enable debug messages.") + +(defun image-dired-debug-message (&rest args) + "Display debug message ARGS when `image-dired-debug' is non-nil." + (when image-dired-debug + (apply #'message args))) (defmacro image-dired--with-db-file (&rest body) "Run BODY in a temp buffer containing `image-dired-db-file'. @@ -542,14 +522,14 @@ Return the last form in BODY." ,@body)) (defun image-dired-dir () - "Return the current thumbnails directory (from variable `image-dired-dir'). -Create the thumbnails directory if it does not exist." + "Return the current thumbnail directory (from variable `image-dired-dir'). +Create the thumbnail directory if it does not exist." (let ((image-dired-dir (file-name-as-directory - (expand-file-name image-dired-dir)))) + (expand-file-name image-dired-dir)))) (unless (file-directory-p image-dired-dir) (with-file-modes #o700 (make-directory image-dired-dir t)) - (message "Creating thumbnails directory")) + (message "Thumbnail directory created: %s" image-dired-dir)) image-dired-dir)) (defun image-dired-insert-image (file type relief margin) @@ -562,7 +542,7 @@ Create the thumbnails directory if it does not exist." (defun image-dired-get-thumbnail-image (file) "Return the image descriptor for a thumbnail of image file FILE." - (unless (string-match (image-file-name-regexp) file) + (unless (string-match-p (image-file-name-regexp) file) (error "%s is not a valid image file" file)) (let* ((thumb-file (image-dired-thumb-name file)) (thumb-attr (file-attributes thumb-file))) @@ -571,11 +551,7 @@ Create the thumbnails directory if it does not exist." (file-attribute-modification-time (file-attributes file)))) (image-dired-create-thumb file thumb-file)) - (create-image thumb-file) -;; (list 'image :type 'jpeg -;; :file thumb-file -;; :relief image-dired-thumb-relief :margin image-dired-thumb-margin) - )) + (create-image thumb-file))) (defun image-dired-insert-thumbnail (file original-file-name associated-dired-buffer) @@ -583,13 +559,19 @@ Create the thumbnails directory if it does not exist." Add text properties ORIGINAL-FILE-NAME and ASSOCIATED-DIRED-BUFFER." (let (beg end) (setq beg (point)) - (image-dired-insert-image file - ;; TODO: this should depend on the real file type - (if (memq image-dired-thumbnail-storage - '(standard standard-large)) - 'png 'jpeg) - image-dired-thumb-relief - image-dired-thumb-margin) + (image-dired-insert-image + file + ;; Thumbnails are created asynchronously, so we might not yet + ;; have a file. But if it exists, it might have been cached from + ;; before and we should use it instead of our current settings. + (or (and (file-exists-p file) + (image-type-from-file-header file)) + (and (memq image-dired-thumbnail-storage + image-dired--thumbnail-standard-sizes) + 'png) + 'jpeg) + image-dired-thumb-relief + image-dired-thumb-margin) (setq end (point)) (add-text-properties beg end @@ -601,35 +583,39 @@ Add text properties ORIGINAL-FILE-NAME and ASSOCIATED-DIRED-BUFFER." 'comment (image-dired-get-comment original-file-name))))) (defun image-dired-thumb-name (file) - "Return thumbnail file name for FILE. -Depending on the value of `image-dired-thumbnail-storage', the file -name will vary. For central thumbnail file storage, make a -MD5-hash of the image file's directory name and add that to make -the thumbnail file name unique. For per-directory storage, just -add a subdirectory. For standard storage, produce the file name -according to the Thumbnail Managing Standard." - (cond ((memq image-dired-thumbnail-storage '(standard standard-large)) - (let* ((xdg (getenv "XDG_CACHE_HOME")) - (dir (if (and xdg (file-name-absolute-p xdg)) - xdg "~/.cache")) - (thumbdir (cl-case image-dired-thumbnail-storage - (standard "thumbnails/normal") - (standard-large "thumbnails/large")))) + "Return absolute file name for thumbnail FILE. +Depending on the value of `image-dired-thumbnail-storage', the +file name of the thumbnail will vary: +- For `use-image-dired-dir', make a SHA1-hash of the image file's + directory name and add that to make the thumbnail file name + unique. +- For `per-directory' storage, just add a subdirectory. +- For `standard' storage, produce the file name according to the + Thumbnail Managing Standard. Among other things, an MD5-hash + of the image file's directory name will be added to the + filename. +See also `image-dired-thumbnail-storage'." + (cond ((memq image-dired-thumbnail-storage + image-dired--thumbnail-standard-sizes) + (let ((thumbdir (cl-case image-dired-thumbnail-storage + (standard "thumbnails/normal") + (standard-large "thumbnails/large") + (standard-x-large "thumbnails/x-large") + (standard-xx-large "thumbnails/xx-large")))) (expand-file-name + ;; MD5 is mandated by the Thumbnail Managing Standard. (concat (md5 (concat "file://" (expand-file-name file))) ".png") - (expand-file-name thumbdir dir)))) + (expand-file-name thumbdir (xdg-cache-home))))) ((eq 'use-image-dired-dir image-dired-thumbnail-storage) (let* ((f (expand-file-name file)) - (md5-hash - ;; Is MD5 hashes fast enough? The checksum of a - ;; thumbnail file name need not be that - ;; "cryptographically" good so a faster one could - ;; be used here. - (md5 (file-name-as-directory (file-name-directory f))))) + (hash + ;; SHA1 is slightly faster than MD5, so let's use it. + ;; (We don't need anything crytographically strong.) + (sha1 (file-name-as-directory (file-name-directory f))))) (format "%s%s%s.thumb.%s" (file-name-as-directory (expand-file-name (image-dired-dir))) (file-name-base f) - (if md5-hash (concat "_" md5-hash) "") + (if hash (concat "_" hash) "") (file-name-extension f)))) ((eq 'per-directory image-dired-thumbnail-storage) (let ((f (expand-file-name file))) @@ -642,16 +628,24 @@ according to the Thumbnail Managing Standard." (unless (executable-find (symbol-value executable)) (error "Executable %S not found" executable))) + +;;; Creating thumbnails + (defun image-dired-thumb-size (dimension) "Return thumb size depending on `image-dired-thumbnail-storage'. DIMENSION should be either the symbol `width' or `height'." (cond ((eq 'standard image-dired-thumbnail-storage) 128) ((eq 'standard-large image-dired-thumbnail-storage) 256) + ((eq 'standard-x-large image-dired-thumbnail-storage) 512) + ((eq 'standard-xx-large image-dired-thumbnail-storage) 1024) (t (cl-ecase dimension (width image-dired-thumb-width) (height image-dired-thumb-height))))) +(defvar image-dired--generate-thumbs-start nil + "Time when `display-thumbs' was called.") + (defvar image-dired-queue nil "List of items in the queue. Each item has the form (ORIGINAL-FILE TARGET-FILE).") @@ -659,11 +653,12 @@ Each item has the form (ORIGINAL-FILE TARGET-FILE).") (defvar image-dired-queue-active-jobs 0 "Number of active jobs in `image-dired-queue'.") -(defvar image-dired-queue-active-limit 2 +(defvar image-dired-queue-active-limit (min 4 (max 2 (/ (num-processors) 2))) "Maximum number of concurrent jobs permitted for generating images. -Increase at own risk.") - -(defvar image-dired-tag-history nil "Variable holding the tag history.") +Increase at own risk. If you want to experiment with this, +consider setting `image-dired-debug' to a non-nil value to see +the time spent on generating thumbnails. Run `image-clear-cache' +and remove the cached thumbnail files between each trial run.") (defun image-dired-pngnq-thumb (spec) "Quantize thumbnail described by format SPEC with pngnq(1)." @@ -750,9 +745,9 @@ Increase at own risk.") (thumbnail-dir (file-name-directory thumbnail-file)) process) (when (not (file-exists-p thumbnail-dir)) - (message "Creating thumbnail directory") (with-file-modes #o700 - (make-directory thumbnail-dir t))) + (make-directory thumbnail-dir t)) + (message "Thumbnail directory created: %s" thumbnail-dir)) ;; Thumbnail file creation processes begin here and are marshaled ;; in a queue by `image-dired-create-thumb'. @@ -762,7 +757,7 @@ Increase at own risk.") (mapcar (lambda (arg) (format-spec arg spec)) (if (memq image-dired-thumbnail-storage - '(standard standard-large)) + image-dired--thumbnail-standard-sizes) image-dired-cmd-create-standard-thumbnail-options image-dired-cmd-create-thumbnail-options)))) @@ -771,6 +766,12 @@ Increase at own risk.") ;; Trigger next in queue once a thumbnail has been created (cl-decf image-dired-queue-active-jobs) (image-dired-thumb-queue-run) + (when (= image-dired-queue-active-jobs 0) + (image-dired-debug-message + (format-time-string + "Generated thumbnails in %s.%3N seconds" + (time-subtract nil + image-dired--generate-thumbs-start)))) (if (not (and (eq (process-status process) 'exit) (zerop (process-exit-status process)))) (message "Thumb could not be created for %s: %s" @@ -781,7 +782,7 @@ Increase at own risk.") ;; PNG thumbnail has been created since we are ;; following the XDG thumbnail spec, so try to optimize (when (memq image-dired-thumbnail-storage - '(standard standard-large)) + image-dired--thumbnail-standard-sizes) (cond ((and image-dired-cmd-pngnq-program (executable-find image-dired-cmd-pngnq-program)) @@ -895,7 +896,7 @@ Otherwise, delete overlays." (interactive) (setq image-dired-append-when-browsing (not image-dired-append-when-browsing)) - (message "Append browsing %s." + (message "Append browsing %s" (if image-dired-append-when-browsing "on" "off"))) @@ -934,15 +935,6 @@ Otherwise, delete overlays." (defvar image-dired-display-image-buffer "*image-dired-display-image*" "Where larger versions of the images are display.") -(defun image-dired-create-display-image-buffer () - "Create image display buffer and set `image-dired-display-image-mode'." - (let ((buf (get-buffer-create image-dired-display-image-buffer))) - (with-current-buffer buf - (setq buffer-read-only t) - (if (not (eq major-mode 'image-dired-display-image-mode)) - (image-dired-display-image-mode))) - buf)) - (defvar image-dired-saved-window-configuration nil "Saved window configuration.") @@ -966,7 +958,7 @@ The current window configuration is saved and can be restored by calling `image-dired-restore-window-configuration'." (interactive "DDirectory: \nP") (let ((buf (image-dired-create-thumbnail-buffer)) - (buf2 (image-dired-create-display-image-buffer))) + (buf2 (get-buffer-create image-dired-display-image-buffer))) (setq image-dired-saved-window-configuration (current-window-configuration)) (dired dir) @@ -985,7 +977,7 @@ calling `image-dired-restore-window-configuration'." "Restore window configuration. Restore any changes to the window configuration made by calling `image-dired-dired-with-window-configuration'." - (interactive) + (interactive nil image-dired-thumbnail-mode) (if image-dired-saved-window-configuration (set-window-configuration image-dired-saved-window-configuration) (message "No saved window configuration"))) @@ -1025,6 +1017,7 @@ used or not. If non-nil, use `display-buffer' instead of `image-dired-previous-line-and-display' where we do not want the thumbnail buffer to be selected." (interactive "P") + (setq image-dired--generate-thumbs-start (current-time)) (let ((buf (image-dired-create-thumbnail-buffer)) thumb-name files dired-buf) (if arg @@ -1048,30 +1041,38 @@ thumbnail buffer to be selected." ;;;###autoload (defun image-dired-show-all-from-dir (dir) - "Make a preview buffer for all images in DIR and display it. -If the number of files in DIR matching `image-file-name-regexp' -exceeds `image-dired-show-all-from-dir-max-files', a warning will be -displayed." - (interactive "DImage Dired: ") + "Make a thumbnail buffer for all images in DIR and display it. +Any file matching `image-file-name-regexp' is considered an image +file. + +If the number of image files in DIR exceeds +`image-dired-show-all-from-dir-max-files', ask for confirmation +before creating the thumbnail buffer. If that variable is nil, +never ask for confirmation." + (interactive "DImage-Dired: ") (dired dir) (dired-mark-files-regexp (image-file-name-regexp)) - (let ((files (dired-get-marked-files))) - (if (or (<= (length files) image-dired-show-all-from-dir-max-files) - (and (> (length files) image-dired-show-all-from-dir-max-files) - (y-or-n-p - (format - "Directory contains more than %d image files. Proceed? " - image-dired-show-all-from-dir-max-files)))) - (progn - (image-dired-display-thumbs) - (pop-to-buffer image-dired-thumbnail-buffer)) - (message "Canceled.")))) + (let ((files (dired-get-marked-files nil nil nil t))) + (cond ((and (null (cdr files))) + (message "No image files in directory")) + ((or (not image-dired-show-all-from-dir-max-files) + (<= (length (cdr files)) image-dired-show-all-from-dir-max-files) + (and (> (length (cdr files)) image-dired-show-all-from-dir-max-files) + (y-or-n-p + (format + "Directory contains more than %d image files. Proceed?" + image-dired-show-all-from-dir-max-files)))) + (image-dired-display-thumbs) + (pop-to-buffer image-dired-thumbnail-buffer) + (setq default-directory dir) + (image-dired-unmark-all-marks)) + (t (message "Image-Dired canceled"))))) ;;;###autoload (defalias 'image-dired 'image-dired-show-all-from-dir) -;;;###autoload -(define-obsolete-function-alias 'tumme 'image-dired "24.4") + +;;; Tags (defun image-dired-sane-db-file () "Check if `image-dired-db-file' exists. @@ -1091,6 +1092,8 @@ Signal error if there are problems creating it." (file-exists-p image-dired-db-file)) (error "Could not create %s" image-dired-db-file))) +(defvar image-dired-tag-history nil "Variable holding the tag history.") + (defun image-dired-write-tags (file-tags) "Write file tags to database. Write each file and tag in FILE-TAGS to the database. @@ -1211,6 +1214,9 @@ With prefix argument ARG, remove tag from file at point." (image-dired-update-property 'tags (image-dired-list-tags (image-dired-original-file-name)))))) + +;;; Thumbnail mode (cont.) + (defun image-dired-original-file-name () "Get original file name for thumbnail or display image at point." (get-text-property (point) 'original-file-name)) @@ -1254,7 +1260,7 @@ around in the thumbnail or dired buffer will find the matching position in the other buffer." (interactive) (setq image-dired-track-movement (not image-dired-track-movement)) - (message "Tracking %s" (if image-dired-track-movement "on" "off"))) + (message "Movement tracking %s" (if image-dired-track-movement "on" "off"))) (defun image-dired-track-thumbnail () "Track current Dired file's thumb in `image-dired-thumbnail-buffer'. @@ -1276,7 +1282,7 @@ but the other way around." (when found (if (setq window (image-dired-thumbnail-window)) (set-window-point window (point))) - (image-dired-display-thumb-properties)))))) + (image-dired-update-header-line)))))) (defun image-dired-dired-next-line (&optional arg) "Call `dired-next-line', then track thumbnail. @@ -1296,51 +1302,59 @@ With prefix argument, move ARG lines." (if image-dired-track-movement (image-dired-track-thumbnail))) -(defun image-dired-forward-image (&optional arg) +(defun image-dired--display-thumb-properties-fun () + (let ((old-buf (current-buffer)) + (old-point (point))) + (lambda () + (when (and (equal (current-buffer) old-buf) + (= (point) old-point)) + (ignore-errors + (image-dired-update-header-line)))))) + +(defun image-dired-forward-image (&optional arg wrap-around) "Move to next image and display properties. -Optional prefix ARG says how many images to move; default is one -image." +Optional prefix ARG says how many images to move; the default is +one image. Negative means move backwards. +On reaching end or beginning of buffer, stop and show a message. + +If optional argument WRAP-AROUND is non-nil, wrap around: if +point is on the last image, move to the last one and vice versa." (interactive "p") - (let (pos (steps (or arg 1))) - (dotimes (_ steps) - (if (and (not (eobp)) + (setq arg (or arg 1)) + (let (pos) + (dotimes (_ (abs arg)) + (if (and (not (if (> arg 0) (eobp) (bobp))) (save-excursion - (forward-char) - (while (and (not (eobp)) + (forward-char (if (> arg 0) 1 -1)) + (while (and (not (if (> arg 0) (eobp) (bobp))) (not (image-dired-image-at-point-p))) - (forward-char)) + (forward-char (if (> arg 0) 1 -1))) (setq pos (point)) (image-dired-image-at-point-p))) - (goto-char pos) - (error "At last image")))) + (progn (goto-char pos) + (image-dired-update-header-line)) + (if wrap-around + (progn (goto-char (if (> arg 0) + (point-min) + ;; There are two spaces after the last image. + (- (point-max) 2))) + (image-dired-update-header-line)) + (message "At %s image" (if (> arg 0) "last" "first")) + (run-at-time 1 nil (image-dired--display-thumb-properties-fun)))))) (when image-dired-track-movement - (image-dired-track-original-file)) - (image-dired-display-thumb-properties)) + (image-dired-track-original-file))) (defun image-dired-backward-image (&optional arg) "Move to previous image and display properties. -Optional prefix ARG says how many images to move; default is one -image." +Optional prefix ARG says how many images to move; the default is +one image. Negative means move forward. +On reaching end or beginning of buffer, stop and show a message." (interactive "p") - (let (pos (steps (or arg 1))) - (dotimes (_ steps) - (if (and (not (bobp)) - (save-excursion - (backward-char) - (while (and (not (bobp)) - (not (image-dired-image-at-point-p))) - (backward-char)) - (setq pos (point)) - (image-dired-image-at-point-p))) - (goto-char pos) - (error "At first image")))) - (when image-dired-track-movement - (image-dired-track-original-file)) - (image-dired-display-thumb-properties)) + (image-dired-forward-image (- (or arg 1)))) (defun image-dired-next-line () "Move to next line and display properties." - (interactive) + (interactive nil image-dired-thumbnail-mode) (let ((goal-column (current-column))) (forward-line 1) (move-to-column goal-column)) @@ -1349,12 +1363,12 @@ image." (image-dired-backward-image)) (if image-dired-track-movement (image-dired-track-original-file)) - (image-dired-display-thumb-properties)) + (image-dired-update-header-line)) (defun image-dired-previous-line () "Move to previous line and display properties." - (interactive) + (interactive nil image-dired-thumbnail-mode) (let ((goal-column (current-column))) (forward-line -1) (move-to-column goal-column)) @@ -1366,7 +1380,29 @@ image." (image-dired-backward-image)) (if image-dired-track-movement (image-dired-track-original-file)) - (image-dired-display-thumb-properties)) + (image-dired-update-header-line)) + +(defun image-dired-beginning-of-buffer () + "Move to the first image in the buffer and display properties." + (interactive nil image-dired-thumbnail-mode) + (goto-char (point-min)) + (while (and (not (image-at-point-p)) + (not (eobp))) + (forward-char 1)) + (when image-dired-track-movement + (image-dired-track-original-file)) + (image-dired-update-header-line)) + +(defun image-dired-end-of-buffer () + "Move to the last image in the buffer and display properties." + (interactive nil image-dired-thumbnail-mode) + (goto-char (point-max)) + (while (and (not (image-at-point-p)) + (not (bobp))) + (forward-char -1)) + (when image-dired-track-movement + (image-dired-track-original-file)) + (image-dired-update-header-line)) (defun image-dired-format-properties-string (buf file props comment) "Format display properties. @@ -1381,77 +1417,115 @@ comment." (cons ?t (or props "")) (cons ?c (or comment ""))))) -(defun image-dired-display-thumb-properties () - "Display thumbnail properties in the echo area." - (if (not (eobp)) - (let ((file-name (file-name-nondirectory (image-dired-original-file-name))) - (dired-buf (buffer-name (image-dired-associated-dired-buffer))) - (props (mapconcat #'identity (get-text-property (point) 'tags) ", ")) - (comment (get-text-property (point) 'comment)) - (message-log-max nil)) - (if file-name - (message "%s" - (image-dired-format-properties-string - dired-buf - file-name - props - comment)))))) - -(defun image-dired-dired-file-marked-p () - "Check whether file on current line is marked or not." +(defun image-dired-update-header-line () + "Update image information in the header line." + (when (and (not (eobp)) + (memq major-mode '(image-dired-thumbnail-mode + image-dired-display-image-mode))) + (let ((file-name (file-name-nondirectory (image-dired-original-file-name))) + (dired-buf (buffer-name (image-dired-associated-dired-buffer))) + (props (mapconcat #'identity (get-text-property (point) 'tags) ", ")) + (comment (get-text-property (point) 'comment)) + (message-log-max nil)) + (if file-name + (setq header-line-format + (image-dired-format-properties-string + dired-buf + file-name + props + comment)))))) + +(defun image-dired-dired-file-marked-p (&optional marker) + "In Dired, return t if file on current line is marked. +If optional argument MARKER is non-nil, it is a character to look +for. The default is to look for `dired-marker-char'." + (setq marker (or marker dired-marker-char)) (save-excursion (beginning-of-line) - (looking-at-p dired-re-mark))) - -(defun image-dired-modify-mark-on-thumb-original-file (command) - "Modify mark in Dired buffer. -COMMAND is one of `mark' for marking file in Dired, `unmark' for -unmarking file in Dired or `flag' for flagging file for delete in -Dired." - (let ((file-name (image-dired-original-file-name)) - (dired-buf (image-dired-associated-dired-buffer))) - (if (not (and dired-buf file-name)) - (message "No image, or image with correct properties, at point.") - (with-current-buffer dired-buf - (message "%s" file-name) - (when (dired-goto-file file-name) - (cond ((eq command 'mark) (dired-mark 1)) - ((eq command 'unmark) (dired-unmark 1)) - ((eq command 'toggle) - (if (image-dired-dired-file-marked-p) - (dired-unmark 1) - (dired-mark 1))) - ((eq command 'flag) (dired-flag-file-deletion 1))) - (image-dired-thumb-update-marks)))))) + (and (looking-at dired-re-mark) + (= (aref (match-string 0) 0) marker)))) + +(defun image-dired-dired-file-flagged-p () + "In Dired, return t if file on current line is flagged for deletion." + (image-dired-dired-file-marked-p dired-del-marker)) + +(defmacro image-dired--with-thumbnail-buffer (&rest body) + (declare (indent defun) (debug t)) + `(if-let ((buf (get-buffer image-dired-thumbnail-buffer))) + (with-current-buffer buf + (if-let ((win (get-buffer-window buf))) + (with-selected-window win + ,@body) + ,@body)) + (user-error "No such buffer: %s" image-dired-thumbnail-buffer))) + +(defmacro image-dired--on-file-in-dired-buffer (&rest body) + "Run BODY with point on file at point in Dired buffer. +Should be called from commands in `image-dired-thumbnail-mode'." + (declare (indent defun) (debug t)) + `(let ((file-name (image-dired-original-file-name)) + (dired-buf (image-dired-associated-dired-buffer))) + (if (not (and dired-buf file-name)) + (message "No image, or image with correct properties, at point.") + (with-current-buffer dired-buf + (when (dired-goto-file file-name) + ,@body + (image-dired-thumb-update-marks)))))) + +(defmacro image-dired--do-mark-command (maybe-next &rest body) + "Helper macro for the mark, unmark and flag commands. +Run BODY in Dired buffer. +If optional argument MAYBE-NEXT is non-nil, show next image +according to `image-dired-marking-shows-next'." + (declare (indent defun) (debug t)) + `(image-dired--with-thumbnail-buffer + (image-dired--on-file-in-dired-buffer + ,@body) + ,(when maybe-next + '(if image-dired-marking-shows-next + (image-dired-display-next-thumbnail-original) + (image-dired-next-line))))) (defun image-dired-mark-thumb-original-file () "Mark original image file in associated Dired buffer." - (interactive) - (image-dired-modify-mark-on-thumb-original-file 'mark) - (image-dired-forward-image)) + (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired--do-mark-command t + (dired-mark 1))) (defun image-dired-unmark-thumb-original-file () "Unmark original image file in associated Dired buffer." - (interactive) - (image-dired-modify-mark-on-thumb-original-file 'unmark) - (image-dired-forward-image)) + (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired--do-mark-command t + (dired-unmark 1))) (defun image-dired-flag-thumb-original-file () "Flag original image file for deletion in associated Dired buffer." - (interactive) - (image-dired-modify-mark-on-thumb-original-file 'flag) - (image-dired-forward-image)) + (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired--do-mark-command t + (dired-flag-file-deletion 1))) (defun image-dired-toggle-mark-thumb-original-file () "Toggle mark on original image file in associated Dired buffer." - (interactive) - (image-dired-modify-mark-on-thumb-original-file 'toggle)) + (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired--do-mark-command nil + (if (image-dired-dired-file-marked-p) + (dired-unmark 1) + (dired-mark 1)))) + +(defun image-dired-unmark-all-marks () + "Remove all marks from all files in associated Dired buffer. +Also update the marks in the thumbnail buffer." + (interactive nil image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired--do-mark-command nil + (dired-unmark-all-marks)) + (image-dired--with-thumbnail-buffer + (image-dired-thumb-update-marks))) (defun image-dired-jump-original-dired-buffer () "Jump to the Dired buffer associated with the current image file. You probably want to use this together with `image-dired-track-original-file'." - (interactive) + (interactive nil image-dired-thumbnail-mode) (let ((buf (image-dired-associated-dired-buffer)) window frame) (setq window (image-dired-get-buffer-window buf)) @@ -1478,236 +1552,213 @@ You probably want to use this together with (defvar image-dired-thumbnail-mode-line-up-map (let ((map (make-sparse-keymap))) ;; map it to "g" so that the user can press it more quickly - (define-key map "g" 'image-dired-line-up-dynamic) + (define-key map "g" #'image-dired-line-up-dynamic) ;; "f" for "fixed" number of thumbs per row - (define-key map "f" 'image-dired-line-up) + (define-key map "f" #'image-dired-line-up) ;; "i" for "interactive" - (define-key map "i" 'image-dired-line-up-interactive) + (define-key map "i" #'image-dired-line-up-interactive) map) "Keymap for line-up commands in `image-dired-thumbnail-mode'.") (defvar image-dired-thumbnail-mode-tag-map (let ((map (make-sparse-keymap))) ;; map it to "t" so that the user can press it more quickly - (define-key map "t" 'image-dired-tag-thumbnail) + (define-key map "t" #'image-dired-tag-thumbnail) ;; "r" for "remove" - (define-key map "r" 'image-dired-tag-thumbnail-remove) + (define-key map "r" #'image-dired-tag-thumbnail-remove) map) "Keymap for tag commands in `image-dired-thumbnail-mode'.") (defvar image-dired-thumbnail-mode-map (let ((map (make-sparse-keymap))) - (define-key map [right] 'image-dired-forward-image) - (define-key map [left] 'image-dired-backward-image) - (define-key map [up] 'image-dired-previous-line) - (define-key map [down] 'image-dired-next-line) - (define-key map "\C-f" 'image-dired-forward-image) - (define-key map "\C-b" 'image-dired-backward-image) - (define-key map "\C-p" 'image-dired-previous-line) - (define-key map "\C-n" 'image-dired-next-line) - - (define-key map "d" 'image-dired-flag-thumb-original-file) - (define-key map [delete] 'image-dired-flag-thumb-original-file) - (define-key map "m" 'image-dired-mark-thumb-original-file) - (define-key map "u" 'image-dired-unmark-thumb-original-file) - (define-key map "." 'image-dired-track-original-file) - (define-key map [tab] 'image-dired-jump-original-dired-buffer) + (define-key map [right] #'image-dired-forward-image) + (define-key map [left] #'image-dired-backward-image) + (define-key map [up] #'image-dired-previous-line) + (define-key map [down] #'image-dired-next-line) + (define-key map "\C-f" #'image-dired-forward-image) + (define-key map "\C-b" #'image-dired-backward-image) + (define-key map "\C-p" #'image-dired-previous-line) + (define-key map "\C-n" #'image-dired-next-line) + + (define-key map "<" #'image-dired-beginning-of-buffer) + (define-key map ">" #'image-dired-end-of-buffer) + (define-key map (kbd "M-<") #'image-dired-beginning-of-buffer) + (define-key map (kbd "M->") #'image-dired-end-of-buffer) + + (define-key map "d" #'image-dired-flag-thumb-original-file) + (define-key map [delete] #'image-dired-flag-thumb-original-file) + (define-key map "m" #'image-dired-mark-thumb-original-file) + (define-key map "u" #'image-dired-unmark-thumb-original-file) + (define-key map "U" #'image-dired-unmark-all-marks) + (define-key map "." #'image-dired-track-original-file) + (define-key map [tab] #'image-dired-jump-original-dired-buffer) ;; add line-up map (define-key map "g" image-dired-thumbnail-mode-line-up-map) ;; add tag map (define-key map "t" image-dired-thumbnail-mode-tag-map) - (define-key map "\C-m" 'image-dired-display-thumbnail-original-image) - (define-key map [C-return] 'image-dired-thumbnail-display-external) + (define-key map "\C-m" #'image-dired-display-thumbnail-original-image) + (define-key map [C-return] #'image-dired-thumbnail-display-external) - (define-key map "l" 'image-dired-rotate-thumbnail-left) - (define-key map "r" 'image-dired-rotate-thumbnail-right) - (define-key map "L" 'image-dired-rotate-original-left) - (define-key map "R" 'image-dired-rotate-original-right) + (define-key map "L" #'image-dired-rotate-original-left) + (define-key map "R" #'image-dired-rotate-original-right) - (define-key map "D" 'image-dired-thumbnail-set-image-description) - (define-key map "\C-d" 'image-dired-delete-char) - (define-key map " " 'image-dired-display-next-thumbnail-original) - (define-key map (kbd "DEL") 'image-dired-display-previous-thumbnail-original) - (define-key map "c" 'image-dired-comment-thumbnail) + (define-key map "D" #'image-dired-thumbnail-set-image-description) + (define-key map "S" #'image-dired-slideshow-start) + (define-key map "\C-d" #'image-dired-delete-char) + (define-key map " " #'image-dired-display-next-thumbnail-original) + (define-key map (kbd "DEL") #'image-dired-display-previous-thumbnail-original) + (define-key map "c" #'image-dired-comment-thumbnail) ;; Mouse - (define-key map [mouse-2] 'image-dired-mouse-display-image) - (define-key map [mouse-1] 'image-dired-mouse-select-thumbnail) + (define-key map [mouse-2] #'image-dired-mouse-display-image) + (define-key map [mouse-1] #'image-dired-mouse-select-thumbnail) + (define-key map [mouse-3] #'image-dired-mouse-select-thumbnail) + (define-key map [down-mouse-1] #'image-dired-mouse-select-thumbnail) + (define-key map [down-mouse-2] #'image-dired-mouse-select-thumbnail) + (define-key map [down-mouse-3] #'image-dired-mouse-select-thumbnail) ;; Seems I must first set C-down-mouse-1 to undefined, or else it ;; will trigger the buffer menu. If I try to instead bind ;; C-down-mouse-1 to `image-dired-mouse-toggle-mark', I get a message ;; about C-mouse-1 not being defined afterwards. Annoying, but I ;; probably do not completely understand mouse events. - (define-key map [C-down-mouse-1] 'undefined) - (define-key map [C-mouse-1] 'image-dired-mouse-toggle-mark) - - ;; Menu - (easy-menu-define nil map - "Menu for `image-dired-thumbnail-mode'." - '("Image-Dired" - ["Display image" image-dired-display-thumbnail-original-image] - ["Display in external viewer" image-dired-thumbnail-display-external] - - ["Mark original" image-dired-mark-thumb-original-file] - ["Unmark original" image-dired-unmark-thumb-original-file] - ["Flag original for deletion" image-dired-flag-thumb-original-file] - - ["Track original" image-dired-track-original-file] - ["Jump to dired buffer" image-dired-jump-original-dired-buffer] - - ["Toggle movement tracking on/off" image-dired-toggle-movement-tracking] - - ["Rotate original right" image-dired-rotate-original-right] - ["Rotate original left" image-dired-rotate-original-left] - ["Rotate thumbnail right" image-dired-rotate-thumbnail-right] - ["Rotate thumbnail left" image-dired-rotate-thumbnail-left] - - ["Line up thumbnails" image-dired-line-up] - ["Dynamic line up" image-dired-line-up-dynamic] - ["Refresh thumb" image-dired-refresh-thumb] - ["Comment thumbnail" image-dired-comment-thumbnail] - ["Tag current or marked thumbnails" image-dired-tag-thumbnail] - ["Remove tag from current or marked thumbnails" - image-dired-tag-thumbnail-remove] - ["Delete marked images" image-dired-delete-marked] - ["Delete thumbnail from buffer" image-dired-delete-char] - ["Quit" quit-window])) + (define-key map [C-down-mouse-1] #'undefined) + (define-key map [C-mouse-1] #'image-dired-mouse-toggle-mark) map) "Keymap for `image-dired-thumbnail-mode'.") +(easy-menu-define image-dired-thumbnail-mode-menu image-dired-thumbnail-mode-map + "Menu for `image-dired-thumbnail-mode'." + '("Image-Dired" + ["Display image" image-dired-display-thumbnail-original-image] + ["Display in external viewer" image-dired-thumbnail-display-external] + ["Jump to Dired buffer" image-dired-jump-original-dired-buffer] + "---" + ["Mark image" image-dired-mark-thumb-original-file] + ["Unmark image" image-dired-unmark-thumb-original-file] + ["Unmark all images" image-dired-unmark-all-marks] + ["Flag for deletion" image-dired-flag-thumb-original-file] + ["Delete marked images" image-dired-delete-marked] + "---" + ["Rotate original right" image-dired-rotate-original-right] + ["Rotate original left" image-dired-rotate-original-left] + "---" + ["Comment thumbnail" image-dired-comment-thumbnail] + ["Tag current or marked thumbnails" image-dired-tag-thumbnail] + ["Remove tag from current or marked thumbnails" + image-dired-tag-thumbnail-remove] + ["Start slideshow" image-dired-slideshow-start] + "---" + ("View Options" + ["Toggle movement tracking" image-dired-toggle-movement-tracking + :style toggle + :selected image-dired-track-movement] + "---" + ["Line up thumbnails" image-dired-line-up] + ["Dynamic line up" image-dired-line-up-dynamic] + ["Refresh thumb" image-dired-refresh-thumb]) + ["Quit" quit-window])) + (defvar image-dired-display-image-mode-map (let ((map (make-sparse-keymap))) - ;; `image-mode-map' has bindings that do not make sense in image-dired - ;; (set-keymap-parent map image-mode-map) - (define-key map "f" 'image-dired-display-current-image-full) - (define-key map "s" 'image-dired-display-current-image-sized) - (define-key map "g" nil) - - ;; Useful bindings from `image-mode-map' - (define-key map [remap forward-char] 'image-forward-hscroll) - (define-key map [remap backward-char] 'image-backward-hscroll) - (define-key map [remap right-char] 'image-forward-hscroll) - (define-key map [remap left-char] 'image-backward-hscroll) - (define-key map [remap previous-line] 'image-previous-line) - (define-key map [remap next-line] 'image-next-line) - (define-key map [remap scroll-up] 'image-scroll-up) - (define-key map [remap scroll-down] 'image-scroll-down) - (define-key map [remap scroll-up-command] 'image-scroll-up) - (define-key map [remap scroll-down-command] 'image-scroll-down) - (define-key map [remap scroll-left] 'image-scroll-left) - (define-key map [remap scroll-right] 'image-scroll-right) - (define-key map [remap move-beginning-of-line] 'image-bol) - (define-key map [remap move-end-of-line] 'image-eol) - (define-key map [remap beginning-of-buffer] 'image-bob) - (define-key map [remap end-of-buffer] 'image-eob) - - (easy-menu-define nil map - "Menu for `image-dired-display-image-mode-map'." - '("Image-Dired" - ["Display original, full size" image-dired-display-current-image-full] - ["Display original, sized to fit" image-dired-display-current-image-sized] - ["Quit" quit-window])) + (define-key map "S" #'image-dired-slideshow-start) + (define-key map (kbd "SPC") #'image-dired-display-next-thumbnail-original) + (define-key map (kbd "DEL") #'image-dired-display-previous-thumbnail-original) + (define-key map "n" #'image-dired-display-next-thumbnail-original) + (define-key map "p" #'image-dired-display-previous-thumbnail-original) + (define-key map "m" #'image-dired-mark-thumb-original-file) + (define-key map "d" #'image-dired-flag-thumb-original-file) + (define-key map "u" #'image-dired-unmark-thumb-original-file) + (define-key map "U" #'image-dired-unmark-all-marks) + ;; Disable keybindings from `image-mode-map' that doesn't make sense here. + (define-key map "o" nil) ; image-save map) "Keymap for `image-dired-display-image-mode'.") -(defun image-dired-display-current-image-full () - "Display current image in full size." - (interactive) - (let ((file (image-dired-original-file-name))) - (if file - (progn - (image-dired-display-image file t) - (message "Full size image displayed")) - (error "No original file name at point")))) - -(defun image-dired-display-current-image-sized () - "Display current image in sized to fit window dimensions." - (interactive) - (let ((file (image-dired-original-file-name))) - (if file - (progn - (image-dired-display-image file) - (message "Fitted image displayed")) - (error "No original file name at point")))) - (define-derived-mode image-dired-thumbnail-mode special-mode "image-dired-thumbnail" "Browse and manipulate thumbnail images using Dired. Use `image-dired-minor-mode' to get a nice setup." + :interactive nil (buffer-disable-undo) - (add-hook 'file-name-at-point-functions 'image-dired-file-name-at-point nil t)) + (add-hook 'file-name-at-point-functions 'image-dired-file-name-at-point nil t) + (setq-local window-resize-pixelwise t) + (setq-local bookmark-make-record-function #'image-dired-bookmark-make-record) + ;; Use approximately as much vertical spacing as horizontal. + (setq-local line-spacing (frame-char-width))) + + +;;; Display image mode (define-derived-mode image-dired-display-image-mode - special-mode "image-dired-image-display" + image-mode "image-dired-image-display" "Mode for displaying and manipulating original image. Resized or in full-size." - (buffer-disable-undo) - (image-mode-setup-winprops) - (setq cursor-type nil) - (add-hook 'file-name-at-point-functions 'image-dired-file-name-at-point nil t)) + :interactive nil + (add-hook 'file-name-at-point-functions #'image-dired-file-name-at-point nil t)) (defvar image-dired-minor-mode-map (let ((map (make-sparse-keymap))) ;; (set-keymap-parent map dired-mode-map) ;; Hijack previous and next line movement. Let C-p and C-b be ;; though... - (define-key map "p" 'image-dired-dired-previous-line) - (define-key map "n" 'image-dired-dired-next-line) - (define-key map [up] 'image-dired-dired-previous-line) - (define-key map [down] 'image-dired-dired-next-line) - - (define-key map (kbd "C-S-n") 'image-dired-next-line-and-display) - (define-key map (kbd "C-S-p") 'image-dired-previous-line-and-display) - (define-key map (kbd "C-S-m") 'image-dired-mark-and-display-next) - - (define-key map "\C-td" 'image-dired-display-thumbs) - (define-key map [tab] 'image-dired-jump-thumbnail-buffer) - (define-key map "\C-ti" 'image-dired-dired-display-image) - (define-key map "\C-tx" 'image-dired-dired-display-external) - (define-key map "\C-ta" 'image-dired-display-thumbs-append) - (define-key map "\C-t." 'image-dired-display-thumb) - (define-key map "\C-tc" 'image-dired-dired-comment-files) - (define-key map "\C-tf" 'image-dired-mark-tagged-files) - - ;; Menu for dired - (easy-menu-define nil map - "Menu for `image-dired-minor-mode'." - '("Image-dired" - ["Display thumb for next file" image-dired-next-line-and-display] - ["Display thumb for previous file" image-dired-previous-line-and-display] - ["Mark and display next" image-dired-mark-and-display-next] - - ["Create thumbnails for marked files" image-dired-create-thumbs] - - ["Display thumbnails append" image-dired-display-thumbs-append] - ["Display this thumbnail" image-dired-display-thumb] - ["Display image" image-dired-dired-display-image] - ["Display in external viewer" image-dired-dired-display-external] - - ["Toggle display properties" image-dired-toggle-dired-display-properties] - ["Toggle append browsing" image-dired-toggle-append-browsing] - ["Toggle movement tracking" image-dired-toggle-movement-tracking] - - ["Jump to thumbnail buffer" image-dired-jump-thumbnail-buffer] - ["Mark tagged files" image-dired-mark-tagged-files] - ["Comment files" image-dired-dired-comment-files] - ["Copy with EXIF file name" image-dired-copy-with-exif-file-name])) + (define-key map "p" #'image-dired-dired-previous-line) + (define-key map "n" #'image-dired-dired-next-line) + (define-key map [up] #'image-dired-dired-previous-line) + (define-key map [down] #'image-dired-dired-next-line) + + (define-key map (kbd "C-S-n") #'image-dired-next-line-and-display) + (define-key map (kbd "C-S-p") #'image-dired-previous-line-and-display) + (define-key map (kbd "C-S-m") #'image-dired-mark-and-display-next) + + (define-key map "\C-td" #'image-dired-display-thumbs) + (define-key map [tab] #'image-dired-jump-thumbnail-buffer) + (define-key map "\C-ti" #'image-dired-dired-display-image) + (define-key map "\C-tx" #'image-dired-dired-display-external) + (define-key map "\C-ta" #'image-dired-display-thumbs-append) + (define-key map "\C-t." #'image-dired-display-thumb) + (define-key map "\C-tc" #'image-dired-dired-comment-files) + (define-key map "\C-tf" #'image-dired-mark-tagged-files) map) "Keymap for `image-dired-minor-mode'.") +(easy-menu-define image-dired-minor-mode-menu image-dired-minor-mode-map + "Menu for `image-dired-minor-mode'." + '("Image-dired" + ["Display thumb for next file" image-dired-next-line-and-display] + ["Display thumb for previous file" image-dired-previous-line-and-display] + ["Mark and display next" image-dired-mark-and-display-next] + "---" + ["Create thumbnails for marked files" image-dired-create-thumbs] + "---" + ["Display thumbnails append" image-dired-display-thumbs-append] + ["Display this thumbnail" image-dired-display-thumb] + ["Display image" image-dired-dired-display-image] + ["Display in external viewer" image-dired-dired-display-external] + "---" + ["Toggle display properties" image-dired-toggle-dired-display-properties + :style toggle + :selected image-dired-dired-disp-props] + ["Toggle append browsing" image-dired-toggle-append-browsing + :style toggle + :selected image-dired-append-when-browsing] + ["Toggle movement tracking" image-dired-toggle-movement-tracking + :style toggle + :selected image-dired-track-movement] + "---" + ["Jump to thumbnail buffer" image-dired-jump-thumbnail-buffer] + ["Mark tagged files" image-dired-mark-tagged-files] + ["Comment files" image-dired-dired-comment-files] + ["Copy with EXIF file name" image-dired-copy-with-exif-file-name])) + ;;;###autoload (define-minor-mode image-dired-minor-mode "Setup easy-to-use keybindings for the commands to be used in Dired mode. Note that n, p and <down> and <up> will be hijacked and bound to -`image-dired-dired-x-line'." +`image-dired-dired-next-line' and `image-dired-dired-previous-line'." :keymap image-dired-minor-mode-map) -;;;###autoload -(define-obsolete-function-alias 'image-dired-setup-dired-keybindings 'image-dired-minor-mode - "26.1") - (declare-function clear-image-cache "image.c" (&optional filter)) (defun image-dired-create-thumbs (&optional arg) @@ -1727,46 +1778,69 @@ With prefix argument ARG, create thumbnails even if they already exist arg) (image-dired-create-thumb curr-file thumb-name))))) -(defvar image-dired-slideshow-timer nil - "Slideshow timer.") + +;;; Slideshow -(defvar image-dired-slideshow-count 0 - "Keeping track on number of images in slideshow.") +(defcustom image-dired-slideshow-delay 5.0 + "Seconds to wait before showing the next image in a slideshow. +This is used by `image-dired-slideshow-start'." + :type 'float + :version "29.1") -(defvar image-dired-slideshow-times 0 - "Number of pictures to display in slideshow.") +(define-obsolete-variable-alias 'image-dired-slideshow-timer + 'image-dired--slideshow-timer "29.1") +(defvar image-dired--slideshow-timer nil + "Slideshow timer.") + +(defvar image-dired--slideshow-initial nil) (defun image-dired-slideshow-step () - "Step to next file, if `image-dired-slideshow-times' has not been reached." - (if (< image-dired-slideshow-count image-dired-slideshow-times) - (progn - (message "%s" (1+ image-dired-slideshow-count)) - (setq image-dired-slideshow-count (1+ image-dired-slideshow-count)) - (image-dired-next-line-and-display)) + "Step to next image in a slideshow." + (if-let ((buf (get-buffer image-dired-thumbnail-buffer))) + (with-current-buffer buf + (image-dired-display-next-thumbnail-original)) (image-dired-slideshow-stop))) -(defun image-dired-slideshow-start () - "Start slideshow. -Ask user for number of images to show and the delay in between." - (interactive) - (setq image-dired-slideshow-count 0) - (setq image-dired-slideshow-times (string-to-number (read-string "How many: "))) - (let ((repeat (string-to-number - (read-string - "Delay, in seconds. Decimals are accepted : " "1")))) - (setq image-dired-slideshow-timer +(defun image-dired-slideshow-start (&optional arg) + "Start a slideshow, waiting `image-dired-slideshow-delay' between images. + +With prefix argument ARG, wait that many seconds before going to +the next image. + +With a negative prefix argument, prompt user for the delay." + (interactive "P" image-dired-thumbnail-mode image-dired-display-image-mode) + (let ((delay (if (not arg) + image-dired-slideshow-delay + (if (> arg 0) + arg + (string-to-number + (let ((delay (number-to-string image-dired-slideshow-delay))) + (read-string + (format-prompt "Delay, in seconds. Decimals are accepted" delay)) + delay)))))) + (setq image-dired--slideshow-timer (run-with-timer - 0 repeat - 'image-dired-slideshow-step)))) + 0 delay + 'image-dired-slideshow-step)) + (add-hook 'post-command-hook 'image-dired-slideshow-stop) + (setq image-dired--slideshow-initial t) + (message "Running slideshow; use any command to stop"))) (defun image-dired-slideshow-stop () "Cancel slideshow." - (interactive) - (cancel-timer image-dired-slideshow-timer)) + ;; Make sure we don't immediately stop after + ;; `image-dired-slideshow-start'. + (unless image-dired--slideshow-initial + (remove-hook 'post-command-hook 'image-dired-slideshow-stop) + (cancel-timer image-dired--slideshow-timer)) + (setq image-dired--slideshow-initial nil)) + + +;;; Thumbnail mode (cont. 3) (defun image-dired-delete-char () "Remove current thumbnail from thumbnail buffer and line up." - (interactive) + (interactive nil image-dired-thumbnail-mode) (let ((inhibit-read-only t)) (delete-char 1) (when (= (following-char) ?\s) @@ -1799,18 +1873,26 @@ See also `image-dired-line-up-dynamic'." (not (eobp))) (delete-char 1))) (goto-char (point-min)) - (let ((count 0)) + (let ((seen 0) + (thumb-prev-pos 0) + (thumb-width-chars + (ceiling (/ (+ (* 2 image-dired-thumb-relief) + (* 2 image-dired-thumb-margin) + (image-dired-thumb-size 'width)) + (float (frame-char-width)))))) (while (not (eobp)) (forward-char) (if (= image-dired-thumbs-per-row 1) (insert "\n") - (insert " ") - (setq count (1+ count)) - (when (and (= count (- image-dired-thumbs-per-row 1)) + (cl-incf thumb-prev-pos thumb-width-chars) + (insert (propertize " " 'display `(space :align-to ,thumb-prev-pos))) + (cl-incf seen) + (when (and (= seen (- image-dired-thumbs-per-row 1)) (not (eobp))) (forward-char) (insert "\n") - (setq count 0))))) + (setq seen 0) + (setq thumb-prev-pos 0))))) (goto-char (point-min)))) (defun image-dired-line-up-dynamic () @@ -1860,11 +1942,6 @@ Ask user how many thumbnails should be displayed per row." "Calculate WINDOW width in pixels." (* (window-width window) (frame-char-width))) -(defun image-dired-window-height-pixels (window) - "Calculate WINDOW height in pixels." - ;; Note: The mode-line consumes one line - (* (- (window-height window) 1) (frame-char-height))) - (defun image-dired-display-window () "Return window where `image-dired-display-image-buffer' is visible." (get-window-with-predicate @@ -1890,59 +1967,24 @@ Ask user how many thumbnails should be displayed per row." (equal (window-buffer window) buf)))) (error "No thumbnail image at point")))) -(defun image-dired-display-window-width (window) - "Return width, in pixels, of WINDOW." - (- (image-dired-window-width-pixels window) - image-dired-display-window-width-correction)) - -(defun image-dired-display-window-height (window) - "Return height, in pixels, of WINDOW." - (- (image-dired-window-height-pixels window) - image-dired-display-window-height-correction)) - -(defun image-dired-display-image (file &optional original-size) +(defun image-dired-display-image (file &optional _ignored) "Display image FILE in image buffer. -Use this when you want to display the image, semi sized, in a new -window. The image is sized to fit the display window (using a -temporary file, don't worry). Because of this, it will not be as -quick as opening it directly, but on most modern systems it -should feel snappy enough. - -If optional argument ORIGINAL-SIZE is non-nil, display image in its -original size." - (image-dired--check-executable-exists - 'image-dired-cmd-create-temp-image-program) - (let ((new-file (expand-file-name image-dired-temp-image-file)) - (window (image-dired-display-window)) - (image-type 'jpeg)) - (setq file (expand-file-name file)) - (if (not original-size) - (let* ((spec - (list - (cons ?p image-dired-cmd-create-temp-image-program) - (cons ?w (image-dired-display-window-width window)) - (cons ?h (image-dired-display-window-height window)) - (cons ?f file) - (cons ?t new-file))) - (ret - (apply #'call-process - image-dired-cmd-create-temp-image-program nil nil nil - (mapcar - (lambda (arg) (format-spec arg spec)) - image-dired-cmd-create-temp-image-options)))) - (when (not (zerop ret)) - (error "Could not resize image"))) - (setq image-type (image-type-from-file-name file)) - (copy-file file new-file t)) - (with-current-buffer (image-dired-create-display-image-buffer) - (let ((inhibit-read-only t)) - (erase-buffer) - (clear-image-cache) - (image-dired-insert-image image-dired-temp-image-file image-type 0 0) - (goto-char (point-min)) - (set-window-vscroll window 0) - (set-window-hscroll window 0) - (image-dired-update-property 'original-file-name file))))) +Use this when you want to display the image, in a new window. +The window will use `image-dired-display-image-mode' which is +based on `image-mode'." + (declare (advertised-calling-convention (file) "29.1")) + (setq file (expand-file-name file)) + (when (not (file-exists-p file)) + (error "No such file: %s" file)) + (let ((buf (get-buffer image-dired-display-image-buffer)) + (cur-win (selected-window))) + (when buf + (kill-buffer buf)) + (when-let ((buf (find-file-other-window file))) + (display-buffer buf) + (rename-buffer image-dired-display-image-buffer) + (image-dired-display-image-mode) + (select-window cur-win)))) (defun image-dired-display-thumbnail-original-image (&optional arg) "Display current thumbnail's original image in display buffer. @@ -1956,8 +1998,6 @@ With prefix argument ARG, display image in its original size." (message "No thumbnail at point") (if (not file) (message "No original file name found") - (image-dired-create-display-image-buffer) - (display-buffer image-dired-display-image-buffer) (image-dired-display-image file arg)))))) @@ -1967,41 +2007,15 @@ With prefix argument ARG, display image in its original size." See documentation for `image-dired-display-image' for more information. With prefix argument ARG, display image in its original size." (interactive "P") - (image-dired-create-display-image-buffer) - (display-buffer image-dired-display-image-buffer) (image-dired-display-image (dired-get-filename) arg)) (defun image-dired-image-at-point-p () "Return non-nil if there is an `image-dired' thumbnail at point." (get-text-property (point) 'image-dired-thumbnail)) -(defun image-dired-rotate-thumbnail (degrees) - "Rotate thumbnail DEGREES degrees." - (image-dired--check-executable-exists - 'image-dired-cmd-rotate-thumbnail-program) - (if (not (image-dired-image-at-point-p)) - (message "No thumbnail at point") - (let* ((file (image-dired-thumb-name (image-dired-original-file-name))) - (thumb (expand-file-name file)) - (spec (list (cons ?d degrees) (cons ?t thumb)))) - (apply #'call-process image-dired-cmd-rotate-thumbnail-program nil nil nil - (mapcar (lambda (arg) (format-spec arg spec)) - image-dired-cmd-rotate-thumbnail-options)) - (clear-image-cache thumb)))) - -(defun image-dired-rotate-thumbnail-left () - "Rotate thumbnail left (counter clockwise) 90 degrees." - (interactive) - (image-dired-rotate-thumbnail "270")) - -(defun image-dired-rotate-thumbnail-right () - "Rotate thumbnail counter right (clockwise) 90 degrees." - (interactive) - (image-dired-rotate-thumbnail "90")) - (defun image-dired-refresh-thumb () "Force creation of new image for current thumbnail." - (interactive) + (interactive nil image-dired-thumbnail-mode) (let* ((file (image-dired-original-file-name)) (thumb (expand-file-name (image-dired-thumb-name file)))) (clear-image-cache (expand-file-name thumb)) @@ -2020,7 +2034,7 @@ With prefix argument ARG, display image in its original size." (cons ?o (expand-file-name file)) (cons ?t image-dired-temp-rotate-image-file)))) (unless (eq 'jpeg (image-type file)) - (error "Only JPEG images can be rotated!")) + (user-error "Only JPEG images can be rotated")) (if (not (= 0 (apply #'call-process image-dired-cmd-rotate-original-program nil nil nil (mapcar (lambda (arg) (format-spec arg spec)) @@ -2054,6 +2068,9 @@ overwritten. This confirmation can be turned off using (interactive) (image-dired-rotate-original "90")) + +;;; EXIF support + (defun image-dired-get-exif-file-name (file) "Use the image's EXIF information to return a unique file name. The file name should be unique as long as you do not take more than @@ -2068,8 +2085,8 @@ YYYY_MM_DD_HH_MM_DD_ORIG_FILE_NAME.jpg. Used from "%Y:%m:%d %H:%M:%S" (file-attribute-modification-time (file-attributes (expand-file-name file))))) - (setq data (image-dired-get-exif-data (expand-file-name file) - "DateTimeOriginal"))) + (setq data (exif-field 'date-time (exif-parse-file + (expand-file-name file))))) (while (string-match "[ :]" data) (setq data (replace-match "_" nil nil data))) (format "%s%s%s" data @@ -2086,7 +2103,7 @@ default value at the prompt." (if (not (image-dired-image-at-point-p)) (message "No thumbnail at point") (let* ((file (image-dired-original-file-name)) - (old-value (image-dired-get-exif-data file "ImageDescription"))) + (old-value (or (exif-field 'description (exif-parse-file file)) ""))) (if (eq 0 (image-dired-set-exif-data file "ImageDescription" (read-string "Value of ImageDescription: " @@ -2107,33 +2124,9 @@ default value at the prompt." (mapcar (lambda (arg) (format-spec arg spec)) image-dired-cmd-write-exif-data-options)))) -(defun image-dired-get-exif-data (file tag-name) - "From FILE, return EXIF tag TAG-NAME." - (image-dired--check-executable-exists - 'image-dired-cmd-read-exif-data-program) - (let ((buf (get-buffer-create "*image-dired-get-exif-data*")) - (spec (list (cons ?f file) (cons ?t tag-name))) - tag-value) - (with-current-buffer buf - (delete-region (point-min) (point-max)) - (if (not (eq (apply #'call-process image-dired-cmd-read-exif-data-program - nil t nil - (mapcar - (lambda (arg) (format-spec arg spec)) - image-dired-cmd-read-exif-data-options)) - 0)) - (error "Could not get EXIF tag") - (goto-char (point-min)) - ;; Clean buffer from newlines and carriage returns before - ;; getting final info - (while (search-forward-regexp "[\n\r]" nil t) - (replace-match "" nil t)) - (setq tag-value (buffer-substring (point-min) (point-max))))) - tag-value)) - (defun image-dired-copy-with-exif-file-name () "Copy file with unique name to main image directory. -Copy current or all marked files in dired to a new file in your +Copy current or all marked files in Dired to a new file in your main image directory, using a file name generated by `image-dired-get-exif-file-name'. A typical usage for this if when copying images from a digital camera into the image directory. @@ -2158,17 +2151,24 @@ function. The result is a couple of new files in (copy-file curr-file new-name)) files))) -(defun image-dired-display-next-thumbnail-original () - "In thumbnail buffer, move to next thumbnail and display the image." - (interactive) - (image-dired-forward-image) - (image-dired-display-thumbnail-original-image)) +;;; Thumbnail mode (cont.) -(defun image-dired-display-previous-thumbnail-original () - "Move to previous thumbnail and display image." - (interactive) - (image-dired-backward-image) - (image-dired-display-thumbnail-original-image)) +(defun image-dired-display-next-thumbnail-original (&optional arg) + "Move to the next image in the thumbnail buffer and display it. +With prefix ARG, move that many thumbnails." + (interactive "p" image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired--with-thumbnail-buffer + (image-dired-forward-image arg t) + (image-dired-display-thumbnail-original-image))) + +(defun image-dired-display-previous-thumbnail-original (arg) + "Move to the previous image in the thumbnail buffer and display it. +With prefix ARG, move that many thumbnails." + (interactive "p" image-dired-thumbnail-mode image-dired-display-image-mode) + (image-dired-display-next-thumbnail-original (- arg))) + + +;;; Image Comments (defun image-dired-write-comments (file-comments) "Write file comments to database. @@ -2233,7 +2233,7 @@ FILE-COMMENTS is an alist on the following form: (comment (image-dired-read-comment file))) (image-dired-write-comments (list (cons file comment))) (image-dired-update-property 'comment comment)) - (image-dired-display-thumb-properties)) + (image-dired-update-header-line)) (defun image-dired-read-comment (&optional file) "Read comment for an image. @@ -2296,6 +2296,10 @@ matching tag will be marked in the Dired buffer." (dired-mark 1)))) (message "%d files with matching tag marked." hits))) + + +;;; Mouse support + (defun image-dired-mouse-display-image (event) "Use mouse EVENT, call `image-dired-display-image' to display image. Track this in associated Dired buffer if `image-dired-track-movement' is @@ -2303,12 +2307,12 @@ non-nil." (interactive "e") (mouse-set-point event) (goto-char (posn-point (event-end event))) + (unless (image-at-point-p) + (image-dired-backward-image)) (let ((file (image-dired-original-file-name))) (when file (if image-dired-track-movement (image-dired-track-original-file)) - (image-dired-create-display-image-buffer) - (display-buffer image-dired-display-image-buffer) (image-dired-display-image file)))) (defun image-dired-mouse-select-thumbnail (event) @@ -2318,19 +2322,33 @@ non-nil." (interactive "e") (mouse-set-point event) (goto-char (posn-point (event-end event))) + (unless (image-at-point-p) + (image-dired-backward-image)) (if image-dired-track-movement (image-dired-track-original-file)) - (image-dired-display-thumb-properties)) + (image-dired-update-header-line)) + + + +;;; Dired marks and tags -(defun image-dired-thumb-file-marked-p () - "Check if file is marked in associated Dired buffer." +(defun image-dired-thumb-file-marked-p (&optional flagged) + "Check if file is marked in associated Dired buffer. +If optional argument FLAGGED is non-nil, check if file is flagged +for deletion instead." (let ((file-name (image-dired-original-file-name)) (dired-buf (image-dired-associated-dired-buffer))) (when (and dired-buf file-name) (with-current-buffer dired-buf (save-excursion (when (dired-goto-file file-name) - (image-dired-dired-file-marked-p))))))) + (if flagged + (image-dired-dired-file-flagged-p) + (image-dired-dired-file-marked-p)))))))) + +(defun image-dired-thumb-file-flagged-p () + "Check if file is flagged for deletion in associated Dired buffer." + (image-dired-thumb-file-marked-p t)) (defun image-dired-delete-marked () "Delete current or marked thumbnails and associated images." @@ -2351,11 +2369,14 @@ non-nil." (let ((inhibit-read-only t)) (while (not (eobp)) (with-silent-modifications - (if (image-dired-thumb-file-marked-p) - (add-face-text-property (point) (1+ (point)) - 'image-dired-thumb-mark) - (remove-text-properties (point) (1+ (point)) - '(face image-dired-thumb-mark)))) + (cond ((image-dired-thumb-file-marked-p) + (add-face-text-property (point) (1+ (point)) + 'image-dired-thumb-mark)) + ((image-dired-thumb-file-flagged-p) + (add-face-text-property (point) (1+ (point)) + 'image-dired-thumb-flagged)) + (t (remove-text-properties (point) (1+ (point)) + '(face image-dired-thumb-mark))))) (forward-char))))))) (defun image-dired-mouse-toggle-mark-1 () @@ -2402,6 +2423,53 @@ Track this in associated Dired buffer if props comment))))) + + +;;; Gallery support + +;; TODO: +;; * Support gallery creation when using per-directory thumbnail +;; storage. +;; * Enhanced gallery creation with basic CSS-support and pagination +;; of tag pages with many pictures. + +(defgroup image-dired-gallery nil + "Image-Dired support for generating a HTML gallery." + :prefix "image-dired-" + :group 'image-dired + :version "29.1") + +(defcustom image-dired-gallery-dir + (expand-file-name ".image-dired_gallery" image-dired-dir) + "Directory to store generated gallery html pages. +The name of this directory needs to be \"shared\" to the public +so that it can access the index.html page that image-dired creates." + :type 'directory) + +(defcustom image-dired-gallery-image-root-url + "https://example.org/image-diredpics" + "URL where the full size images are to be found on your web server. +Note that this URL has to be configured on your web server. +Image-Dired expects to find pictures in this directory. +This is used by `image-dired-gallery-generate'." + :type 'string + :version "29.1") + +(defcustom image-dired-gallery-thumb-image-root-url + "https://example.org/image-diredthumbs" + "URL where the thumbnail images are to be found on your web server. +Note that URL path has to be configured on your web server. +Image-Dired expects to find pictures in this directory. +This is used by `image-dired-gallery-generate'." + :type 'string + :version "29.1") + +(defcustom image-dired-gallery-hidden-tags + (list "private" "hidden" "pending") + "List of \"hidden\" tags. +Used by `image-dired-gallery-generate' to leave out \"hidden\" images." + :type '(repeat string)) + (defvar image-dired-tag-file-list nil "List to store tag-file structure.") @@ -2411,19 +2479,8 @@ Track this in associated Dired buffer if (defvar image-dired-file-comment-list nil "List to store file comments.") -(defun image-dired-add-to-tag-file-list (tag file) - "Add relation between TAG and FILE." - (let (curr) - (if image-dired-tag-file-list - (if (setq curr (assoc tag image-dired-tag-file-list)) - (if (not (member file curr)) - (setcdr curr (cons file (cdr curr)))) - (setcdr image-dired-tag-file-list - (cons (list tag file) (cdr image-dired-tag-file-list)))) - (setq image-dired-tag-file-list (list (list tag file)))))) - -(defun image-dired-add-to-tag-file-lists (tag file) - "Helper function used from `image-dired-create-gallery-lists'. +(defun image-dired--add-to-tag-file-lists (tag file) + "Helper function used from `image-dired--create-gallery-lists'. Add TAG to FILE in one list and FILE to TAG in the other. @@ -2457,8 +2514,8 @@ image-dired-tag-file-list: (cons (list tag file) (cdr image-dired-tag-file-list)))) (setq image-dired-tag-file-list (list (list tag file)))))) -(defun image-dired-add-to-file-comment-list (file comment) - "Helper function used from `image-dired-create-gallery-lists'. +(defun image-dired--add-to-file-comment-list (file comment) + "Helper function used from `image-dired--create-gallery-lists'. For FILE, add COMMENT to list. @@ -2476,7 +2533,7 @@ image-dired-file-comment-list: (cdr image-dired-file-comment-list)))) (setq image-dired-file-comment-list (list (cons file comment))))) -(defun image-dired-create-gallery-lists () +(defun image-dired--create-gallery-lists () "Create temporary lists used by `image-dired-gallery-generate'." (image-dired-sane-db-file) (image-dired--with-db-file @@ -2497,15 +2554,15 @@ image-dired-file-comment-list: (setq file (car row-tags)) (dolist (x (cdr row-tags)) (if (not (string-match "^comment:\\(.*\\)" x)) - (image-dired-add-to-tag-file-lists x file) - (image-dired-add-to-file-comment-list file (match-string 1 x))))))) + (image-dired--add-to-tag-file-lists x file) + (image-dired--add-to-file-comment-list file (match-string 1 x))))))) ;; Sort tag-file list (setq image-dired-tag-file-list (sort image-dired-tag-file-list (lambda (x y) (string< (car x) (car y)))))) -(defun image-dired-hidden-p (file) +(defun image-dired--hidden-p (file) "Return t if image FILE has a \"hidden\" tag." (cl-loop for tag in (cdr (assoc file image-dired-file-tag-list)) if (member tag image-dired-gallery-hidden-tags) return t)) @@ -2519,7 +2576,7 @@ it easier to generate, then HTML-files are created in (if (eq 'per-directory image-dired-thumbnail-storage) (error "Currently, gallery generation is not supported \ when using per-directory thumbnail file storage")) - (image-dired-create-gallery-lists) + (image-dired--create-gallery-lists) (let ((tags image-dired-tag-file-list) (index-file (format "%s/index.html" image-dired-gallery-dir)) count tag tag-file @@ -2601,6 +2658,9 @@ when using per-directory thumbnail file storage")) (insert " </body>\n") (insert "</html>")))) + +;;; Tag support + (defvar image-dired-widget-list nil "List to keep track of meta data in edit buffer.") @@ -2702,6 +2762,285 @@ tags to their respective image file. Internal function used by (dolist (tag tag-list) (push (cons file tag) lst)))))) + +;;; bookmark.el support + +(declare-function bookmark-make-record-default + "bookmark" (&optional no-file no-context posn)) +(declare-function bookmark-prop-get "bookmark" (bookmark prop)) + +(defun image-dired-bookmark-name () + "Create a default bookmark name for the current EWW buffer." + (file-name-nondirectory + (directory-file-name + (file-name-directory (image-dired-original-file-name))))) + +(defun image-dired-bookmark-make-record () + "Create a bookmark for the current EWW buffer." + `(,(image-dired-bookmark-name) + ,@(bookmark-make-record-default t) + (location . ,(file-name-directory (image-dired-original-file-name))) + (image-dired-file . ,(file-name-nondirectory (image-dired-original-file-name))) + (handler . image-dired-bookmark-jump))) + +;;;###autoload +(defun image-dired-bookmark-jump (bookmark) + "Default bookmark handler for Image-Dired buffers." + ;; User already cached thumbnails, so disable any checking. + (let ((image-dired-show-all-from-dir-max-files nil)) + (image-dired (bookmark-prop-get bookmark 'location)) + ;; TODO: Go to the bookmarked file, if it exists. + ;; (bookmark-prop-get bookmark 'image-dired-file) + (goto-char (point-min)))) + + +;;; Obsolete + +;;;###autoload +(define-obsolete-function-alias 'tumme #'image-dired "24.4") + +;;;###autoload +(define-obsolete-function-alias 'image-dired-setup-dired-keybindings + #'image-dired-minor-mode "26.1") + +(defcustom image-dired-temp-image-file + (expand-file-name ".image-dired_temp" image-dired-dir) + "Name of temporary image file used by various commands." + :type 'file) +(make-obsolete-variable 'image-dired-temp-image-file + "no longer used." "29.1") + +(defcustom image-dired-cmd-create-temp-image-program + (if (executable-find "gm") "gm" "convert") + "Executable used to create temporary image. +Used together with `image-dired-cmd-create-temp-image-options'." + :type 'file + :version "29.1") +(make-obsolete-variable 'image-dired-cmd-create-temp-image-program + "no longer used." "29.1") + +(defcustom image-dired-cmd-create-temp-image-options + (let ((opts '("-size" "%wx%h" "%f[0]" + "-resize" "%wx%h>" + "-strip" "jpeg:%t"))) + (if (executable-find "gm") (cons "convert" opts) opts)) + "Options of command used to create temporary image for display window. +Used together with `image-dired-cmd-create-temp-image-program', +Available format specifiers are: %w and %h which are replaced by +the calculated max size for width and height in the image display window, +%f which is replaced by the file name of the original image and %t which +is replaced by the file name of the temporary file." + :version "29.1" + :type '(repeat (string :tag "Argument"))) +(make-obsolete-variable 'image-dired-cmd-create-temp-image-options + "no longer used." "29.1") + +(defcustom image-dired-display-window-width-correction 1 + "Number to be used to correct image display window width. +Change if the default (1) does not work (i.e. if the image does not +completely fit)." + :type 'integer) +(make-obsolete-variable 'image-dired-display-window-width-correction + "no longer used." "29.1") + +(defcustom image-dired-display-window-height-correction 0 + "Number to be used to correct image display window height. +Change if the default (0) does not work (i.e. if the image does not +completely fit)." + :type 'integer) +(make-obsolete-variable 'image-dired-display-window-height-correction + "no longer used." "29.1") + +(defun image-dired-display-window-width (window) + "Return width, in pixels, of WINDOW." + (declare (obsolete nil "29.1")) + (- (image-dired-window-width-pixels window) + image-dired-display-window-width-correction)) + +(defun image-dired-display-window-height (window) + "Return height, in pixels, of WINDOW." + (declare (obsolete nil "29.1")) + (- (image-dired-window-height-pixels window) + image-dired-display-window-height-correction)) + +(defun image-dired-window-height-pixels (window) + "Calculate WINDOW height in pixels." + (declare (obsolete nil "29.1")) + ;; Note: The mode-line consumes one line + (* (- (window-height window) 1) (frame-char-height))) + +(defcustom image-dired-cmd-read-exif-data-program "exiftool" + "Program used to read EXIF data to image. +Used together with `image-dired-cmd-read-exif-data-options'." + :type 'file) +(make-obsolete-variable 'image-dired-cmd-read-exif-data-program + "use `exif-parse-file' and `exif-field' instead." "29.1") + +(defcustom image-dired-cmd-read-exif-data-options '("-s" "-s" "-s" "-%t" "%f") + "Arguments of command used to read EXIF data. +Used with `image-dired-cmd-read-exif-data-program'. +Available format specifiers are: %f which is replaced +by the image file name and %t which is replaced by the tag name." + :version "26.1" + :type '(repeat (string :tag "Argument"))) +(make-obsolete-variable 'image-dired-cmd-read-exif-data-options + "use `exif-parse-file' and `exif-field' instead." "29.1") + +(defun image-dired-get-exif-data (file tag-name) + "From FILE, return EXIF tag TAG-NAME." + (declare (obsolete "use `exif-parse-file' and `exif-field' instead." "29.1")) + (image-dired--check-executable-exists + 'image-dired-cmd-read-exif-data-program) + (let ((buf (get-buffer-create "*image-dired-get-exif-data*")) + (spec (list (cons ?f file) (cons ?t tag-name))) + tag-value) + (with-current-buffer buf + (delete-region (point-min) (point-max)) + (if (not (eq (apply #'call-process image-dired-cmd-read-exif-data-program + nil t nil + (mapcar + (lambda (arg) (format-spec arg spec)) + image-dired-cmd-read-exif-data-options)) + 0)) + (error "Could not get EXIF tag") + (goto-char (point-min)) + ;; Clean buffer from newlines and carriage returns before + ;; getting final info + (while (search-forward-regexp "[\n\r]" nil t) + (replace-match "" nil t)) + (setq tag-value (buffer-substring (point-min) (point-max))))) + tag-value)) + +(defcustom image-dired-cmd-rotate-thumbnail-program + (if (executable-find "gm") "gm" "mogrify") + "Executable used to rotate thumbnail. +Used together with `image-dired-cmd-rotate-thumbnail-options'." + :type 'file + :version "29.1") +(make-obsolete-variable 'image-dired-cmd-rotate-thumbnail-program nil "29.1") + +(defcustom image-dired-cmd-rotate-thumbnail-options + (let ((opts '("-rotate" "%d" "%t"))) + (if (executable-find "gm") (cons "mogrify" opts) opts)) + "Arguments of command used to rotate thumbnail image. +Used with `image-dired-cmd-rotate-thumbnail-program'. +Available format specifiers are: %d which is replaced by the +number of (positive) degrees to rotate the image, normally 90 or 270 +\(for 90 degrees right and left), %t which is replaced by the file name +of the thumbnail file." + :version "29.1" + :type '(repeat (string :tag "Argument"))) +(make-obsolete-variable 'image-dired-cmd-rotate-thumbnail-options nil "29.1") + +(defun image-dired-rotate-thumbnail (degrees) + "Rotate thumbnail DEGREES degrees." + (declare (obsolete image-dired-refresh-thumb "29.1")) + (image-dired--check-executable-exists + 'image-dired-cmd-rotate-thumbnail-program) + (if (not (image-dired-image-at-point-p)) + (message "No thumbnail at point") + (let* ((file (image-dired-thumb-name (image-dired-original-file-name))) + (thumb (expand-file-name file)) + (spec (list (cons ?d degrees) (cons ?t thumb)))) + (apply #'call-process image-dired-cmd-rotate-thumbnail-program nil nil nil + (mapcar (lambda (arg) (format-spec arg spec)) + image-dired-cmd-rotate-thumbnail-options)) + (clear-image-cache thumb)))) + +(defun image-dired-rotate-thumbnail-left () + "Rotate thumbnail left (counter clockwise) 90 degrees." + (declare (obsolete image-dired-refresh-thumb "29.1")) + (interactive) + (with-suppressed-warnings ((obsolete image-dired-rotate-thumbnail)) + (image-dired-rotate-thumbnail "270"))) + +(defun image-dired-rotate-thumbnail-right () + "Rotate thumbnail counter right (clockwise) 90 degrees." + (declare (obsolete image-dired-refresh-thumb "29.1")) + (interactive) + (with-suppressed-warnings ((obsolete image-dired-rotate-thumbnail)) + (image-dired-rotate-thumbnail "90"))) + +(defun image-dired-modify-mark-on-thumb-original-file (command) + "Modify mark in Dired buffer. +COMMAND is one of `mark' for marking file in Dired, `unmark' for +unmarking file in Dired or `flag' for flagging file for delete in +Dired." + (declare (obsolete image-dired--on-file-in-dired-buffer "29.1")) + (let ((file-name (image-dired-original-file-name)) + (dired-buf (image-dired-associated-dired-buffer))) + (if (not (and dired-buf file-name)) + (message "No image, or image with correct properties, at point.") + (with-current-buffer dired-buf + (message "%s" file-name) + (when (dired-goto-file file-name) + (cond ((eq command 'mark) (dired-mark 1)) + ((eq command 'unmark) (dired-unmark 1)) + ((eq command 'toggle) + (if (image-dired-dired-file-marked-p) + (dired-unmark 1) + (dired-mark 1))) + ((eq command 'flag) (dired-flag-file-deletion 1))) + (image-dired-thumb-update-marks)))))) + +(defun image-dired-display-current-image-full () + "Display current image in full size." + (declare (obsolete image-transform-original "29.1")) + (interactive nil image-dired-thumbnail-mode) + (let ((file (image-dired-original-file-name))) + (if file + (progn + (image-dired-display-image file) + (with-current-buffer image-dired-display-image-buffer + (image-transform-original))) + (error "No original file name at point")))) + +(defun image-dired-display-current-image-sized () + "Display current image in sized to fit window dimensions." + (declare (obsolete image-mode-fit-frame "29.1")) + (interactive nil image-dired-thumbnail-mode) + (let ((file (image-dired-original-file-name))) + (if file + (progn + (image-dired-display-image file)) + (error "No original file name at point")))) + +(defun image-dired-add-to-tag-file-list (tag file) + "Add relation between TAG and FILE." + (declare (obsolete nil "29.1")) + (let (curr) + (if image-dired-tag-file-list + (if (setq curr (assoc tag image-dired-tag-file-list)) + (if (not (member file curr)) + (setcdr curr (cons file (cdr curr)))) + (setcdr image-dired-tag-file-list + (cons (list tag file) (cdr image-dired-tag-file-list)))) + (setq image-dired-tag-file-list (list (list tag file)))))) + +(defun image-dired-display-thumb-properties () + "Display thumbnail properties in the echo area." + (declare (obsolete image-dired-update-header-line "29.1")) + (image-dired-update-header-line)) + +(defvar image-dired-slideshow-count 0 + "Keeping track on number of images in slideshow.") +(make-obsolete-variable 'image-dired-slideshow-count "no longer used." "29.1") + +(defvar image-dired-slideshow-times 0 + "Number of pictures to display in slideshow.") +(make-obsolete-variable 'image-dired-slideshow-times "no longer used." "29.1") + +(define-obsolete-function-alias 'image-dired-create-display-image-buffer + #'ignore "29.1") +(define-obsolete-function-alias 'image-dired-create-gallery-lists + #'image-dired--create-gallery-lists "29.1") +(define-obsolete-function-alias 'image-dired-add-to-file-comment-list + #'image-dired--add-to-file-comment-list "29.1") +(define-obsolete-function-alias 'image-dired-add-to-tag-file-lists + #'image-dired--add-to-tag-file-lists "29.1") +(define-obsolete-function-alias 'image-dired-hidden-p + #'image-dired--hidden-p "29.1") + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;; TEST-SECTION ;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -2733,23 +3072,6 @@ tags to their respective image file. Internal function used by ;; (setq dirsize (- dirsize (car (cdar files)))) ;; (setq files (cdr files))))) -;;;;;;;;;;;;;;;;;;;;;;, - -;; (defun dired-speedbar-buttons (dired-buffer) -;; (when (and (boundp 'image-dired-use-speedbar) -;; image-dired-use-speedbar) -;; (let ((filename (with-current-buffer dired-buffer -;; (dired-get-filename)))) -;; (when (and (not (string-equal filename (buffer-string))) -;; (string-match (image-file-name-regexp) filename)) -;; (erase-buffer) -;; (insert (propertize -;; filename -;; 'display -;; (image-dired-get-thumbnail-image filename))))))) - -;; (setq image-dired-use-speedbar t) - (provide 'image-dired) ;;; image-dired.el ends here diff --git a/lisp/image-file.el b/lisp/image-file.el index fbc9eaaf94e..6df43f737dd 100644 --- a/lisp/image-file.el +++ b/lisp/image-file.el @@ -37,7 +37,7 @@ ;;;###autoload (defcustom image-file-name-extensions - (purecopy '("png" "jpeg" "jpg" "gif" "tiff" "tif" "xbm" "xpm" "pbm" "pgm" "ppm" "pnm" "svg")) + (purecopy '("png" "jpeg" "jpg" "gif" "tiff" "tif" "xbm" "xpm" "pbm" "pgm" "ppm" "pnm" "svg" "webp")) "A list of image-file filename extensions. Filenames having one of these extensions are considered image files, in addition to those matching `image-file-name-regexps'. diff --git a/lisp/image-mode.el b/lisp/image-mode.el index 4a326cdc693..6ff7859c835 100644 --- a/lisp/image-mode.el +++ b/lisp/image-mode.el @@ -58,16 +58,25 @@ It is called with one argument, the initial WINPROPS.") "Non-nil to resize the image upon first display. Its value should be one of the following: - nil, meaning no resizing. - - t, meaning to fit the image to the window height and width. - - `fit-height', meaning to fit the image to the window height. - - `fit-width', meaning to fit the image to the window width. - - A number, which is a scale factor (the default size is 1)." + - t, meaning to scale the image down to fit in the window. + - `fit-window', meaning to fit the image to the window. + - A number, which is a scale factor (the default size is 1). + +Resizing will always preserve the aspect ratio of the image." :type '(choice (const :tag "No resizing" nil) - (other :tag "Fit height and width" t) - (const :tag "Fit height" fit-height) - (const :tag "Fit width" fit-width) + (const :tag "Fit to window" fit-window) + (other :tag "Scale down to fit window" t) (number :tag "Scale factor" 1)) - :version "27.1" + :version "29.1" + :group 'image) + +(defcustom image-auto-resize-max-scale-percent nil + "Max size (in percent) to scale up to when `image-auto-resize' is `fit-window'. +Can be either a number larger than 100, or nil, which means no +max size." + :type '(choice (const :tag "No max" nil) + natnum) + :version "29.1" :group 'image) (defcustom image-auto-resize-on-window-resize 1 @@ -82,12 +91,18 @@ resizing according to the value specified in `image-auto-resize'." (defvar-local image-transform-resize nil "The image resize operation. +Non-nil to resize the image upon first display. Its value should be one of the following: - nil, meaning no resizing. - - t, meaning to fit the image to the window height and width. + - t, meaning to scale the image down to fit in the window. + - `fit-window', meaning to fit the image to the window. + - A number, which is a scale factor (the default size is 1). + +There is also support for these values, obsolete since Emacs 29.1: - `fit-height', meaning to fit the image to the window height. - `fit-width', meaning to fit the image to the window width. - - A number, which is a scale factor (the default size is 1).") + +Resizing will always preserve the aspect ratio of the image.") (defvar-local image-transform-scale 1.0 "The scale factor of the image being displayed.") @@ -440,6 +455,15 @@ call." ;;; Image Mode setup +(defcustom image-text-based-formats '(svg xpm) + "List of image formats that use a plain text format. +For such formats, display a message that explains how to edit the +image as text, when opening such images in `image-mode'." + :type '(choice (const :tag "Disable completely" nil) + (repeat :tag "List of formats" sexp)) + :version "29.1" + :group 'image) + (defvar-local image-type nil "The image type for the current Image mode buffer.") @@ -455,8 +479,9 @@ call." ;; Transformation keys (define-key map "sf" 'image-mode-fit-frame) + (define-key map "sw" 'image-transform-fit-to-window) (define-key map "sh" 'image-transform-fit-to-height) - (define-key map "sw" 'image-transform-fit-to-width) + (define-key map "si" 'image-transform-fit-to-width) (define-key map "sb" 'image-transform-fit-both) (define-key map "ss" 'image-transform-set-scale) (define-key map "sr" 'image-transform-set-rotation) @@ -511,12 +536,10 @@ call." "--" ["Fit Frame to Image" image-mode-fit-frame :active t :help "Resize frame to match image"] - ["Fit Image to Window (Best Fit)" image-transform-fit-both - :help "Resize image to match the window height and width"] - ["Fit to Window Height" image-transform-fit-to-height - :help "Resize image to match the window height"] - ["Fit to Window Width" image-transform-fit-to-width - :help "Resize image to match the window width"] + ["Fit Image to Window" image-transform-fit-to-window + :help "Resize image to match the window height and width"] + ["Fit Image to Window (Scale down only)" image-transform-fit-both + :help "Scale image down to match the window height and width"] ["Zoom In" image-increase-size :help "Enlarge the image"] ["Zoom Out" image-decrease-size @@ -605,8 +628,9 @@ call." ;;;###autoload (defun image-mode () "Major mode for image files. -You can use \\<image-mode-map>\\[image-toggle-display] or \\<image-mode-map>\\[image-toggle-hex-display] -to toggle between display as an image and display as text or hex. +You can use \\<image-mode-map>\\[image-toggle-display] or \ +\\[image-toggle-hex-display] to toggle between display +as an image and display as text or hex. Key bindings: \\{image-mode-map}" @@ -678,12 +702,10 @@ Key bindings: (run-mode-hooks 'image-mode-hook) (let ((image (image-get-display-property)) - (msg1 (substitute-command-keys - "Type \\[image-toggle-display] or \\[image-toggle-hex-display] to view the image as ")) - animated) + msg animated) (cond ((null image) - (message "%s" (concat msg1 "an image."))) + (setq msg "an image")) ((setq animated (image-multi-frame-p image)) (setq image-multi-frame t mode-line-process @@ -701,10 +723,13 @@ Key bindings: keymap (down-mouse-1 . image-next-frame) (down-mouse-3 . image-previous-frame))))))) - (message "%s" - (concat msg1 "text. This image has multiple frames."))) + (setq msg "text. This image has multiple frames")) (t - (message "%s" (concat msg1 "text or hex.")))))) + (setq msg "text"))) + (when (memq (plist-get (cdr image) :type) image-text-based-formats) + (message (substitute-command-keys + "Type \\[image-toggle-display] to view the image as %s") + msg)))) ;;;###autoload (define-minor-mode image-minor-mode @@ -751,11 +776,11 @@ on these modes." (image-mode-to-text) ;; Turn on hexl-mode (hexl-mode) - (message "%s" (concat - (substitute-command-keys - "Type \\[image-toggle-hex-display] or \\[image-toggle-display] to view the image as ") - (if (image-get-display-property) - "hex" "an image or text") "."))) + (message (substitute-command-keys + "Type \\[image-toggle-hex-display] or \ +\\[image-toggle-display] to view the image as %s") + (if (image-get-display-property) + "hex" "an image or text"))) (defun image-mode-as-text () "Set a non-image mode as major mode in combination with image minor mode. @@ -771,11 +796,10 @@ See commands `image-mode' and `image-minor-mode' for more information on these modes." (interactive) (image-mode-to-text) - (message "%s" (concat - (substitute-command-keys - "Type \\[image-toggle-display] or \\[image-toggle-hex-display] to view the image as ") - (if (image-get-display-property) - "text" "an image or hex") "."))) + (message (substitute-command-keys + "Type \\[image-toggle-display] to view the image as %s") + (if (image-get-display-property) + "text" "an image"))) (defun image-toggle-display-text () "Show the image file as text. @@ -803,6 +827,21 @@ Remove text properties that display the image." (defvar tar-superior-buffer) (declare-function image-flush "image.c" (spec &optional frame)) +(defun image--scale-within-limits-p (image) + "Return t if `fit-window' will scale image within the customized limits. +The limits are given by the user option +`image-auto-resize-max-scale-percent'." + (or (not image-auto-resize-max-scale-percent) + (let ((scale (/ image-auto-resize-max-scale-percent 100)) + (mw (plist-get (cdr image) :max-width)) + (mh (plist-get (cdr image) :max-height)) + ;; Note: `image-size' looks up and thus caches the + ;; untransformed image. There's no easy way to + ;; prevent that. + (size (image-size image t))) + (or (<= mw (* (car size) scale)) + (<= mh (* (cdr size) scale)))))) + (defun image-toggle-display-image () "Show the image of the image file. Turn the image data into a real image, but only if the whole file @@ -837,7 +876,8 @@ was inserted." filename)) ;; If we have a `fit-width' or a `fit-height', don't limit ;; the size of the image to the window size. - (edges (when (eq image-transform-resize t) + (edges (when (or (eq image-transform-resize t) + (eq image-transform-resize 'fit-window)) (window-inside-pixel-edges (get-buffer-window)))) (max-width (when edges (- (nth 2 edges) (nth 0 edges)))) @@ -884,6 +924,14 @@ was inserted." ;; Type hint. :format (and filename data-p)))) + ;; Handle `fit-window'. + (when (and (eq image-transform-resize 'fit-window) + (image--scale-within-limits-p image)) + (setq image + (cons (car image) + (plist-put (cdr image) :width + (plist-get (cdr image) :max-width))))) + ;; Discard any stale image data before looking it up again. (image-flush image) (setq image (append image (image-transform-properties image))) @@ -1494,21 +1542,29 @@ return value is suitable for appending to an image spec." (defun image-transform-fit-to-height () "Fit the current image to the height of the current window." (interactive) + (declare (obsolete nil "29.1")) (setq image-transform-resize 'fit-height) (image-toggle-display-image)) (defun image-transform-fit-to-width () "Fit the current image to the width of the current window." + (declare (obsolete nil "29.1")) (interactive) (setq image-transform-resize 'fit-width) (image-toggle-display-image)) (defun image-transform-fit-both () - "Fit the current image both to the height and width of the current window." + "Scale the current image down to fit in the current window." (interactive) (setq image-transform-resize t) (image-toggle-display-image)) +(defun image-transform-fit-to-window () + "Fit the current image to the height and width of the current window." + (interactive) + (setq image-transform-resize 'fit-window) + (image-toggle-display-image)) + (defun image-transform-set-rotation (rotation) "Prompt for an angle ROTATION, and rotate the image by that amount. ROTATION should be in degrees." diff --git a/lisp/image.el b/lisp/image.el index 6e1dbbdf5cd..cedefc038f0 100644 --- a/lisp/image.el +++ b/lisp/image.el @@ -27,6 +27,8 @@ (defgroup image () "Image support." + :prefix "image-" + :link '(info-link "(emacs) Image Mode") :group 'multimedia) (declare-function image-flush "image.c" (spec &optional frame)) @@ -48,6 +50,7 @@ static \\(unsigned \\)?char \\1_bits" . xbm) ("\\`\\(?:MM\0\\*\\|II\\*\0\\)" . tiff) ("\\`[\t\n\r ]*%!PS" . postscript) ("\\`\xff\xd8" . jpeg) ; used to be (image-jpeg-p . jpeg) + ("\\`RIFF....WEBPVP8" . webp) (,(let* ((incomment-re "\\(?:[^-]\\|-[^-]\\)") (comment-re (concat "\\(?:!--" incomment-re "*-->[ \t\r\n]*<\\)"))) (concat "\\(?:<\\?xml[ \t\r\n]+[^>]*>\\)?[ \t\r\n]*<" @@ -67,6 +70,7 @@ a non-nil value, TYPE is the image's type.") '(("\\.png\\'" . png) ("\\.gif\\'" . gif) ("\\.jpe?g\\'" . jpeg) + ("\\.webp\\'" . webp) ("\\.bmp\\'" . bmp) ("\\.xpm\\'" . xpm) ("\\.pbm\\'" . pbm) @@ -92,6 +96,7 @@ be of image type IMAGE-TYPE.") (jpeg . maybe) (tiff . maybe) (svg . maybe) + (webp . maybe) (postscript . nil)) "Alist of (IMAGE-TYPE . AUTODETECT) pairs used to auto-detect image files. \(See `image-type-auto-detected-p'). @@ -556,7 +561,12 @@ If VALUE is nil, PROPERTY is removed from IMAGE." (declare (gv-setter image--set-property)) (plist-get (cdr image) property)) -(defun image-compute-scaling-factor (scaling) +(defun image-compute-scaling-factor (&optional scaling) + "Compute the scaling factor based on SCALING. +If a number, use that. If it's `auto', compute the factor. +If nil, use the `image-scaling-factor' variable." + (unless scaling + (setq scaling image-scaling-factor)) (cond ((numberp scaling) scaling) ((eq scaling 'auto) @@ -600,7 +610,7 @@ means display it in the right marginal area." ;;;###autoload -(defun insert-image (image &optional string area slice) +(defun insert-image (image &optional string area slice inhibit-isearch) "Insert IMAGE into current buffer at point. IMAGE is displayed by inserting STRING into the current buffer with a `display' property whose value is the image. @@ -617,7 +627,11 @@ SLICE specifies slice of IMAGE to insert. SLICE nil or omitted means insert whole image. SLICE is a list (X Y WIDTH HEIGHT) specifying the X and Y positions and WIDTH and HEIGHT of image area to insert. A float value 0.0 - 1.0 means relative to the width or -height of the image; integer values are taken as pixel values." +height of the image; integer values are taken as pixel values. + +Normally `isearch' is able to search for STRING in the buffer +even if it's hidden behind a displayed image. If INHIBIT-ISEARCH +is non-nil, this is inhibited." ;; Use a space as least likely to cause trouble when it's a hidden ;; character in the buffer. (unless string (setq string " ")) @@ -641,6 +655,7 @@ height of the image; integer values are taken as pixel values." (list (cons 'slice slice) image) image) rear-nonsticky t + inhibit-isearch ,inhibit-isearch keymap ,image-map)))) @@ -791,7 +806,7 @@ Example: (defimage test-image ((:type xpm :file \"~/test1.xpm\") (:type xbm :file \"~/test1.xbm\")))" - (declare (doc-string 3)) + (declare (doc-string 3) (indent defun)) `(defvar ,symbol (find-image ',specs) ,doc)) @@ -823,15 +838,18 @@ in which case you might want to use `image-default-frame-delay'." (make-obsolete 'image-animated-p 'image-multi-frame-p "24.4") -;; "Destructively"? -(defun image-animate (image &optional index limit) +(defun image-animate (image &optional index limit position) "Start animating IMAGE. Animation occurs by destructively altering the IMAGE spec list. With optional INDEX, begin animating from that animation frame. LIMIT specifies how long to animate the image. If omitted or nil, play the animation until the end. If t, loop forever. If a -number, play until that number of seconds has elapsed." +number, play until that number of seconds has elapsed. + +If POSITION (which should be buffer position where the image is +displayed), stop the animation if the image is no longer +displayed." (let ((animation (image-multi-frame-p image)) timer) (when animation @@ -839,6 +857,9 @@ number, play until that number of seconds has elapsed." (cancel-timer timer)) (plist-put (cdr image) :animate-buffer (current-buffer)) (plist-put (cdr image) :animate-tardiness 0) + (when position + (plist-put (cdr image) :animate-position + (set-marker (make-marker) position (current-buffer)))) ;; Stash the data about the animation here so that we don't ;; trigger image recomputation unnecessarily later. (plist-put (cdr image) :animate-multi-frame-data animation) @@ -912,40 +933,54 @@ for the animation speed. A negative value means to animate in reverse." (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)) - ;; Cumulatively delayed two seconds more than expected. - (or (< (plist-get (cdr image) :animate-tardiness) 2) - (progn - (message "Stopping animation; animation possibly too big") - nil))) - (image-show-frame image n t) - (let* ((speed (image-animate-get-speed image)) - (time (current-time)) - (time-to-load-image (time-since time)) - (stated-delay-time - (/ (or (cdr (plist-get (cdr image) :animate-multi-frame-data)) - image-default-frame-delay) - (float (abs speed)))) - ;; Subtract off the time we took to load the image from the - ;; stated delay time. - (delay (max (float-time (time-subtract stated-delay-time - time-to-load-image)) - image-minimum-frame-delay)) - done) - (setq n (if (< speed 0) - (1- n) - (1+ n))) - (if limit - (cond ((>= n count) (setq n 0)) - ((< n 0) (setq n (1- count)))) - (and (or (>= n count) (< n 0)) (setq done t))) - (setq time-elapsed (+ delay time-elapsed)) - (if (numberp limit) - (setq done (>= time-elapsed limit))) - (unless done - (run-with-timer delay nil #'image-animate-timeout - image n count time-elapsed limit - (+ (float-time) delay)))))) + (let ((buffer (plist-get (cdr image) :animate-buffer)) + (position (plist-get (cdr image) :animate-position))) + (when (and (buffer-live-p buffer) + ;; If we have a :animate-position setting, the caller + ;; has requested that the animation be stopped if the + ;; image is no longer displayed in the buffer. + (or (null position) + (with-current-buffer buffer + (let ((disp (get-text-property position 'display))) + (and (consp disp) + (eq (car disp) 'image) + ;; We can't check `eq'-ness of the image + ;; itself, since that may change. + (eq position + (plist-get (cdr disp) :animate-position)))))) + ;; Cumulatively delayed two seconds more than expected. + (or (< (plist-get (cdr image) :animate-tardiness) 2) + (progn + (message "Stopping animation; animation possibly too big") + nil))) + (let* ((time (prog1 (current-time) + (image-show-frame image n t))) + (speed (image-animate-get-speed image)) + (time-to-load-image (time-since time)) + (stated-delay-time + (/ (or (cdr (plist-get (cdr image) :animate-multi-frame-data)) + image-default-frame-delay) + (float (abs speed)))) + ;; Subtract off the time we took to load the image from the + ;; stated delay time. + (delay (max (float-time (time-subtract stated-delay-time + time-to-load-image)) + image-minimum-frame-delay)) + done) + (setq n (if (< speed 0) + (1- n) + (1+ n))) + (if limit + (cond ((>= n count) (setq n 0)) + ((< n 0) (setq n (1- count)))) + (and (or (>= n count) (< n 0)) (setq done t))) + (setq time-elapsed (+ delay time-elapsed)) + (if (numberp limit) + (setq done (>= time-elapsed limit))) + (unless done + (run-with-timer delay nil #'image-animate-timeout + image n count time-elapsed limit + (+ (float-time) delay))))))) (defvar imagemagick-types-inhibit) @@ -1137,6 +1172,13 @@ default is 20%." (error "No image under point")) image)) +;;;###autoload +(defun image-at-point-p () + "Return non-nil if there is an image at point." + (condition-case nil + (prog1 t (image--get-image)) + (error nil))) + (defun image--get-imagemagick-and-warn (&optional position) (declare-function image-transforms-p "image.c" (&optional frame)) (unless (or (fboundp 'imagemagick-types) (image-transforms-p)) diff --git a/lisp/image/exif.el b/lisp/image/exif.el index c2cf2346408..372e2d25553 100644 --- a/lisp/image/exif.el +++ b/lisp/image/exif.el @@ -58,6 +58,9 @@ ;; (:tag 306 :tag-name date-time :format 2 :format-type ascii ;; :value "2019:09:21 16:22:13") ;; ...) +;; +;; (exif-field 'date-time (exif-parse-file "test.jpg")) => +;; "2022:09:14 18:46:19" ;;; Code: @@ -65,6 +68,7 @@ (defvar exif-tag-alist '((11 processing-software) + (270 description) (271 make) (272 model) (274 orientation) @@ -73,7 +77,8 @@ (296 resolution-unit) (305 software) (306 date-time) - (315 artist)) + (315 artist) + (33432 copyright)) "Alist of tag values and their names.") (defconst exif--orientation @@ -122,13 +127,20 @@ If the data is invalid, an `exif-error' is signaled." (when-let ((app1 (cdr (assq #xffe1 (exif--parse-jpeg))))) (exif--parse-exif-chunk app1)))))) +(defun exif-field (field data) + "Return raw FIELD from EXIF. +If FIELD is not present in the data, return nil. +FIELD is a symbol in the cdr of `exif-tag-alist'. +DATA is the result of calling `exif-parse-file'." + (plist-get (seq-find (lambda (e) + (eq field (plist-get e :tag-name))) + data) + :value)) + (defun exif-orientation (exif) "Return the orientation (in degrees) in EXIF. If the orientation isn't present in the data, return nil." - (let ((code (plist-get (cl-find 'orientation exif - :key (lambda (e) - (plist-get e :tag-name))) - :value))) + (let ((code (exif-field 'orientation exif))) (cadr (assq code exif--orientation)))) (defun exif--parse-jpeg () diff --git a/lisp/image/gravatar.el b/lisp/image/gravatar.el index f6f056a2baf..87726a9b8c8 100644 --- a/lisp/image/gravatar.el +++ b/lisp/image/gravatar.el @@ -277,7 +277,7 @@ where GRAVATAR is either an image descriptor, or the symbol ;; Store the image in the cache. (when image (setf (gethash mail-address gravatar--cache) - (cons (time-convert (current-time) 'integer) + (cons (time-convert nil 'integer) image))) (prog1 (apply callback (if data image 'error) cbargs) @@ -286,7 +286,7 @@ where GRAVATAR is either an image descriptor, or the symbol (defun gravatar--prune-cache () (let ((expired nil) - (time (- (time-convert (current-time) 'integer) + (time (- (time-convert nil 'integer) ;; Twelve hours. (* 12 60 60)))) (maphash (lambda (key val) diff --git a/lisp/indent.el b/lisp/indent.el index aa6b8d17c4a..ec01733d123 100644 --- a/lisp/indent.el +++ b/lisp/indent.el @@ -88,16 +88,20 @@ This variable has no effect unless `tab-always-indent' is `complete'." indent-relative-first-indent-point) "Values that are ignored by `indent-according-to-mode'.") -(defun indent-according-to-mode () +(defun indent-according-to-mode (&optional inhibit-widen) "Indent line in proper way for current major mode. Normally, this is done by calling the function specified by the variable `indent-line-function'. However, if the value of that variable is present in the `indent-line-ignored-functions' variable, handle it specially (since those functions are used for tabbing); -in that case, indent by aligning to the previous non-blank line." +in that case, indent by aligning to the previous non-blank line. + +Ignore restriction, unless the optional argument INHIBIT-WIDEN is +non-nil." (interactive) (save-restriction - (widen) + (unless inhibit-widen + (widen)) (syntax-propertize (line-end-position)) (if (memq indent-line-function indent-line-ignored-functions) ;; These functions are used for tabbing, but can't be used for @@ -601,7 +605,10 @@ column to indent to; if it is nil, use one of the three methods above." (funcall indent-region-function start end))) ;; Else, use a default implementation that calls indent-line-function on ;; each line. - (t (indent-region-line-by-line start end))) + (t + (save-restriction + (widen) + (indent-region-line-by-line start end)))) ;; In most cases, reindenting modifies the buffer, but it may also ;; leave it unmodified, in which case we have to deactivate the mark ;; by hand. @@ -615,7 +622,7 @@ column to indent to; if it is nil, use one of the three methods above." (make-progress-reporter "Indenting region..." (point) end)))) (while (< (point) end) (or (and (bolp) (eolp)) - (indent-according-to-mode)) + (indent-according-to-mode t)) (forward-line 1) (and pr (progress-reporter-update pr (point)))) (and pr (progress-reporter-done pr)) diff --git a/lisp/info-look.el b/lisp/info-look.el index cc6a806f56f..48120359193 100644 --- a/lisp/info-look.el +++ b/lisp/info-look.el @@ -43,6 +43,7 @@ (require 'info) (eval-when-compile (require 'subr-x)) +(eval-when-compile (require 'cl-lib)) (defgroup info-lookup nil "Major mode sensitive help agent." @@ -123,6 +124,14 @@ OTHER-MODES is a list of cross references to other help modes.") (defsubst info-lookup->mode-value (topic mode) (assoc mode (info-lookup->topic-value topic))) +(defun info-lookup--expand-info (info) + ;; We have a dynamic doc-spec function. + (when (and (null (nth 3 info)) + (nth 6 info)) + (setf (nth 3 info) (funcall (nth 6 info)) + (nth 6 info) nil)) + info) + (defsubst info-lookup->regexp (topic mode) (nth 1 (info-lookup->mode-value topic mode))) @@ -145,7 +154,11 @@ Function arguments are specified as keyword/argument pairs: (KEYWORD . ARGUMENT) KEYWORD is either `:topic', `:mode', `:regexp', `:ignore-case', - `:doc-spec', `:parse-rule', or `:other-modes'. + `:doc-spec', `:parse-rule', `:other-modes' or `:doc-spec-function'. + `:doc-spec-function' is used to compute a `:doc-spec', but instead of + doing so at load time, this is done when the user asks for info on + the mode in question. + ARGUMENT has a value as explained in the documentation of the variable `info-lookup-alist'. @@ -161,7 +174,8 @@ for more details." (defun info-lookup-add-help* (maybe &rest arg) (let (topic mode regexp ignore-case doc-spec - parse-rule other-modes keyword value) + parse-rule other-modes keyword value + doc-spec-function) (setq topic 'symbol mode major-mode regexp "\\w+") @@ -184,6 +198,8 @@ for more details." (setq ignore-case value)) ((eq keyword :doc-spec) (setq doc-spec value)) + ((eq keyword :doc-spec-function) + (setq doc-spec-function value)) ((eq keyword :parse-rule) (setq parse-rule value)) ((eq keyword :other-modes) @@ -191,7 +207,8 @@ for more details." (t (error "Unknown keyword \"%S\"" keyword)))) (or (and maybe (info-lookup->mode-value topic mode)) - (let* ((data (list regexp ignore-case doc-spec parse-rule other-modes)) + (let* ((data (list regexp ignore-case doc-spec parse-rule other-modes + doc-spec-function)) (topic-cell (or (assoc topic info-lookup-alist) (car (setq info-lookup-alist (cons (cons topic nil) @@ -341,11 +358,22 @@ If optional argument QUERY is non-nil, query for the help mode." (error "No %s help available for `%s'" topic mode)) (setq info-lookup-mode mode))) +(defun info-lookup--item-to-mode (item mode) + (let ((spec (cons mode (car (split-string (if (stringp item) + item + (symbol-name item)) + "-"))))) + (if (assoc spec (cdr (assq 'symbol info-lookup-alist))) + spec + mode))) + (defun info-lookup (topic item mode) "Display the documentation of a help item." (or mode (setq mode (info-lookup-select-mode))) - (or (info-lookup->mode-value topic mode) - (error "No %s help available for `%s'" topic mode)) + (setq mode (info-lookup--item-to-mode item mode)) + (if-let ((info (info-lookup->mode-value topic mode))) + (info-lookup--expand-info info) + (error "No %s help available for `%s'" topic mode)) (let* ((completions (info-lookup->completions topic mode)) (ignore-case (info-lookup->ignore-case topic mode)) (entry (or (assoc (if ignore-case (downcase item) item) completions) @@ -724,6 +752,8 @@ Return nil if there is nothing appropriate in the buffer near point." (defun info-complete (topic mode) "Try to complete a help item." (barf-if-buffer-read-only) + (when-let ((info (info-lookup->mode-value topic mode))) + (info-lookup--expand-info info)) (let ((data (info-lookup-completions-at-point topic mode))) (if (null data) (error "No %s completion available for `%s' at point" topic mode) @@ -904,9 +934,16 @@ Return nil if there is nothing appropriate in the buffer near point." (info-lookup-maybe-add-help :mode 'python-mode - :doc-spec `((,(if (Info-find-file "python3.9" t) - "(python3.9)Index" - "(python)Index")))) + ;; Debian includes Python info files, but they're version-named + ;; instead of having a symlink. + :doc-spec-function (lambda () + (list + (list + (cl-loop for version from 20 downto 7 + for name = (format "python3.%d" version) + if (Info-find-file name t) + return (format "(%s)Index" name) + finally return "(python)Index"))))) (info-lookup-maybe-add-help :mode 'cperl-mode @@ -944,6 +981,67 @@ Return nil if there is nothing appropriate in the buffer near point." ("(cl)Function Index" nil "^ -+ .*: " "\\( \\|$\\)") ("(cl)Variable Index" nil "^ -+ .*: " "\\( \\|$\\)"))) +(mapc + (lambda (elem) + (let* ((prefix (car elem))) + (info-lookup-add-help + :mode (cons 'emacs-lisp-mode prefix) + :regexp (concat "\\b" prefix "-[^][()`'‘’,\" \t\n]+") + :doc-spec (cl-loop for node in (cdr elem) + collect + (list (if (string-match-p "^(" node) + node + (format "(%s)%s" prefix node)) + nil "^ -+ .*: " "\\( \\|$\\)"))))) + ;; Below we have a list of prefixes (used to match on symbols in + ;; `emacs-lisp-mode') and the nodes where the function/variable + ;; indices live. If the prefix is different than the name of the + ;; manual, then the full "(manual)Node" name has to be used. + '(("auth" "Function Index" "Variable Index") + ("autotype" "Command Index" "Variable Index") + ("calc" "Lisp Function Index" "Variable Index") + ;;("cc-mode" "Variable Index" "Command and Function Index") + ("dbus" "Index") + ("ediff" "Index") + ("eieio" "Function Index") + ("gnutls" "(emacs-gnutls)Variable Index" "(emacs-gnutls)Function Index") + ("mm" "(emacs-mime)Index") + ("epa" "Variable Index" "Function Index") + ("ert" "Index") + ("eshell" "Function and Variable Index") + ("eudc" "Index") + ("eww" "Variable Index" "Lisp Function Index") + ("flymake" "Index") + ("forms" "Index") + ("gnus" "Index") + ("htmlfontify" "Functions" "Variables & Customization") + ("idlwave" "Index") + ("ido" "Variable Index" "Function Index") + ("info" "Index") + ("mairix" "(mairix-el)Variable Index" "(mairix-el)Function Index") + ("message" "Index") + ("mh" "(mh-e)Option Index" "(mh-e)Command Index") + ("newsticker" "Index") + ("octave" "(octave-mode)Variable Index" "(octave-mode)Lisp Function Index") + ("org" "Variable Index" "Command and Function Index") + ("pgg" "Variable Index" "Function Index") + ("rcirc" "Variable Index" "Index") + ("reftex" "Index") + ("sasl" "Variable Index" "Function Index") + ("sc" "Variable Index") + ("semantic" "Index") + ("ses" "Index") + ("sieve" "Index") + ("smtpmail" "Function and Variable Index") + ("srecode" "Index") + ("tramp" "Variable Index" "Function Index") + ("url" "Variable Index" "Function Index") + ("vhdl" "(vhdl-mode)Variable Index" "(vhdl-mode)Command Index") + ("viper" "Variable Index" "Function Index") + ("widget" "Index") + ("wisent" "Index") + ("woman" "Variable Index" "Command Index"))) + ;; docstrings talk about elisp, so have apropos-mode follow emacs-lisp-mode (info-lookup-maybe-add-help :mode 'apropos-mode diff --git a/lisp/info.el b/lisp/info.el index 8c08eaec3c8..559460e8d2c 100644 --- a/lisp/info.el +++ b/lisp/info.el @@ -115,7 +115,9 @@ The Lisp code is executed when the node is selected.") (defface info-menu-star '((((class color)) :foreground "red1") (t :underline t)) - "Face for every third `*' in an Info menu.") + "Face used to emphasize `*' in an Info menu. +The face is assigned to the third, sixth, and ninth `*' for easier +orientation. See `Info-nth-menu-item'.") (defface info-xref '((t :inherit link)) @@ -1792,7 +1794,46 @@ of NODENAME; if none is found it then tries a case-insensitive match (if trim (setq nodename (substring nodename 0 trim)))) (if transient-mark-mode (deactivate-mark)) (Info-find-node (if (equal filename "") nil filename) - (if (equal nodename "") "Top" nodename) nil strict-case))) + (if (equal nodename "") "Top" nodename) nil strict-case))) + +(defun Info-goto-node-web (node) + "Use `browse-url' to go to the gnu.org web server's version of NODE. +By default, go to the current Info node." + (interactive (list (Info-read-node-name + "Go to node (default current page): " Info-current-node)) + Info-mode) + (browse-url-button-open-url + (Info-url-for-node (format "(%s)%s" (file-name-sans-extension + (file-name-nondirectory + Info-current-file)) + node)))) + +(defun Info-url-for-node (node) + "Return a URL for NODE, a node in the GNU Emacs or Elisp manual. +NODE should be a string on the form \"(manual)Node\". Only emacs +and elisp manuals are supported." + (unless (string-match "\\`(\\(.+\\))\\(.+\\)\\'" node) + (error "Invalid node name %s" node)) + (let ((manual (match-string 1 node)) + (node (match-string 2 node))) + (unless (member manual '("emacs" "elisp")) + (error "Only emacs/elisp manuals are supported")) + ;; Encode a bunch of characters the way that makeinfo does. + (setq node + (mapconcat (lambda (ch) + (if (or (< ch 32) ; ^@^A-^Z^[^\^]^^^- + (<= 33 ch 47) ; !"#$%&'()*+,-./ + (<= 58 ch 64) ; :;<=>?@ + (<= 91 ch 96) ; [\]_` + (<= 123 ch 127)) ; {|}~ DEL + (format "_00%x" ch) + (char-to-string ch))) + node + "")) + (concat "https://www.gnu.org/software/emacs/manual/html_node/" + manual "/" + (url-hexify-string (string-replace " " "-" node)) + ".html"))) (defvar Info-read-node-completion-table) @@ -1877,7 +1918,7 @@ See `completing-read' for a description of arguments and usage." code Info-read-node-completion-table string predicate)))) ;; Arrange to highlight the proper letters in the completion list buffer. -(defun Info-read-node-name (prompt) +(defun Info-read-node-name (prompt &optional default) "Read an Info node name with completion, prompting with PROMPT. A node name can have the form \"NODENAME\", referring to a node in the current Info file, or \"(FILENAME)NODENAME\", referring to @@ -1885,7 +1926,8 @@ a node in FILENAME. \"(FILENAME)\" is a short format to go to the Top node in FILENAME." (let* ((completion-ignore-case t) (Info-read-node-completion-table (Info-build-node-completions)) - (nodename (completing-read prompt #'Info-read-node-name-1 nil t))) + (nodename (completing-read prompt #'Info-read-node-name-1 nil t nil + 'Info-minibuf-history default))) (if (equal nodename "") (Info-read-node-name prompt) nodename))) @@ -2604,12 +2646,9 @@ new buffer." (if (eq (length completions) 1) (setq default (car completions))) (if completions - (let ((input (completing-read (if default - (concat - "Follow reference named (default " - default "): ") - "Follow reference named: ") - completions nil t))) + (let ((input (completing-read (format-prompt "Follow reference named" + default) + completions nil t))) (list (if (equal input "") default input) current-prefix-arg)) @@ -4049,6 +4088,7 @@ If FORK is non-nil, it is passed to `Info-goto-node'." (define-key map "e" 'end-of-buffer) (define-key map "f" 'Info-follow-reference) (define-key map "g" 'Info-goto-node) + (define-key map "G" 'Info-goto-node-web) (define-key map "h" 'Info-help) ;; This is for compatibility with standalone info (>~ version 5.2). ;; Though for some time, standalone info had H and h reversed. @@ -4858,9 +4898,16 @@ first line or header line, and for breadcrumb links.") ;; an end of sentence (skip-syntax-backward " (")) (setq other-tag - (cond ((save-match-data (looking-back "\\(^\\| \\)see" + (cond ((save-match-data (looking-back "\\(^\\|[ (]\\)see" (- (point) 4))) "") + ;; We want "Also *note" to produce + ;; "Also see", but "See also *note" to produce + ;; "See also", so match case-sensitively. + ((save-match-data (let ((case-fold-search nil)) + (looking-back "\\(^\\| \\)also" + (- (point) 5)))) + "") ((save-match-data (looking-back "\\(^\\| \\)in" (- (point) 3))) "") diff --git a/lisp/international/ccl.el b/lisp/international/ccl.el index 629cd4c2879..883b0b60fc9 100644 --- a/lisp/international/ccl.el +++ b/lisp/international/ccl.el @@ -1553,7 +1553,7 @@ MAP := MAP-IDs := MAP-ID ... MAP-SET := MAP-IDs | (MAP-IDs) MAP-SET MAP-ID := integer" - (declare (doc-string 3)) + (declare (doc-string 3) (indent defun)) `(let ((prog ,(unwind-protect (progn ;; To make ,(charset-id CHARSET) works well. diff --git a/lisp/international/characters.el b/lisp/international/characters.el index 5aefda23283..a2156ee01aa 100644 --- a/lisp/international/characters.el +++ b/lisp/international/characters.el @@ -1493,6 +1493,9 @@ Setup `char-width-table' appropriate for non-CJK language environment." (aset char-acronym-table #x202D "LRO") ; LEFT-TO-RIGHT OVERRIDE (aset char-acronym-table #x202E "RLO") ; RIGHT-TO-LEFT OVERRIDE (aset char-acronym-table #x2060 "WJ") ; WORD JOINER +(aset char-acronym-table #x2066 "LRI") ; LEFT-TO-RIGHT ISOLATE +(aset char-acronym-table #x2067 "RLI") ; RIGHT-TO-LEFT ISOLATE +(aset char-acronym-table #x2069 "PDI") ; POP DIRECTIONAL ISOLATE (aset char-acronym-table #x206A "ISS") ; INHIBIT SYMMETRIC SWAPPING (aset char-acronym-table #x206B "ASS") ; ACTIVATE SYMMETRIC SWAPPING (aset char-acronym-table #x206C "IAFS") ; INHIBIT ARABIC FORM SHAPING @@ -1517,18 +1520,32 @@ Setup `char-width-table' appropriate for non-CJK language environment." (aset char-acronym-table (+ #xE0021 i) (format " %c TAG" (+ 33 i)))) (aset char-acronym-table #xE007F "->|TAG") ; CANCEL TAG +;; We can't use the \N{name} things here, because this file is used +;; too early in the build process. +(defvar glyphless--bidi-control-characters + '(#x202a ; ?\N{left-to-right embedding} + #x202b ; ?\N{right-to-left embedding} + #x202d ; ?\N{left-to-right override} + #x202e ; ?\N{right-to-left override} + #x2066 ; ?\N{left-to-right isolate} + #x2067 ; ?\N{right-to-left isolate} + #x2068 ; ?\N{first strong isolate} + #x202c ; ?\N{pop directional formatting} + #x2069)) ; ?\N{pop directional isolate}) + (defun update-glyphless-char-display (&optional variable value) "Make the setting of `glyphless-char-display-control' take effect. This function updates the char-table `glyphless-char-display', and is intended to be used in the `:set' attribute of the option `glyphless-char-display'." - (when value + (when variable (set-default variable value)) (dolist (elt value) (let ((target (car elt)) (method (cdr elt))) - (or (memq method '(zero-width thin-space empty-box acronym hex-code)) - (error "Invalid glyphless character display method: %s" method)) + (unless (memq method '( zero-width thin-space empty-box + acronym hex-code bidi-control)) + (error "Invalid glyphless character display method: %s" method)) (cond ((eq target 'c0-control) (glyphless-set-char-table-range glyphless-char-display #x00 #x1F method) @@ -1543,24 +1560,29 @@ option `glyphless-char-display'." ((eq target 'variation-selectors) (glyphless-set-char-table-range glyphless-char-display #xFE00 #xFE0F method)) - ((eq target 'format-control) + ((or (eq target 'format-control) + (eq target 'bidi-control)) (when unicode-category-table (map-char-table (lambda (char category) - (if (eq category 'Cf) - (let ((this-method method) - from to) - (if (consp char) - (setq from (car char) to (cdr char)) - (setq from char to char)) - (while (<= from to) - (when (/= from #xAD) - (if (eq method 'acronym) - (setq this-method - (aref char-acronym-table from))) + (when (eq category 'Cf) + (let ((this-method method) + from to) + (if (consp char) + (setq from (car char) to (cdr char)) + (setq from char to char)) + (while (<= from to) + (when (/= from #xAD) + (when (eq method 'acronym) + (setq this-method + (or (aref char-acronym-table from) + "UNK"))) + (when (or (eq target 'format-control) + (memq from + glyphless--bidi-control-characters)) (set-char-table-range glyphless-char-display - from this-method)) - (setq from (1+ from)))))) + from this-method))) + (setq from (1+ from)))))) unicode-category-table))) ((eq target 'no-font) (set-char-table-extra-slot glyphless-char-display 0 method)) @@ -1576,6 +1598,19 @@ option `glyphless-char-display'." (set-char-table-range chartable (cons from to) method))) ;;; Control of displaying glyphless characters. +(define-widget 'glyphless-char-display-method 'lazy + "Display method for glyphless characters." + :group 'mule + :format "%v" + :value 'thin-space + :type + '(choice + (const :tag "Don't display" zero-width) + (const :tag "Display as thin space" thin-space) + (const :tag "Display as empty box" empty-box) + (const :tag "Display acronym" acronym) + (const :tag "Display hex code in a box" hex-code))) + (defcustom glyphless-char-display-control '((format-control . thin-space) (variation-selectors . thin-space) @@ -1594,12 +1629,17 @@ GROUP must be one of these symbols: such as U+200C (ZWNJ), U+200E (LRM), but excluding characters that have graphic images, such as U+00AD (SHY). - `variation-selectors': U+FE00..U+FE0F, used for choosing between - glyph variations (e.g. Emoji vs Text - presentation). - `no-font': characters for which no suitable font is found. - For character terminals, characters that cannot - be encoded by `terminal-coding-system'. + `bidi-control': A subset of `format-control', but only characters + that are relevant for bidirectional formatting control, + like U+2069 (PDI) and U+202B (RLE). + `variation-selectors': + Characters in the range U+FE00..U+FE0F, used for + selecting alternate glyph presentations, such as + Emoji vs Text presentation, of the preceding + character(s). + `no-font': For GUI frames, characters for which no suitable + font is found; for text-mode frames, characters + that cannot be encoded by `terminal-coding-system'. METHOD must be one of these symbols: `zero-width': don't display. @@ -1617,36 +1657,12 @@ function (`update-glyphless-char-display'), which updates :version "28.1" :type '(alist :key-type (symbol :tag "Character Group") :value-type (symbol :tag "Display Method")) - :options '((c0-control - (choice (const :tag "Don't display" zero-width) - (const :tag "Display as thin space" thin-space) - (const :tag "Display as empty box" empty-box) - (const :tag "Display acronym" acronym) - (const :tag "Display hex code in a box" hex-code))) - (c1-control - (choice (const :tag "Don't display" zero-width) - (const :tag "Display as thin space" thin-space) - (const :tag "Display as empty box" empty-box) - (const :tag "Display acronym" acronym) - (const :tag "Display hex code in a box" hex-code))) - (format-control - (choice (const :tag "Don't display" zero-width) - (const :tag "Display as thin space" thin-space) - (const :tag "Display as empty box" empty-box) - (const :tag "Display acronym" acronym) - (const :tag "Display hex code in a box" hex-code))) - (variation-selectors - (choice (const :tag "Don't display" zero-width) - (const :tag "Display as thin space" thin-space) - (const :tag "Display as empty box" empty-box) - (const :tag "Display acronym" acronym) - (const :tag "Display hex code in a box" hex-code))) - (no-font - (choice (const :tag "Don't display" zero-width) - (const :tag "Display as thin space" thin-space) - (const :tag "Display as empty box" empty-box) - (const :tag "Display acronym" acronym) - (const :tag "Display hex code in a box" hex-code)))) + :options '((c0-control glyphless-char-display-method) + (c1-control glyphless-char-display-method) + (format-control glyphless-char-display-method) + (bidi-control glyphless-char-display-method) + (variation-selectors glyphless-char-display-method) + (no-font (glyphless-char-display-method :value hex-code))) :set 'update-glyphless-char-display :group 'display) diff --git a/lisp/international/emoji.el b/lisp/international/emoji.el new file mode 100644 index 00000000000..5f8c358caab --- /dev/null +++ b/lisp/international/emoji.el @@ -0,0 +1,647 @@ +;;; emoji.el --- Inserting emojis -*- lexical-binding:t -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; Author: Lars Ingebrigtsen <larsi@gnus.org> +;; Keywords: fun + +;; Package-Requires: ((emacs "28.0") (transient "0.3.7")) +;; Package-Version: 0.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: + +;;; Code: + +(require 'cl-lib) +(require 'cl-extra) +(require 'transient) + +(defgroup emoji nil + "Inserting Emojis." + :version "29.1" + :group 'play) + +(defface emoji-list-header + '((default :weight bold :inherit variable-pitch)) + "Face for emoji list headers." + :version "29.1") + +(defface emoji + '((t :height 2.0)) + "Face used when displaying an emoji." + :version "29.1") + +(defface emoji-with-derivations + '((((background dark)) + (:background "#202020" :inherit emoji)) + (((background light)) + (:background "#e0e0e0" :inherit emoji))) + "Face for emojis that have derivations." + :version "29.1") + +(defvar emoji--labels nil) +(defvar emoji--all-bases nil) +(defvar emoji--derived nil) +(defvar emoji--names (make-hash-table :test #'equal)) +(defvar emoji--done-derived nil) +(defvar emoji--recent (list "😀" "😖")) +(defvar emoji--insert-buffer) + +;;;###autoload +(defun emoji-insert (&optional text) + "Choose and insert an emoji glyph. +If TEXT (interactively, the prefix), use a textual search instead +of a visual interface." + (interactive "*P") + (emoji--init) + (if text + (emoji--choose-emoji) + (unless (fboundp 'emoji--command-Emoji) + (emoji--define-transient)) + (funcall (intern "emoji--command-Emoji")))) + +;;;###autoload +(defun emoji-recent () + "Choose and insert a recently used emoji glyph." + (interactive "*") + (emoji--init) + (unless (fboundp 'emoji--command-Emoji) + (emoji--define-transient)) + (funcall (emoji--define-transient + (cons "Recent" emoji--recent) t))) + +;;;###autoload +(defun emoji-search () + "Choose and insert an emoji glyph by searching for an emoji name." + (interactive "*") + (emoji--init) + (emoji--choose-emoji)) + +;;;###autoload +(defun emoji-list () + "List emojis and insert the one that's selected. +The character will be inserted into the buffer that was selected +when the command was issued." + (interactive "*") + (let ((buf (current-buffer))) + (emoji--init) + (switch-to-buffer (get-buffer-create "*Emoji*")) + ;; Don't regenerate the buffer if it already exists -- this will + ;; leave point where it was the last time it was used. + (when (zerop (buffer-size)) + (let ((inhibit-read-only t)) + (emoji-list-mode) + (setq-local emoji--insert-buffer buf) + (emoji--list-generate nil (cons nil emoji--labels)) + (goto-char (point-min)))))) + +;;;###autoload +(defun emoji-describe (glyph &optional interactive) + "Say what the name of the composed grapheme cluster GLYPH is. +If it's not known, this function returns nil. + +Interactively, it will message what the name of the emoji (or +character) under point is." + (interactive + (list (if (eobp) + (error "No glyph under point") + (let ((comp (find-composition (point) (1+ (point))))) + (if comp + (buffer-substring-no-properties (car comp) (cadr comp)) + (buffer-substring-no-properties (point) (1+ (point)))))) + t)) + (require 'emoji-labels) + (if (not interactive) + ;; Don't return a name for non-compositions when called + ;; non-interactively. + (gethash glyph emoji--names) + ;; Give a name for (pretty much) any glyph, including non-emojis. + (let ((name (emoji--name glyph))) + (if (not name) + (message "No known name for \"%s\"" glyph) + (message "The name of \"%s\" is \"%s\"" glyph name))))) + +(defun emoji--list-generate (name alist) + (let ((width (/ (window-width) 5)) + (mname (pop alist))) + (if (consp (car alist)) + ;; Recurse. + (mapcar (lambda (elem) + (emoji--list-generate (if name + (concat name " > " mname) + mname) + elem)) + alist) + ;; Output this block of emojis. + (insert (propertize + (if (zerop (length name)) + mname + (concat name " > " mname)) + 'face 'emoji-list-header) + "\n\n") + (cl-loop for i from 0 + for glyph in alist + do + (when (and (cl-plusp i) + (zerop (mod i width))) + (insert "\n")) + (insert + (propertize + (emoji--fontify-glyph glyph) + 'emoji-glyph glyph + 'help-echo (emoji--name glyph)))) + (insert "\n\n")))) + +(defun emoji--fontify-glyph (glyph &optional inhibit-derived) + (propertize glyph 'face + (if (and (not inhibit-derived) + (or (null emoji--done-derived) + (not (gethash glyph emoji--done-derived))) + (gethash glyph emoji--derived)) + ;; If this emoji has derivations, use a special face + ;; to tell the user. + 'emoji-with-derivations + ;; Normal emoji. + 'emoji))) + +(defun emoji--name (glyph) + (or (gethash glyph emoji--names) + (get-char-code-property (aref glyph 0) 'name))) + +(defvar-keymap emoji-list-mode-map + "RET" #'emoji-list-select + "<mouse-2>" #'emoji-list-select + "h" #'emoji-list-help + "<follow-link>" 'mouse-face) + +(define-derived-mode emoji-list-mode special-mode "Emoji" + "Mode to display emojis." + :interactive nil + (setq-local truncate-lines t)) + +(defun emoji-list-select (event) + "Select the emoji under point." + (interactive (list last-nonmenu-event) emoji-list-mode) + (mouse-set-point event) + (let ((glyph (get-text-property (point) 'emoji-glyph))) + (unless glyph + (error "No emoji under point")) + (let ((derived (gethash glyph emoji--derived)) + (end-func + (lambda () + (let ((buf emoji--insert-buffer)) + (quit-window) + (if (buffer-live-p buf) + (switch-to-buffer buf) + (error "Buffer disappeared")))))) + (if (not derived) + ;; Glyph without derivations. + (progn + (emoji--add-recent glyph) + (funcall end-func) + (insert glyph)) + ;; Pop up a transient to choose between derivations. + (let ((emoji--done-derived (make-hash-table :test #'equal))) + (setf (gethash glyph emoji--done-derived) t) + (funcall + (emoji--define-transient (cons "Choose Emoji" (cons glyph derived)) + nil end-func))))))) + +(defun emoji-list-help () + "Say what the emoji under point is." + (interactive nil emoji-list-mode) + (let ((glyph (get-text-property (point) 'emoji-glyph))) + (unless glyph + (error "No emoji under point")) + (let ((name (emoji--name glyph))) + (if (not name) + (error "Unknown name") + (message "%s" name))))) + +(defun emoji--init (&optional force inhibit-adjust) + (when (or (not emoji--labels) + force) + (unless force + (ignore-errors (require 'emoji-labels))) + ;; The require should define the variable, but in case the .el + ;; file doesn't exist (yet), parse the file now. + (when (or force + (not emoji--labels)) + (setq emoji--derived (make-hash-table :test #'equal)) + (emoji--parse-emoji-test))) + (when (and (not inhibit-adjust) + (not emoji--all-bases)) + (setq emoji--all-bases (make-hash-table :test #'equal)) + (emoji--adjust-displayable (cons "Emoji" emoji--labels)))) + +(defvar emoji--font nil) + +(defun emoji--adjust-displayable (alist) + "Remove glyphs we don't have fonts for." + (let ((emoji--font nil)) + (emoji--adjust-displayable-1 alist))) + +(defun emoji--adjust-displayable-1 (alist) + (if (consp (caddr alist)) + (dolist (child (cdr alist)) + (emoji--adjust-displayable-1 child)) + (while (cdr alist) + (let ((glyph (cadr alist))) + ;; Store all the emojis for later retrieval by + ;; the search feature. + (when-let ((name (emoji--name glyph))) + (setf (gethash (downcase name) emoji--all-bases) glyph)) + (if (display-graphic-p) + ;; Remove glyphs we don't have in graphical displays. + (if (let ((char (elt glyph 0))) + (if emoji--font + (font-has-char-p emoji--font char) + (when-let ((font (car (internal-char-font nil char)))) + (setq emoji--font font)))) + (setq alist (cdr alist)) + ;; Remove the element. + (setcdr alist (cddr alist))) + ;; We don't have font info on non-graphical displays. + (if (let ((char (elt glyph 0))) + ;; FIXME. Some grapheme clusters display more or less + ;; correctly in the terminal, but we don't really know + ;; which ones. None of these display totally + ;; correctly, though, so should they be filtered out? + (char-displayable-p char)) + (setq alist (cdr alist)) + ;; Remove the element. + (setcdr alist (cddr alist)))))))) + +(defun emoji--parse-emoji-test () + (setq emoji--labels nil) + (with-temp-buffer + (insert-file-contents (expand-file-name "../admin/unidata/emoji-test.txt" + data-directory)) + (unless (re-search-forward "^# +group:" nil t) + (error "Can't find start of data")) + (beginning-of-line) + (setq emoji--names (make-hash-table :test #'equal)) + (let ((derivations (make-hash-table :test #'equal)) + (case-fold-search t) + group subgroup) + (while (not (eobp)) + (cond + ((looking-at "# +group: \\(.*\\)") + (setq group (match-string 1) + subgroup nil)) + ((looking-at "# +subgroup: \\(.*\\)") + (setq subgroup (match-string 1))) + ((looking-at + "\\([[:xdigit:] \t]+\\); *\\([^ \t]+\\)[ \t]+#.*?E[.0-9]+ +\\(.*\\)") + (let* ((codes (match-string 1)) + (qualification (match-string 2)) + (name (match-string 3)) + (base (emoji--base-name name derivations)) + (glyph (mapconcat + (lambda (code) + (string (string-to-number code 16))) + (split-string codes)))) + ;; Special-case flags. + (when (equal base "flag") + (setq base name)) + ;; Register all glyphs to that we can look up their names + ;; later. + (setf (gethash glyph emoji--names) name) + ;; For the interface, we only care about the fully qualified + ;; emojis. + (when (equal qualification "fully-qualified") + (when (equal base name) + (emoji--add-to-group group subgroup glyph)) + ;; Create mapping from base glyph name to name of + ;; derived glyphs. + (setf (gethash base derivations) + (nconc (gethash base derivations) (list glyph))))))) + (forward-line 1)) + ;; Finally create the mapping from the base glyphs to derived ones. + (setq emoji--derived (make-hash-table :test #'equal)) + (maphash (lambda (_k v) + (setf (gethash (car v) emoji--derived) + (cdr v))) + derivations)))) + +(defun emoji--add-to-group (group subgroup glyph) + ;; "People & Body" is very large; split it up. + (cond + ((equal group "People & Body") + (if (or (string-match "\\`person" subgroup) + (equal subgroup "family")) + (emoji--add-glyph glyph "People" + (if (equal subgroup "family") + (list subgroup) + ;; Avoid "Person person". + (cdr (emoji--split-subgroup subgroup)))) + (emoji--add-glyph glyph "Body" (emoji--split-subgroup subgroup)))) + ;; "Smileys & Emotion" also seems sub-optimal. + ((equal group "Smileys & Emotion") + (if (equal subgroup "emotion") + (emoji--add-glyph glyph "Emotion" nil) + (let ((subs (emoji--split-subgroup subgroup))) + ;; Remove one level of menus in the face case. + (when (equal (car subs) "face") + (pop subs)) + (emoji--add-glyph glyph "Smileys" subs)))) + ;; Don't modify the rest. + (t + (emoji--add-glyph glyph group (emoji--split-subgroup subgroup))))) + +(defun emoji--generate-file (&optional file) + "Generate an .el file with emoji mapping data and write it to FILE." + ;; Running from Makefile. + (unless file + (setq file (pop command-line-args-left))) + (emoji--init t t) + ;; Weed out the elements that are empty. + (let ((glyphs nil)) + (maphash (lambda (k v) + (unless v + (push k glyphs))) + emoji--derived) + (dolist (glyph glyphs) + (remhash glyph emoji--derived))) + (with-temp-buffer + (insert ";; Generated file -- do not edit. -*- lexical-binding:t -*- +;; Copyright © 1991-2021 Unicode, Inc. +;; Generated from Unicode data files by emoji.el. +;; The source for this file is found in the admin/unidata/emoji-test.txt +;; file in the Emacs sources. The Unicode data files are used under the +;; Unicode Terms of Use, as contained in the file copyright.html in that +;; same directory.\n\n") + (dolist (var '(emoji--labels emoji--derived emoji--names)) + (insert (format "(defconst %s '" var)) + (pp (symbol-value var) (current-buffer)) + (insert (format "\n) ;; End %s\n\n" var))) + (insert ";; Local" " Variables: +;; coding: utf-8 +;; version-control: never +;; no-byte-" + ;; Obfuscate to not inhibit compilation of this file, too. + "compile: t +;; no-update-autoloads: t +;; End: + +(provide 'emoji-labels) + +;;; emoji-labels.el ends here\n") + (write-region (point-min) (point-max) file))) + +(defun emoji--base-name (name derivations) + (let* ((base (replace-regexp-in-string ":.*" "" name)) + (non-binary (replace-regexp-in-string "\\`\\(man\\|woman\\) " "" + base))) + ;; If we have (for instance) "person golfing", and we're adding + ;; "man golfing", make the latter a derivation of the former. + (if (or (gethash (concat "person " non-binary) derivations) + (gethash non-binary derivations)) + non-binary + base))) + +(defun emoji--split-subgroup (subgroup) + (let ((prefixes '("face" "hand" "person" "animal" "plant" + "food" "place"))) + (cond + ((string-match (concat "\\`" (regexp-opt prefixes) "-") subgroup) + ;; Split these subgroups into hierarchies. + (list (substring subgroup 0 (1- (match-end 0))) + (substring subgroup (match-end 0)))) + ((equal subgroup "person") + (list "person" "age")) + (t + (list subgroup))))) + +(defun emoji--add-glyph (glyph main subs) + (let (parent elem) + ;; Useless category. + (unless (member main '("Component")) + (unless (setq parent (assoc main emoji--labels)) + (setq emoji--labels (append emoji--labels + (list (setq parent (list main)))))) + (setq elem parent) + (while subs + (unless (setq elem (assoc (car subs) parent)) + (nconc parent (list (setq elem (list (car subs)))))) + (pop subs) + (setq parent elem)) + (nconc elem (list glyph))))) + +(defun emoji--define-transient (&optional alist inhibit-derived + end-function) + (unless alist + (setq alist (cons "Emoji" emoji--labels))) + (let* ((mname (pop alist)) + (name (intern (format "emoji--command-%s" mname))) + (emoji--done-derived (or emoji--done-derived + (make-hash-table :test #'equal))) + (has-subs (consp (cadr alist))) + (layout + (if has-subs + ;; Define sub-maps. + (cl-loop for entry in + (emoji--compute-prefix + (if (equal mname "Emoji") + (cons (list "Recent") alist) + alist)) + collect (list + (car entry) + (emoji--compute-name (cdr entry)) + (if (equal (cadr entry) "Recent") + (emoji--recent-transient end-function) + (emoji--define-transient + (cons (concat mname " > " (cadr entry)) + (cddr entry)))))) + ;; Insert an emoji. + (cl-loop for glyph in alist + for i in (append (number-sequence ?a ?z) + (number-sequence ?A ?Z) + (number-sequence ?0 ?9) + (number-sequence ?! ?/)) + collect (let ((this-glyph glyph)) + (list + (string i) + (emoji--fontify-glyph + glyph inhibit-derived) + (let ((derived + (and (not inhibit-derived) + (not (gethash glyph + emoji--done-derived)) + (gethash glyph emoji--derived)))) + (if derived + ;; We have a derived glyph, so add + ;; another level. + (progn + (setf (gethash glyph + emoji--done-derived) + t) + (emoji--define-transient + (cons (concat mname " " glyph) + (cons glyph derived)) + t end-function)) + ;; Insert the emoji. + (lambda () + (interactive) + ;; Allow switching to the correct + ;; buffer. + (when end-function + (funcall end-function)) + (emoji--add-recent this-glyph) + (insert this-glyph))))))))) + (args (apply #'vector mname + (emoji--columnize layout + (if has-subs 2 8))))) + ;; There's probably a better way to do this... + (setf (symbol-function name) + (lambda () + (interactive) + (transient-setup name))) + (pcase-let ((`(,class ,slots ,suffixes ,docstr ,_body) + (transient--expand-define-args (list args)))) + (put name 'interactive-only t) + (put name 'function-documentation docstr) + (put name 'transient--prefix + (apply (or class 'transient-prefix) :command name + (cons :variable-pitch (cons t slots)))) + (put name 'transient--layout + (cl-mapcan (lambda (s) (transient--parse-child name s)) + suffixes))) + name)) + +(defun emoji--recent-transient (end-function) + "Create a function to display a dynamically generated menu." + (lambda () + (interactive) + (funcall (emoji--define-transient + (cons "Recent" emoji--recent) t end-function)))) + +(defun emoji--add-recent (glyph) + "Add GLYPH to the set of recently used emojis." + (setq emoji--recent (delete glyph emoji--recent)) + (push glyph emoji--recent) + ;; Shorten the list. + (when-let ((tail (nthcdr 30 emoji--recent))) + (setcdr tail nil))) + +(defun emoji--columnize (list columns) + "Split LIST into COLUMN columns." + (cl-loop with length = (ceiling (/ (float (length list)) columns)) + for i upto columns + for part on list by (lambda (l) (nthcdr length l)) + collect (apply #'vector (seq-take part length)))) + +(defun emoji--compute-prefix (alist) + "Compute characters to use for entries in ALIST. +We prefer the earliest unique letter." + (cl-loop with taken = (make-hash-table) + for entry in alist + for name = (car entry) + collect (cons (cl-loop for char across (concat + (downcase name) + (upcase name)) + while (gethash char taken) + finally (progn + (setf (gethash char taken) t) + (cl-return (string char)))) + entry))) + +(defun emoji--compute-name (entry) + "Add example emojis to the name." + (let* ((name (concat (car entry) " ")) + (children (emoji--flatten entry)) + (length (length name)) + (max 30)) + (cl-loop for i from 0 upto 20 + ;; Choose from all the children. + while (< length max) + do (cl-loop for child in children + for glyph = (elt child i) + while (< length max) + when glyph + do (setq name (concat name glyph) + length (+ length 2)))) + (if (= (length name) max) + ;; Make an ellipsis signal that we've not exhausted the + ;; possibilities. + (concat name "…") + name))) + +(defun emoji--flatten (alist) + (pop alist) + (if (consp (cadr alist)) + (cl-loop for child in alist + append (emoji--flatten child)) + (list alist))) + +(defun emoji--split-long-lists (alist) + (let ((whole alist)) + (pop alist) + (if (consp (cadr alist)) + ;; Descend. + (cl-loop for child in alist + do (emoji--split-long-lists child)) + ;; We have a list. + (when (length> alist 77) + (setcdr whole + (cl-loop for prefix from ?a + for bit on alist by (lambda (l) (nthcdr 77 l)) + collect (cons (concat (string prefix) "-group") + (seq-take bit 77)))))))) + +(defun emoji--choose-emoji () + ;; Use the list of names. + (let ((name + (completing-read + "Insert emoji: " + (lambda (string pred action) + (if (eq action 'metadata) + (list 'metadata + (cons + 'affixation-function + ;; Add the glyphs to the start of the displayed + ;; strings when TAB-ing. + (lambda (strings) + (mapcar + (lambda (name) + (list name + (concat + (or (gethash name emoji--all-bases) " ") + "\t") + "")) + strings)))) + (complete-with-action action emoji--all-bases string pred))) + nil t))) + (when (cl-plusp (length name)) + (let* ((glyph (gethash name emoji--all-bases)) + (derived (gethash glyph emoji--derived))) + (if (not derived) + ;; Simple glyph with no derivations. + (progn + (emoji--add-recent glyph) + (insert glyph)) + ;; Choose a derived version. + (let ((emoji--done-derived (make-hash-table :test #'equal))) + (setf (gethash glyph emoji--done-derived) t) + (funcall + (emoji--define-transient + (cons "Choose Emoji" (cons glyph derived)))))))))) + +(provide 'emoji) + +;;; emoji.el ends here diff --git a/lisp/international/fontset.el b/lisp/international/fontset.el index fcd22e09d29..7c3a7cd1a9e 100644 --- a/lisp/international/fontset.el +++ b/lisp/international/fontset.el @@ -816,11 +816,16 @@ (#x1D7EC #x1D7F5 mathematical-sans-serif-bold) (#x1D7F6 #x1D7FF mathematical-monospace))) (let ((slot (assq (nth 2 math-subgroup) script-representative-chars))) + ;; Add both ends of each subgroup to help filter out some + ;; incomplete fonts, e.g. those that cover MATHEMATICAL SCRIPT + ;; CAPITAL glyphs but not MATHEMATICAL SCRIPT SMALL ones. (if slot - (if (vectorp (cdr slot)) - (setcdr slot (vconcat (cdr slot) (vector (car math-subgroup)))) - (setcdr slot (vector (cadr slot) (car math-subgroup)))) - (setq slot (list (nth 2 math-subgroup) (car math-subgroup))) + (setcdr slot (append (list (nth 0 math-subgroup) + (nth 1 math-subgroup)) + (cdr slot))) + (setq slot (list (nth 2 math-subgroup) + (nth 0 math-subgroup) + (nth 1 math-subgroup))) (nconc script-representative-chars (list slot)))) (set-fontset-font "fontset-default" diff --git a/lisp/international/iso-transl.el b/lisp/international/iso-transl.el index 2c7da2b7cdf..aea12179170 100644 --- a/lisp/international/iso-transl.el +++ b/lisp/international/iso-transl.el @@ -86,33 +86,46 @@ ("\"y" . [?ÿ]) ("''" . [?´]) ("'A" . [?Á]) + ("'C" . [?Ć]) ("'E" . [?É]) ("'I" . [?Í]) + ("'N" . [?Ń]) ("'O" . [?Ó]) + ("'S" . [?Ś]) ("'U" . [?Ú]) ("'Y" . [?Ý]) + ("'Z" . [?Ź]) ("'a" . [?á]) + ("'c" . [?ć]) ("'e" . [?é]) ("'i" . [?í]) + ("'n" . [?ń]) ("'o" . [?ó]) + ("'s" . [?ś]) ("'u" . [?ú]) ("'y" . [?ý]) + ("'z" . [?ź]) ("*$" . [?¤]) ("$" . [?¤]) ("*+" . [?±]) ("+" . [?±]) (",," . [?¸]) + (",A" . [?Ą]) (",C" . [?Ç]) + (",a" . [?ą]) (",c" . [?ç]) ("*-" . [?]) ("-" . [?]) ("*." . [?·]) - ("." . [?·]) + (".." . [?·]) + (".z" . [?ż]) ("//" . [?÷]) ("/A" . [?Å]) + ("/L" . [?Ł]) ("/E" . [?Æ]) ("/O" . [?Ø]) ("/a" . [?å]) + ("/l" . [?ł]) ("/e" . [?æ]) ("/o" . [?ø]) ("1/2" . [?½]) @@ -294,6 +307,14 @@ sequence VECTOR. (VECTOR is normally one character long.)") (setq alist (cdr alist)))) (defun iso-transl-set-language (lang) + "Set shorter key bindings for some characters relevant for LANG. +This affects the `C-x 8' prefix. + +Note that only a few languages are supported, and for more +rigorous support it is recommended to use an input method +instead. Also note that many of these characters can be input +with the regular `C-x 8' map without having to specify a language +here." (interactive (list (let ((completion-ignore-case t)) (completing-read "Set which language? " iso-transl-language-alist nil t)))) diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el index a0a6557c95c..b84d9e0823d 100644 --- a/lisp/international/mule-cmds.el +++ b/lisp/international/mule-cmds.el @@ -88,7 +88,7 @@ (bindings--define-key map [separator-3] menu-bar-separator) (bindings--define-key map [set-terminal-coding-system] '(menu-item "For Terminal" set-terminal-coding-system - :enable (null (memq initial-window-system '(x w32 ns))) + :enable (null (memq initial-window-system '(x w32 ns haiku))) :help "How to encode terminal output")) (bindings--define-key map [set-keyboard-coding-system] '(menu-item "For Keyboard" set-keyboard-coding-system @@ -1638,30 +1638,31 @@ If `default-transient-input-method' was not yet defined, prompt for it." (interactive (list (read-input-method-name (format-prompt "Describe input method" current-input-method)))) - (if (and input-method (symbolp input-method)) - (setq input-method (symbol-name input-method))) - (help-setup-xref (list #'describe-input-method - (or input-method current-input-method)) - (called-interactively-p 'interactive)) - - (if (null input-method) - (describe-current-input-method) - (let ((current current-input-method)) - (condition-case nil - (progn - (save-excursion - (activate-input-method input-method) - (describe-current-input-method)) - (activate-input-method current)) - (error - (activate-input-method current) - (help-setup-xref (list #'describe-input-method input-method) - (called-interactively-p 'interactive)) - (with-output-to-temp-buffer (help-buffer) - (let ((elt (assoc input-method input-method-alist))) - (princ (format-message - "Input method: %s (`%s' in mode line) for %s\n %s\n" - input-method (nth 3 elt) (nth 1 elt) (nth 4 elt)))))))))) + (let ((help-buffer-under-preparation t)) + (if (and input-method (symbolp input-method)) + (setq input-method (symbol-name input-method))) + (help-setup-xref (list #'describe-input-method + (or input-method current-input-method)) + (called-interactively-p 'interactive)) + + (if (null input-method) + (describe-current-input-method) + (let ((current current-input-method)) + (condition-case nil + (progn + (save-excursion + (activate-input-method input-method) + (describe-current-input-method)) + (activate-input-method current)) + (error + (activate-input-method current) + (help-setup-xref (list #'describe-input-method input-method) + (called-interactively-p 'interactive)) + (with-output-to-temp-buffer (help-buffer) + (let ((elt (assoc input-method input-method-alist))) + (princ (format-message + "Input method: %s (`%s' in mode line) for %s\n %s\n" + input-method (nth 3 elt) (nth 1 elt) (nth 4 elt))))))))))) (defun describe-current-input-method () "Describe the input method currently in use. @@ -2162,89 +2163,90 @@ See `set-language-info-alist' for use in programs." (list (read-language-name 'documentation (format-prompt "Describe language environment" current-language-environment)))) - (if (null language-name) - (setq language-name current-language-environment)) - (if (or (null language-name) - (null (get-language-info language-name 'documentation))) - (error "No documentation for the specified language")) - (if (symbolp language-name) - (setq language-name (symbol-name language-name))) - (dolist (feature (get-language-info language-name 'features)) - (require feature)) - (let ((doc (get-language-info language-name 'documentation))) - (help-setup-xref (list #'describe-language-environment language-name) - (called-interactively-p 'interactive)) - (with-output-to-temp-buffer (help-buffer) - (with-current-buffer standard-output - (insert language-name " language environment\n\n") - (if (stringp doc) - (insert (substitute-command-keys doc) "\n\n")) - (condition-case nil - (let ((str (eval (get-language-info language-name 'sample-text)))) - (if (stringp str) - (insert "Sample text:\n " - (string-replace "\n" "\n " str) - "\n\n"))) - (error nil)) - (let ((input-method (get-language-info language-name 'input-method)) - (l (copy-sequence input-method-alist)) - (first t)) - (when (and input-method - (setq input-method (assoc input-method l))) - (insert "Input methods (default " (car input-method) ")\n") - (setq l (cons input-method (delete input-method l)) - first nil)) - (dolist (elt l) - (when (or (eq input-method elt) - (eq t (compare-strings language-name nil nil - (nth 1 elt) nil nil t))) - (when first - (insert "Input methods:\n") - (setq first nil)) - (insert " " (car elt)) - (search-backward (car elt)) - (help-xref-button 0 'help-input-method (car elt)) - (goto-char (point-max)) - (insert " (\"" - (if (stringp (nth 3 elt)) (nth 3 elt) (car (nth 3 elt))) - "\" in mode line)\n"))) - (or first - (insert "\n"))) - (insert "Character sets:\n") - (let ((l (get-language-info language-name 'charset))) - (if (null l) - (insert " nothing specific to " language-name "\n") - (while l - (insert " " (symbol-name (car l))) - (search-backward (symbol-name (car l))) - (help-xref-button 0 'help-character-set (car l)) - (goto-char (point-max)) - (insert ": " (charset-description (car l)) "\n") - (setq l (cdr l))))) - (insert "\n") - (insert "Coding systems:\n") - (let ((l (get-language-info language-name 'coding-system))) - (if (null l) - (insert " nothing specific to " language-name "\n") - (while l - (insert " " (symbol-name (car l))) - (search-backward (symbol-name (car l))) - (help-xref-button 0 'help-coding-system (car l)) - (goto-char (point-max)) - (insert (substitute-command-keys " (`") - (coding-system-mnemonic (car l)) - (substitute-command-keys "' in mode line):\n\t") - (substitute-command-keys - (coding-system-doc-string (car l))) - "\n") - (let ((aliases (coding-system-aliases (car l)))) - (when aliases - (insert "\t(alias:") - (while aliases - (insert " " (symbol-name (car aliases))) - (setq aliases (cdr aliases))) - (insert ")\n"))) - (setq l (cdr l))))))))) + (let ((help-buffer-under-preparation t)) + (if (null language-name) + (setq language-name current-language-environment)) + (if (or (null language-name) + (null (get-language-info language-name 'documentation))) + (error "No documentation for the specified language")) + (if (symbolp language-name) + (setq language-name (symbol-name language-name))) + (dolist (feature (get-language-info language-name 'features)) + (require feature)) + (let ((doc (get-language-info language-name 'documentation))) + (help-setup-xref (list #'describe-language-environment language-name) + (called-interactively-p 'interactive)) + (with-output-to-temp-buffer (help-buffer) + (with-current-buffer standard-output + (insert language-name " language environment\n\n") + (if (stringp doc) + (insert (substitute-command-keys doc) "\n\n")) + (condition-case nil + (let ((str (eval (get-language-info language-name 'sample-text)))) + (if (stringp str) + (insert "Sample text:\n " + (string-replace "\n" "\n " str) + "\n\n"))) + (error nil)) + (let ((input-method (get-language-info language-name 'input-method)) + (l (copy-sequence input-method-alist)) + (first t)) + (when (and input-method + (setq input-method (assoc input-method l))) + (insert "Input methods (default " (car input-method) ")\n") + (setq l (cons input-method (delete input-method l)) + first nil)) + (dolist (elt l) + (when (or (eq input-method elt) + (eq t (compare-strings language-name nil nil + (nth 1 elt) nil nil t))) + (when first + (insert "Input methods:\n") + (setq first nil)) + (insert " " (car elt)) + (search-backward (car elt)) + (help-xref-button 0 'help-input-method (car elt)) + (goto-char (point-max)) + (insert " (\"" + (if (stringp (nth 3 elt)) (nth 3 elt) (car (nth 3 elt))) + "\" in mode line)\n"))) + (or first + (insert "\n"))) + (insert "Character sets:\n") + (let ((l (get-language-info language-name 'charset))) + (if (null l) + (insert " nothing specific to " language-name "\n") + (while l + (insert " " (symbol-name (car l))) + (search-backward (symbol-name (car l))) + (help-xref-button 0 'help-character-set (car l)) + (goto-char (point-max)) + (insert ": " (charset-description (car l)) "\n") + (setq l (cdr l))))) + (insert "\n") + (insert "Coding systems:\n") + (let ((l (get-language-info language-name 'coding-system))) + (if (null l) + (insert " nothing specific to " language-name "\n") + (while l + (insert " " (symbol-name (car l))) + (search-backward (symbol-name (car l))) + (help-xref-button 0 'help-coding-system (car l)) + (goto-char (point-max)) + (insert (substitute-command-keys " (`") + (coding-system-mnemonic (car l)) + (substitute-command-keys "' in mode line):\n\t") + (substitute-command-keys + (coding-system-doc-string (car l))) + "\n") + (let ((aliases (coding-system-aliases (car l)))) + (when aliases + (insert "\t(alias:") + (while aliases + (insert " " (symbol-name (car aliases))) + (setq aliases (cdr aliases))) + (insert ")\n"))) + (setq l (cdr l)))))))))) ;;; Locales. @@ -2665,6 +2667,20 @@ For example, translate \"swedish\" into \"sv_SE.ISO8859-1\"." locale)) locale)) +(defvar current-locale-environment nil + "The currently set locale environment.") + +(defmacro with-locale-environment (locale-name &rest body) + "Execute BODY with the locale set to LOCALE-NAME." + (declare (indent 1) (debug (sexp def-body))) + (let ((current (gensym))) + `(let ((,current current-locale-environment)) + (unwind-protect + (progn + (set-locale-environment ,locale-name) + ,@body) + (set-locale-environment ,current))))) + (defun set-locale-environment (&optional locale-name frame) "Set up multilingual environment for using LOCALE-NAME. This sets the language environment, the coding system priority, @@ -2690,6 +2706,10 @@ If FRAME is non-nil, only set the keyboard coding system and the terminal coding system for the terminal of that frame, and don't touch session-global parameters like the language environment. +This function sets the `current-locale-environment' variable. To +change the locale temporarily, `with-locale-environment' can be +used. + See also `locale-charset-language-names', `locale-language-names', `locale-preferred-coding-systems' and `locale-coding-system'." (interactive (list (completing-read "Set environment for locale: " @@ -2723,6 +2743,7 @@ See also `locale-charset-language-names', `locale-language-names', (when locale (setq locale (locale-translate locale)) + (setq current-locale-environment locale) ;; Leave the system locales alone if the caller did not specify ;; an explicit locale name, as their defaults are set from @@ -2927,6 +2948,7 @@ Optional 3rd argument DOCSTRING is a documentation string of the property. See also the documentation of `get-char-code-property' and `put-char-code-property'." + (declare (indent defun)) (or (symbolp name) (error "Not a symbol: %s" name)) (if (char-table-p table) @@ -3055,22 +3077,6 @@ on encoding." 0)) (substring enc2 i0 i2))))) -;; Backwards compatibility. These might be better with :init-value t, -;; but that breaks loadup. -(define-minor-mode unify-8859-on-encoding-mode - "Exists only for backwards compatibility." - :group 'mule - :global t) -;; Doc said "obsolete" in 23.1, this statement only added in 24.1. -(make-obsolete 'unify-8859-on-encoding-mode "don't use it." "23.1") - -(define-minor-mode unify-8859-on-decoding-mode - "Exists only for backwards compatibility." - :group 'mule - :global t) -;; Doc said "obsolete" in 23.1, this statement only added in 24.1. -(make-obsolete 'unify-8859-on-decoding-mode "don't use it." "23.1") - (defvar ucs-names nil "Hash table of cached CHAR-NAME keys to CHAR-CODE values.") @@ -3238,5 +3244,116 @@ as names, not numbers." (define-obsolete-function-alias 'ucs-insert 'insert-char "24.3") (define-key ctl-x-map "8\r" 'insert-char) +(define-key ctl-x-map "8e" + (define-keymap + "e" #'emoji-insert + "i" #'emoji-insert + "s" #'emoji-search + "d" #'emoji-describe + "r" #'emoji-recent + "l" #'emoji-list)) + +(defface confusingly-reordered + '((((supports :underline (:style wave))) + :underline (:style wave :color "Red1")) + (t + :inherit warning)) + "Face for highlighting text that was bidi-reordered in confusing ways." + :version "29.1") + +(defvar reorder-starters "[\u202A\u202B\u202D\u202E\u2066-\u2068]+" + "Regular expression for characters that start forced-reordered text.") +(defvar reorder-enders "[\u202C\u2069]+\\|\n" + "Regular expression for characters that end forced-reordered text.") + +(autoload 'text-property-search-forward "text-property-search") +(autoload 'prop-match-beginning "text-property-search") +(autoload 'prop-match-end "text-property-search") + +(defun highlight-confusing-reorderings (beg end &optional remove) + "Highlight text in region that might be bidi-reordered in suspicious ways. +This command find and highlights segments of buffer text that could have +been reordered on display by using directional control characters, such +as RLO and LRI, in a way that their display is deliberately meant to +confuse the reader. These techniques can be used for obfuscating +malicious source code. The suspicious stretches of buffer text are +highlighted using the `confusingly-reordered' face. + +If the region is active, check the text inside the region. Otherwise +check the entire buffer. When called from Lisp, pass BEG and END to +specify the portion of the buffer to check. + +Optional argument REMOVE, if non-nil (interactively, prefix argument), +means remove the highlighting from the region between BEG and END, +or the active region if that is set." + (interactive + (if (use-region-p) + (list (region-beginning) (region-end) current-prefix-arg) + (list (point-min) (point-max) current-prefix-arg))) + (save-excursion + (if remove + (let (prop-match) + (goto-char beg) + (while (and + (setq prop-match + (text-property-search-forward 'font-lock-face + 'confusingly-reordered t)) + (< (prop-match-beginning prop-match) end)) + (with-silent-modifications + (remove-list-of-text-properties (prop-match-beginning prop-match) + (prop-match-end prop-match) + '(font-lock-face face mouse-face + help-echo))))) + (let ((count 0) + next) + (goto-char beg) + (while (setq next + (bidi-find-overridden-directionality + (point) end nil + (current-bidi-paragraph-direction))) + (goto-char next) + ;; We detect the problematic parts by watching directional + ;; properties of strong L2R and R2L characters. But + ;; malicious reordering in source buffers can, and usuually + ;; does, include syntactically-important punctuation + ;; characters. Those have "weak" directionality, so we + ;; cannot easily detect when they are affected in malicious + ;; ways. Therefore, once we find a strong directional + ;; character whose directionality was tweaked, we highlight + ;; the text around it, between the first bidi control + ;; character we find before it that starts an + ;; override/embedding/isolate, and the first control after + ;; it that ends these. This could sometimes highlight only + ;; part of the affected text. An alternative would be to + ;; find the first "starter" following BOL and the last + ;; "ender" before EOL, and highlight everything in between + ;; them -- this could sometimes highlight too much. + (let ((start + (save-excursion + (re-search-backward reorder-starters nil t))) + (finish + (save-excursion + (let ((fin (re-search-forward reorder-enders nil t))) + (if fin (1- fin) + (point-max)))))) + (with-silent-modifications + (add-text-properties start finish + '(font-lock-face + confusingly-reordered + face confusingly-reordered + mouse-face highlight + help-echo "\ +This text is reordered on display in a way that could change its semantics; +use \\[forward-char] and \\[backward-char] to see the actual order of characters."))) + (goto-char finish) + (setq count (1+ count)))) + (message + (if (> count 0) + (ngettext + "Highlighted %d confusingly-reordered text string" + "Highlighted %d confusingly-reordered text strings" + count) + "No confusingly-reordered text strings were found") + count))))) ;;; mule-cmds.el ends here diff --git a/lisp/international/mule-conf.el b/lisp/international/mule-conf.el index 9a68fce2e81..ec027e9a932 100644 --- a/lisp/international/mule-conf.el +++ b/lisp/international/mule-conf.el @@ -148,6 +148,7 @@ (defmacro define-iso-single-byte-charset (symbol iso-symbol name nickname iso-ir iso-final emacs-mule-id map) + (declare (indent defun)) `(progn (define-charset ,symbol ,name diff --git a/lisp/international/mule-diag.el b/lisp/international/mule-diag.el index 862c577bd5d..efb9296c110 100644 --- a/lisp/international/mule-diag.el +++ b/lisp/international/mule-diag.el @@ -299,65 +299,66 @@ meanings of these arguments." (defun describe-character-set (charset) "Display information about built-in character set CHARSET." (interactive (list (read-charset "Charset: "))) - (or (charsetp charset) - (error "Invalid charset: %S" charset)) - (help-setup-xref (list #'describe-character-set charset) - (called-interactively-p 'interactive)) - (with-output-to-temp-buffer (help-buffer) - (with-current-buffer standard-output - (insert "Character set: " (symbol-name charset)) - (let ((name (get-charset-property charset :name))) - (if (not (eq name charset)) - (insert " (alias of " (symbol-name name) ?\)))) - (insert "\n\n" (charset-description charset) "\n\n") - (insert "Number of contained characters: ") - (dotimes (i (charset-dimension charset)) - (unless (= i 0) - (insert ?x)) - (insert (format "%d" (charset-chars charset (1+ i))))) - (insert ?\n) - (let ((char (charset-iso-final-char charset))) - (when (> char 0) - (insert "Final char of ISO2022 designation sequence: ") - (insert (format-message "`%c'\n" char)))) - (let (aliases) - (dolist (c charset-list) - (if (and (not (eq c charset)) - (eq charset (get-charset-property c :name))) - (push c aliases))) - (if aliases - (insert "Aliases: " (mapconcat #'symbol-name aliases ", ") ?\n))) - - (dolist (elt `((:ascii-compatible-p "ASCII compatible." nil) - (:map "Map file: " identity) - (:unify-map "Unification map file: " identity) - (:invalid-code - nil - ,(lambda (c) - (format "Invalid character: %c (code %d)" c c))) - (:emacs-mule-id "Id in emacs-mule coding system: " - number-to-string) - (:parents "Parents: " - (lambda (parents) - (mapconcat ,(lambda (elt) - (format "%s" elt)) - parents - ", "))) - (:code-space "Code space: " ,(lambda (c) - (format "%s" c))) - (:code-offset "Code offset: " number-to-string) - (:iso-revision-number "ISO revision number: " - number-to-string) - (:supplementary-p - "Used only as a parent or a subset of some other charset, + (let ((help-buffer-under-preparation t)) + (or (charsetp charset) + (error "Invalid charset: %S" charset)) + (help-setup-xref (list #'describe-character-set charset) + (called-interactively-p 'interactive)) + (with-output-to-temp-buffer (help-buffer) + (with-current-buffer standard-output + (insert "Character set: " (symbol-name charset)) + (let ((name (get-charset-property charset :name))) + (if (not (eq name charset)) + (insert " (alias of " (symbol-name name) ?\)))) + (insert "\n\n" (charset-description charset) "\n\n") + (insert "Number of contained characters: ") + (dotimes (i (charset-dimension charset)) + (unless (= i 0) + (insert ?x)) + (insert (format "%d" (charset-chars charset (1+ i))))) + (insert ?\n) + (let ((char (charset-iso-final-char charset))) + (when (> char 0) + (insert "Final char of ISO2022 designation sequence: ") + (insert (format-message "`%c'\n" char)))) + (let (aliases) + (dolist (c charset-list) + (if (and (not (eq c charset)) + (eq charset (get-charset-property c :name))) + (push c aliases))) + (if aliases + (insert "Aliases: " (mapconcat #'symbol-name aliases ", ") ?\n))) + + (dolist (elt `((:ascii-compatible-p "ASCII compatible." nil) + (:map "Map file: " identity) + (:unify-map "Unification map file: " identity) + (:invalid-code + nil + ,(lambda (c) + (format "Invalid character: %c (code %d)" c c))) + (:emacs-mule-id "Id in emacs-mule coding system: " + number-to-string) + (:parents "Parents: " + (lambda (parents) + (mapconcat ,(lambda (elt) + (format "%s" elt)) + parents + ", "))) + (:code-space "Code space: " ,(lambda (c) + (format "%s" c))) + (:code-offset "Code offset: " number-to-string) + (:iso-revision-number "ISO revision number: " + number-to-string) + (:supplementary-p + "Used only as a parent or a subset of some other charset, or provided just for backward compatibility." nil))) - (let ((val (get-charset-property charset (car elt)))) - (when val - (if (cadr elt) (insert (cadr elt))) - (if (nth 2 elt) - (let ((print-length 10) (print-level 2)) - (princ (funcall (nth 2 elt) val) (current-buffer)))) - (insert ?\n))))))) + (let ((val (get-charset-property charset (car elt)))) + (when val + (if (cadr elt) (insert (cadr elt))) + (if (nth 2 elt) + (let ((print-length 10) (print-level 2)) + (princ (funcall (nth 2 elt) val) (current-buffer)))) + (insert ?\n)))))))) ;;; CODING-SYSTEM @@ -406,89 +407,90 @@ or provided just for backward compatibility." nil))) (defun describe-coding-system (coding-system) "Display information about CODING-SYSTEM." (interactive "zDescribe coding system (default current choices): ") - (if (null coding-system) - (describe-current-coding-system) - (help-setup-xref (list #'describe-coding-system coding-system) - (called-interactively-p 'interactive)) - (with-output-to-temp-buffer (help-buffer) - (print-coding-system-briefly coding-system 'doc-string) - (let ((type (coding-system-type coding-system)) - ;; Fixme: use this - ;; (extra-spec (coding-system-plist coding-system)) - ) - (princ "Type: ") - (princ type) - (cond ((eq type 'undecided) - (princ " (do automatic conversion)")) - ((eq type 'utf-8) - (princ " (UTF-8: Emacs internal multibyte form)")) - ((eq type 'utf-16) - ;; (princ " (UTF-16)") - ) - ((eq type 'shift-jis) - (princ " (Shift-JIS, MS-KANJI)")) - ((eq type 'iso-2022) - (princ " (variant of ISO-2022)\n") - (princ "Initial designations:\n") - (print-designation (coding-system-get coding-system - :designation)) - - (when (coding-system-get coding-system :flags) - (princ "Other specifications: \n ") - (apply #'print-list - (coding-system-get coding-system :flags)))) - ((eq type 'charset) - (princ " (charset)")) - ((eq type 'ccl) - (princ " (do conversion by CCL program)")) - ((eq type 'raw-text) - (princ " (text with random binary characters)")) - ((eq type 'emacs-mule) - (princ " (Emacs 21 internal encoding)")) - ((eq type 'big5)) - (t (princ ": invalid coding-system."))) - (princ "\nEOL type: ") - (let ((eol-type (coding-system-eol-type coding-system))) - (cond ((vectorp eol-type) - (princ "Automatic selection from:\n\t") - (princ eol-type) - (princ "\n")) - ((or (null eol-type) (eq eol-type 0)) (princ "LF\n")) - ((eq eol-type 1) (princ "CRLF\n")) - ((eq eol-type 2) (princ "CR\n")) - (t (princ "invalid\n"))))) - (let ((postread (coding-system-get coding-system :post-read-conversion))) - (when postread - (princ "After decoding text normally,") - (princ " perform post-conversion using the function: ") - (princ "\n ") - (princ postread) - (princ "\n"))) - (let ((prewrite (coding-system-get coding-system :pre-write-conversion))) - (when prewrite - (princ "Before encoding text normally,") - (princ " perform pre-conversion using the function: ") - (princ "\n ") - (princ prewrite) - (princ "\n"))) - (with-current-buffer standard-output - (let ((charsets (coding-system-charset-list coding-system))) - (when (and (not (eq (coding-system-base coding-system) 'raw-text)) - charsets) - (cond - ((eq charsets 'iso-2022) - (insert "This coding system can encode all ISO 2022 charsets.")) - ((eq charsets 'emacs-mule) - (insert "This coding system can encode all emacs-mule charsets\ + (let ((help-buffer-under-preparation t)) + (if (null coding-system) + (describe-current-coding-system) + (help-setup-xref (list #'describe-coding-system coding-system) + (called-interactively-p 'interactive)) + (with-output-to-temp-buffer (help-buffer) + (print-coding-system-briefly coding-system 'doc-string) + (let ((type (coding-system-type coding-system)) + ;; Fixme: use this + ;; (extra-spec (coding-system-plist coding-system)) + ) + (princ "Type: ") + (princ type) + (cond ((eq type 'undecided) + (princ " (do automatic conversion)")) + ((eq type 'utf-8) + (princ " (UTF-8: Emacs internal multibyte form)")) + ((eq type 'utf-16) + ;; (princ " (UTF-16)") + ) + ((eq type 'shift-jis) + (princ " (Shift-JIS, MS-KANJI)")) + ((eq type 'iso-2022) + (princ " (variant of ISO-2022)\n") + (princ "Initial designations:\n") + (print-designation (coding-system-get coding-system + :designation)) + + (when (coding-system-get coding-system :flags) + (princ "Other specifications: \n ") + (apply #'print-list + (coding-system-get coding-system :flags)))) + ((eq type 'charset) + (princ " (charset)")) + ((eq type 'ccl) + (princ " (do conversion by CCL program)")) + ((eq type 'raw-text) + (princ " (text with random binary characters)")) + ((eq type 'emacs-mule) + (princ " (Emacs 21 internal encoding)")) + ((eq type 'big5)) + (t (princ ": invalid coding-system."))) + (princ "\nEOL type: ") + (let ((eol-type (coding-system-eol-type coding-system))) + (cond ((vectorp eol-type) + (princ "Automatic selection from:\n\t") + (princ eol-type) + (princ "\n")) + ((or (null eol-type) (eq eol-type 0)) (princ "LF\n")) + ((eq eol-type 1) (princ "CRLF\n")) + ((eq eol-type 2) (princ "CR\n")) + (t (princ "invalid\n"))))) + (let ((postread (coding-system-get coding-system :post-read-conversion))) + (when postread + (princ "After decoding text normally,") + (princ " perform post-conversion using the function: ") + (princ "\n ") + (princ postread) + (princ "\n"))) + (let ((prewrite (coding-system-get coding-system :pre-write-conversion))) + (when prewrite + (princ "Before encoding text normally,") + (princ " perform pre-conversion using the function: ") + (princ "\n ") + (princ prewrite) + (princ "\n"))) + (with-current-buffer standard-output + (let ((charsets (coding-system-charset-list coding-system))) + (when (and (not (eq (coding-system-base coding-system) 'raw-text)) + charsets) + (cond + ((eq charsets 'iso-2022) + (insert "This coding system can encode all ISO 2022 charsets.")) + ((eq charsets 'emacs-mule) + (insert "This coding system can encode all emacs-mule charsets\ .""")) - (t - (insert "This coding system encodes the following charsets:\n ") - (while charsets - (insert " " (symbol-name (car charsets))) - (search-backward (symbol-name (car charsets))) - (help-xref-button 0 'help-character-set (car charsets)) - (goto-char (point-max)) - (setq charsets (cdr charsets))))))))))) + (t + (insert "This coding system encodes the following charsets:\n ") + (while charsets + (insert " " (symbol-name (car charsets))) + (search-backward (symbol-name (car charsets))) + (help-xref-button 0 'help-character-set (car charsets)) + (goto-char (point-max)) + (setq charsets (cdr charsets)))))))))))) ;;;###autoload (defun describe-current-coding-system-briefly () @@ -833,7 +835,7 @@ The IGNORED argument is ignored." "Display information about a font whose name is FONTNAME." (interactive (list (completing-read - "Font name (default current choice for ASCII chars): " + (format-prompt "Font name" "current choice for ASCII chars") (and window-system ;; Implied by `window-system'. (fboundp 'x-list-fonts) @@ -845,7 +847,8 @@ The IGNORED argument is ignored." (or (and window-system (fboundp 'fontset-list)) (error "No fonts being used")) (let ((xref-item (list #'describe-font fontname)) - font-info) + font-info + (help-buffer-under-preparation t)) (if (or (not fontname) (= (length fontname) 0)) (setq fontname (face-attribute 'default :font))) (setq font-info (font-info fontname)) @@ -1004,16 +1007,17 @@ This shows which font is used for which character(s)." (mapcar 'cdr fontset-alias-alist))) (completion-ignore-case t)) (list (completing-read - "Fontset (default used by the current frame): " + (format-prompt "Fontset" "used by the current frame") fontset-list nil t))))) - (if (= (length fontset) 0) - (setq fontset (face-attribute 'default :fontset)) - (setq fontset (query-fontset fontset))) - (help-setup-xref (list #'describe-fontset fontset) - (called-interactively-p 'interactive)) - (with-output-to-temp-buffer (help-buffer) - (with-current-buffer standard-output - (print-fontset fontset t)))) + (let ((help-buffer-under-preparation t)) + (if (= (length fontset) 0) + (setq fontset (face-attribute 'default :fontset)) + (setq fontset (query-fontset fontset))) + (help-setup-xref (list #'describe-fontset fontset) + (called-interactively-p 'interactive)) + (with-output-to-temp-buffer (help-buffer) + (with-current-buffer standard-output + (print-fontset fontset t))))) (declare-function fontset-plain-name "fontset" (fontset)) @@ -1024,39 +1028,41 @@ This shows the name, size, and style of each fontset. With prefix arg, also list the fonts contained in each fontset; see the function `describe-fontset' for the format of the list." (interactive "P") - (if (not (and window-system (fboundp 'fontset-list))) - (error "No fontsets being used") - (help-setup-xref (list #'list-fontsets arg) - (called-interactively-p 'interactive)) - (with-output-to-temp-buffer (help-buffer) - (with-current-buffer standard-output - ;; This code is duplicated near the end of mule-diag. - (let ((fontsets - (sort (fontset-list) - (lambda (x y) - (string< (fontset-plain-name x) - (fontset-plain-name y)))))) - (while fontsets - (if arg - (print-fontset (car fontsets) nil) - (insert "Fontset: " (car fontsets) "\n")) - (setq fontsets (cdr fontsets)))))))) + (let ((help-buffer-under-preparation t)) + (if (not (and window-system (fboundp 'fontset-list))) + (error "No fontsets being used") + (help-setup-xref (list #'list-fontsets arg) + (called-interactively-p 'interactive)) + (with-output-to-temp-buffer (help-buffer) + (with-current-buffer standard-output + ;; This code is duplicated near the end of mule-diag. + (let ((fontsets + (sort (fontset-list) + (lambda (x y) + (string< (fontset-plain-name x) + (fontset-plain-name y)))))) + (while fontsets + (if arg + (print-fontset (car fontsets) nil) + (insert "Fontset: " (car fontsets) "\n")) + (setq fontsets (cdr fontsets))))))))) ;;;###autoload (defun list-input-methods () "Display information about all input methods." (interactive) - (help-setup-xref '(list-input-methods) - (called-interactively-p 'interactive)) - (with-output-to-temp-buffer (help-buffer) - (list-input-methods-1) - (with-current-buffer standard-output - (save-excursion - (goto-char (point-min)) - (while (re-search-forward - (substitute-command-keys "^ \\([^ ]+\\) (`.*' in mode line)$") - nil t) - (help-xref-button 1 'help-input-method (match-string 1))))))) + (let ((help-buffer-under-preparation t)) + (help-setup-xref '(list-input-methods) + (called-interactively-p 'interactive)) + (with-output-to-temp-buffer (help-buffer) + (list-input-methods-1) + (with-current-buffer standard-output + (save-excursion + (goto-char (point-min)) + (while (re-search-forward + (substitute-command-keys "^ \\([^ ]+\\) (`.*' in mode line)$") + nil t) + (help-xref-button 1 'help-input-method (match-string 1)))))))) (defun list-input-methods-1 () (if (not input-method-alist) diff --git a/lisp/international/mule.el b/lisp/international/mule.el index 5022a17db5a..3e45a64dc9a 100644 --- a/lisp/international/mule.el +++ b/lisp/international/mule.el @@ -218,6 +218,7 @@ corresponding Unicode character code. If it is a string, it is a name of file that contains the above information. The file format is the same as what described for `:map' attribute." + (declare (indent defun)) (when (vectorp (car props)) ;; Old style code: ;; (define-charset CHARSET-ID CHARSET-SYMBOL INFO-VECTOR) @@ -890,6 +891,7 @@ non-nil. VALUE non-nil means Emacs prefers UTF-8 on code detection for non-ASCII files. This attribute is meaningful only when `:coding-type' is `undecided'." + (declare (indent defun)) (let* ((common-attrs (mapcar 'list '(:mnemonic :coding-type @@ -2320,6 +2322,7 @@ This function sets properties `translation-table' and `translation-table-id' of SYMBOL to the created table itself and the identification number of the table respectively. It also registers the table in `translation-table-vector'." + (declare (indent defun)) (let ((table (if (and (char-table-p (car args)) (eq (char-table-subtype (car args)) 'translation-table)) @@ -2394,6 +2397,7 @@ Value is what BODY returns." Analogous to `define-translation-table', but updates `translation-hash-table-vector' and the table is for use in the CCL `lookup-integer' and `lookup-character' functions." + (declare (indent defun)) (unless (and (symbolp symbol) (hash-table-p table)) (error "Bad args to define-translation-hash-table")) diff --git a/lisp/international/quail.el b/lisp/international/quail.el index ee935b11ec0..5cdd6d6242b 100644 --- a/lisp/international/quail.el +++ b/lisp/international/quail.el @@ -917,7 +917,7 @@ The format of KBD-LAYOUT is the same as `quail-keyboard-layout'." The variable `quail-keyboard-layout-type' holds the currently selected keyboard type." (interactive - (list (completing-read "Keyboard type (default current choice): " + (list (completing-read (format-prompt "Keyboard type" "current choice") quail-keyboard-layout-alist nil t))) (or (and keyboard-type (> (length keyboard-type) 0)) diff --git a/lisp/international/robin.el b/lisp/international/robin.el index c38cd822693..4c498d7f923 100644 --- a/lisp/international/robin.el +++ b/lisp/international/robin.el @@ -529,10 +529,10 @@ Use the longest match method to select a rule." (insert (cadr tree)) (delete-char (- end begin))))) -;; for backward compatibility - -(fset 'robin-transliterate-region 'robin-convert-region) -(fset 'robin-transliterate-buffer 'robin-convert-buffer) +(define-obsolete-function-alias 'robin-transliterate-region + #'robin-convert-region "29.1") +(define-obsolete-function-alias 'robin-transliterate-buffer + #'robin-convert-buffer "29.1") ;;; Reverse conversion diff --git a/lisp/international/ucs-normalize.el b/lisp/international/ucs-normalize.el index 0f8dedfc09b..3da47e701ab 100644 --- a/lisp/international/ucs-normalize.el +++ b/lisp/international/ucs-normalize.el @@ -536,74 +536,124 @@ COMPOSITION-PREDICATE will be used to compose region." (,ucs-normalize-region (point-min) (point-max)) (buffer-string))) -;;;###autoload (defun ucs-normalize-NFD-region (from to) - "Normalize the current region by the Unicode NFD." + "Decompose the region between FROM and TO according to the Unicode NFD. +This replaces the text between FROM and TO with its canonical decomposition, +a.k.a. the \"Unicode Normalization Form D\"." (interactive "r") (ucs-normalize-region from to ucs-normalize-nfd-quick-check-regexp 'ucs-normalize-nfd-table nil)) -;;;###autoload + (defun ucs-normalize-NFD-string (str) - "Normalize the string STR by the Unicode NFD." + "Decompose the string STR according to the Unicode NFD. +This returns a new string that is the canonical decomposition of STR, +a.k.a. the \"Unicode Normalization Form D\" of STR. For instance: + + (ucs-normalize-NFD-string \"Å\") => \"Å\"" (ucs-normalize-string ucs-normalize-NFD-region)) -;;;###autoload (defun ucs-normalize-NFC-region (from to) - "Normalize the current region by the Unicode NFC." + "Compose the region between FROM and TO according to the Unicode NFC. +This replaces the text between FROM and TO with the result of its +canonical decomposition (see `ucs-normalize-NFD-region') followed by +canonical composition, a.k.a. the \"Unicode Normalization Form C\"." (interactive "r") (ucs-normalize-region from to ucs-normalize-nfc-quick-check-regexp 'ucs-normalize-nfd-table t)) + ;;;###autoload +(defun string-glyph-compose (string) + "Compose STRING according to the Unicode NFC. +This returns a new string obtained by canonical decomposition +of STRING (see `ucs-normalize-NFC-string') followed by canonical +composition, a.k.a. the \"Unicode Normalization Form C\" of STRING. +For instance: + + (string-glyph-compose \"Å\") => \"Å\"" + (ucs-normalize-NFC-string string)) + +;;;###autoload +(defun string-glyph-decompose (string) + "Decompose STRING according to the Unicode NFD. +This returns a new string that is the canonical decomposition of STRING, +a.k.a. the \"Unicode Normalization Form D\" of STRING. For instance: + + (ucs-normalize-NFD-string \"Å\") => \"Å\"" + (ucs-normalize-NFD-string string)) + (defun ucs-normalize-NFC-string (str) - "Normalize the string STR by the Unicode NFC." + "Compose STR according to the Unicode NFC. +This returns a new string obtained by canonical decomposition +of STR (see `ucs-normalize-NFC-string') followed by canonical +composition, a.k.a. the \"Unicode Normalization Form C\" of STR. +For instance: + + (string-glyph-compose \"Å\") => \"Å\"" (ucs-normalize-string ucs-normalize-NFC-region)) -;;;###autoload (defun ucs-normalize-NFKD-region (from to) - "Normalize the current region by the Unicode NFKD." + "Decompose the region between FROM and TO according to the Unicode NFKD. +This replaces the text between FROM and TO with its compatibility +decomposition, a.k.a. \"Unicode Normalization Form KD\"." (interactive "r") (ucs-normalize-region from to ucs-normalize-nfkd-quick-check-regexp 'ucs-normalize-nfkd-table nil)) -;;;###autoload + (defun ucs-normalize-NFKD-string (str) - "Normalize the string STR by the Unicode NFKD." + "Decompose the string STR according to the Unicode NFKD. +This returns a new string obtained by compatibility decomposition +of STR. This is much like the NFD (canonical decomposition) form, +see `ucs-normalize-NFD-string', but mainly differs for precomposed +characters. For instance: + + (ucs-normalize-NFD-string \"fi\") => \"fi\" + (ucs-normalize-NFKD-string \"fi\") = \"fi\"" (ucs-normalize-string ucs-normalize-NFKD-region)) -;;;###autoload (defun ucs-normalize-NFKC-region (from to) - "Normalize the current region by the Unicode NFKC." + "Compose the region between FROM and TO according to the Unicode NFKC. +This replaces the text between FROM and TO with the result of its +compatibility decomposition (see `ucs-normalize-NFC-region') followed by +canonical composition, a.k.a. the \"Unicode Normalization Form KC\"." (interactive "r") (ucs-normalize-region from to ucs-normalize-nfkc-quick-check-regexp 'ucs-normalize-nfkd-table t)) -;;;###autoload + (defun ucs-normalize-NFKC-string (str) - "Normalize the string STR by the Unicode NFKC." + "Compose STR according to the Unicode NFC. +This returns a new string obtained by compatibility decomposition +of STR (see `ucs-normalize-NFKD-string') followed by canonical +composition, a.k.a. the \"Unicode Normalization Form KC\" of STR. +This is much like the NFC (canonical composition) form, but mainly +differs for precomposed characters. For instance: + + (ucs-normalize-NFC-string \"fi\") => \"fi\" + (ucs-normalize-NFKC-string \"fi\") = \"fi\"" (ucs-normalize-string ucs-normalize-NFKC-region)) -;;;###autoload (defun ucs-normalize-HFS-NFD-region (from to) - "Normalize the current region by the Unicode NFD and Mac OS's HFS Plus." + "Normalize region between FROM and TO by Unicode NFD and Mac OS's HFS Plus." (interactive "r") (ucs-normalize-region from to ucs-normalize-hfs-nfd-quick-check-regexp 'ucs-normalize-hfs-nfd-table 'ucs-normalize-hfs-nfd-comp-p)) -;;;###autoload + (defun ucs-normalize-HFS-NFD-string (str) "Normalize the string STR by the Unicode NFD and Mac OS's HFS Plus." (ucs-normalize-string ucs-normalize-HFS-NFD-region)) -;;;###autoload + (defun ucs-normalize-HFS-NFC-region (from to) - "Normalize the current region by the Unicode NFC and Mac OS's HFS Plus." + "Normalize region between FROM and TO by Unicode NFC and Mac OS's HFS Plus." (interactive "r") (ucs-normalize-region from to ucs-normalize-hfs-nfc-quick-check-regexp 'ucs-normalize-hfs-nfd-table t)) -;;;###autoload + (defun ucs-normalize-HFS-NFC-string (str) "Normalize the string STR by the Unicode NFC and Mac OS's HFS Plus." (ucs-normalize-string ucs-normalize-HFS-NFC-region)) diff --git a/lisp/isearch.el b/lisp/isearch.el index c382d0ad2a0..8815cb4f2d6 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -488,9 +488,9 @@ and doesn't remove full-buffer highlighting after a search." "You have typed %THIS-KEY%, the help character. Type a Help option: \(Type \\<isearch-help-map>\\[help-quit] to exit the Help command.) -\\[isearch-describe-bindings] Display all Isearch key bindings. -\\[isearch-describe-key] KEYS Display full documentation of Isearch key sequence. -\\[isearch-describe-mode] Display documentation of Isearch mode. + \\[isearch-describe-bindings] Display all Isearch key bindings. + \\[isearch-describe-key] Display full documentation of Isearch key sequence. + \\[isearch-describe-mode] Display documentation of Isearch mode. You can't type here other help keys available in the global help map, but outside of this help window when you type them in Isearch mode, @@ -2478,8 +2478,8 @@ 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 - #'(lambda (regexp face lighter) - (highlight-regexp regexp face nil lighter)))) + (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'. @@ -2487,8 +2487,8 @@ 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 - #'(lambda (regexp face _lighter) - (highlight-lines-matching-regexp regexp face)))) + (lambda (regexp face _lighter) + (highlight-lines-matching-regexp regexp face)))) (defun isearch-delete-char () @@ -2504,6 +2504,11 @@ If no input items have been entered yet, just beep." (if (null (cdr isearch-cmds)) (ding) (isearch-pop-state)) + ;; When going back to the hidden match, reopen it. + (when (and (eq search-invisible 'open) isearch-hide-immediately + isearch-other-end) + (isearch-range-invisible (min (point) isearch-other-end) + (max (point) isearch-other-end))) (isearch-update)) (defun isearch-del-char (&optional arg) @@ -3787,8 +3792,9 @@ Isearch, at least partially, as determined by `isearch-range-invisible'. If `search-invisible' is t, which allows Isearch matches inside invisible text, this function will always return non-nil, regardless of what `isearch-range-invisible' says." - (or (eq search-invisible t) - (not (isearch-range-invisible beg end)))) + (and (not (text-property-not-all beg end 'inhibit-isearch nil)) + (or (eq search-invisible t) + (not (isearch-range-invisible beg end))))) ;; General utilities diff --git a/lisp/keymap.el b/lisp/keymap.el new file mode 100644 index 00000000000..fd91689f887 --- /dev/null +++ b/lisp/keymap.el @@ -0,0 +1,457 @@ +;;; keymap.el --- Keymap functions -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This library deals with the "new" keymap binding interface: The +;; only key syntax allowed by these functions is the `kbd' one. + +;;; Code: + + + +(defun keymap--check (key) + "Signal an error if KEY doesn't have a valid syntax." + (unless (key-valid-p key) + (error "%S is not a valid key definition; see `key-valid-p'" key))) + +(defun keymap--compile-check (&rest keys) + (dolist (key keys) + (when (or (vectorp key) + (and (stringp key) (not (key-valid-p key)))) + (byte-compile-warn "Invalid `kbd' syntax: %S" key)))) + +(defun keymap-set (keymap key definition) + "Set key sequence KEY to DEFINITION in KEYMAP. +KEY is a string that satisfies `key-valid-p'. + +DEFINITION is anything that can be a key's definition: + nil (means key is undefined in this keymap), + a command (a Lisp function suitable for interactive calling), + a string (treated as a keyboard macro), + a keymap (to define a prefix key), + a symbol (when the key is looked up, the symbol will stand for its + function definition, which should at that time be one of the above, + or another symbol whose function definition is used, etc.), + a cons (STRING . DEFN), meaning that DEFN is the definition + (DEFN should be a valid definition in its own right) and + STRING is the menu item name (which is used only if the containing + keymap has been created with a menu name, see `make-keymap'), + or a cons (MAP . CHAR), meaning use definition of CHAR in keymap MAP, + or an extended menu item definition. + (See info node `(elisp)Extended Menu Items'.)" + (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) + (keymap--check key) + ;; If we're binding this key to another key, then parse that other + ;; key, too. + (when (stringp definition) + (keymap--check definition) + (setq definition (key-parse definition))) + (define-key keymap (key-parse key) definition)) + +(defun keymap-global-set (key command) + "Give KEY a global binding as COMMAND. +COMMAND is the command definition to use; usually it is +a symbol naming an interactively-callable function. + +KEY is a string that satisfies `key-valid-p'. + +Note that if KEY has a local binding in the current buffer, +that local binding will continue to shadow any global binding +that you make with this function." + (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) + (interactive + (let* ((menu-prompting nil) + (key (read-key-sequence "Set key globally: " nil t))) + (list key + (read-command (format "Set key %s to command: " + (key-description key)))))) + (keymap-set (current-global-map) key command)) + +(defun keymap-local-set (key command) + "Give KEY a local binding as COMMAND. +COMMAND is the command definition to use; usually it is +a symbol naming an interactively-callable function. + +KEY is a string that satisfies `key-valid-p'. + +The binding goes in the current buffer's local map, which in most +cases is shared with all other buffers in the same major mode." + (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) + (interactive "KSet key locally: \nCSet key %s locally to command: ") + (let ((map (current-local-map))) + (unless map + (use-local-map (setq map (make-sparse-keymap)))) + (keymap-set map key command))) + +(defun keymap-global-unset (key &optional remove) + "Remove global binding of KEY (if any). +KEY is a string that satisfies `key-valid-p'. + +If REMOVE (interactively, the prefix arg), remove the binding +instead of unsetting it. See `keymap-unset' for details." + (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) + (interactive + (list (key-description (read-key-sequence "Set key locally: ")) + current-prefix-arg)) + (keymap-unset (current-global-map) key remove)) + +(defun keymap-local-unset (key &optional remove) + "Remove local binding of KEY (if any). +KEY is a string that satisfies `key-valid-p'. + +If REMOVE (interactively, the prefix arg), remove the binding +instead of unsetting it. See `keymap-unset' for details." + (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) + (interactive + (list (key-description (read-key-sequence "Unset key locally: ")) + current-prefix-arg)) + (when (current-local-map) + (keymap-unset (current-local-map) key remove))) + +(defun keymap-unset (keymap key &optional remove) + "Remove key sequence KEY from KEYMAP. +KEY is a string that satisfies `key-valid-p'. + +If REMOVE, remove the binding instead of unsetting it. This only +makes a difference when there's a parent keymap. When unsetting +a key in a child map, it will still shadow the same key in the +parent keymap. Removing the binding will allow the key in the +parent keymap to be used." + (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) + (keymap--check key) + (define-key keymap (key-parse key) nil remove)) + +(defun keymap-substitute (keymap olddef newdef &optional oldmap prefix) + "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF. +In other words, OLDDEF is replaced with NEWDEF wherever it appears. +Alternatively, if optional fourth argument OLDMAP is specified, we redefine +in KEYMAP as NEWDEF those keys that are defined as OLDDEF in OLDMAP. + +If you don't specify OLDMAP, you can usually get the same results +in a cleaner way with command remapping, like this: + (define-key KEYMAP [remap OLDDEF] NEWDEF) +\n(fn OLDDEF NEWDEF KEYMAP &optional OLDMAP)" + ;; Don't document PREFIX in the doc string because we don't want to + ;; advertise it. It's meant for recursive calls only. Here's its + ;; meaning + + ;; If optional argument PREFIX is specified, it should be a key + ;; prefix, a string. Redefined bindings will then be bound to the + ;; original key, with PREFIX added at the front. + (unless prefix + (setq prefix "")) + (let* ((scan (or oldmap keymap)) + (prefix1 (vconcat prefix [nil])) + (key-substitution-in-progress + (cons scan key-substitution-in-progress))) + ;; Scan OLDMAP, finding each char or event-symbol that + ;; has any definition, and act on it with hack-key. + (map-keymap + (lambda (char defn) + (aset prefix1 (length prefix) char) + (substitute-key-definition-key defn olddef newdef prefix1 keymap)) + scan))) + +(defun keymap-set-after (keymap key definition &optional after) + "Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding. +This is like `keymap-set' except that the binding for KEY is placed +just after the binding for the event AFTER, instead of at the beginning +of the map. Note that AFTER must be an event type (like KEY), NOT a command +\(like DEFINITION). + +If AFTER is t or omitted, the new binding goes at the end of the keymap. +AFTER should be a single event type--a symbol or a character, not a sequence. + +Bindings are always added before any inherited map. + +The order of bindings in a keymap matters only when it is used as +a menu, so this function is not useful for non-menu keymaps." + (declare (indent defun) + (compiler-macro (lambda (form) (keymap--compile-check key) form))) + (keymap--check key) + (when after + (keymap--check after)) + (define-key-after keymap (key-parse key) definition + (and after (key-parse after)))) + +(defun key-parse (keys) + "Convert KEYS to the internal Emacs key representation. +See `kbd' for a descripion of KEYS." + (declare (pure t) (side-effect-free t)) + ;; A pure function is expected to preserve the match data. + (save-match-data + (let ((case-fold-search nil) + (len (length keys)) ; We won't alter keys in the loop below. + (pos 0) + (res [])) + (while (and (< pos len) + (string-match "[^ \t\n\f]+" keys pos)) + (let* ((word-beg (match-beginning 0)) + (word-end (match-end 0)) + (word (substring keys word-beg len)) + (times 1) + key) + ;; Try to catch events of the form "<as df>". + (if (string-match "\\`<[^ <>\t\n\f][^>\t\n\f]*>" word) + (setq word (match-string 0 word) + pos (+ word-beg (match-end 0))) + (setq word (substring keys word-beg word-end) + pos word-end)) + (when (string-match "\\([0-9]+\\)\\*." word) + (setq times (string-to-number (substring word 0 (match-end 1)))) + (setq word (substring word (1+ (match-end 1))))) + (cond ((string-match "^<<.+>>$" word) + (setq key (vconcat (if (eq (key-binding [?\M-x]) + 'execute-extended-command) + [?\M-x] + (or (car (where-is-internal + 'execute-extended-command)) + [?\M-x])) + (substring word 2 -2) "\r"))) + ((and (string-match "^\\(\\([ACHMsS]-\\)*\\)<\\(.+\\)>$" word) + (progn + (setq word (concat (match-string 1 word) + (match-string 3 word))) + (not (string-match + "\\<\\(NUL\\|RET\\|LFD\\|ESC\\|SPC\\|DEL\\)$" + word)))) + (setq key (list (intern word)))) + ((or (equal word "REM") (string-match "^;;" word)) + (setq pos (string-match "$" keys pos))) + (t + (let ((orig-word word) (prefix 0) (bits 0)) + (while (string-match "^[ACHMsS]-." word) + (setq bits (+ bits + (cdr + (assq (aref word 0) + '((?A . ?\A-\^@) (?C . ?\C-\^@) + (?H . ?\H-\^@) (?M . ?\M-\^@) + (?s . ?\s-\^@) (?S . ?\S-\^@)))))) + (setq prefix (+ prefix 2)) + (setq word (substring word 2))) + (when (string-match "^\\^.$" word) + (setq bits (+ bits ?\C-\^@)) + (setq prefix (1+ prefix)) + (setq word (substring word 1))) + (let ((found (assoc word '(("NUL" . "\0") ("RET" . "\r") + ("LFD" . "\n") ("TAB" . "\t") + ("ESC" . "\e") ("SPC" . " ") + ("DEL" . "\177"))))) + (when found (setq word (cdr found)))) + (when (string-match "^\\\\[0-7]+$" word) + (let ((n 0)) + (dolist (ch (cdr (string-to-list word))) + (setq n (+ (* n 8) ch -48))) + (setq word (vector n)))) + (cond ((= bits 0) + (setq key word)) + ((and (= bits ?\M-\^@) (stringp word) + (string-match "^-?[0-9]+$" word)) + (setq key (mapcar (lambda (x) (+ x bits)) + (append word nil)))) + ((/= (length word) 1) + (error "%s must prefix a single character, not %s" + (substring orig-word 0 prefix) word)) + ((and (/= (logand bits ?\C-\^@) 0) (stringp word) + ;; We used to accept . and ? here, + ;; but . is simply wrong, + ;; and C-? is not used (we use DEL instead). + (string-match "[@-_a-z]" word)) + (setq key (list (+ bits (- ?\C-\^@) + (logand (aref word 0) 31))))) + (t + (setq key (list (+ bits (aref word 0))))))))) + (when key + (dolist (_ (number-sequence 1 times)) + (setq res (vconcat res key)))))) + (if (and (>= (length res) 4) + (eq (aref res 0) ?\C-x) + (eq (aref res 1) ?\() + (eq (aref res (- (length res) 2)) ?\C-x) + (eq (aref res (- (length res) 1)) ?\))) + (apply #'vector (let ((lres (append res nil))) + ;; Remove the first and last two elements. + (setq lres (cdr (cdr lres))) + (nreverse lres) + (setq lres (cdr (cdr lres))) + (nreverse lres))) + res)))) + +(defun key-valid-p (keys) + "Say whether KEYS is a valid `kbd' sequence. +A `kbd' sequence is a string consisting of one and more key +strokes. The key strokes are separated by a space character. + +Each key stroke is either a single character, or the name of an +event, surrounded by angle brackets. In addition, any key stroke +may be preceded by one or more modifier keys. Finally, a limited +number of characters have a special shorthand syntax. + +Here's some example key sequences. + + \"f\" (the key 'f') + \"S o m\" (a three key sequence of the keys 'S', 'o' and 'm') + \"C-c o\" (a two key sequence of the keys 'c' with the control modifier + and then the key 'o') + \"H-<left>\" (the key named \"left\" with the hyper modifier) + \"M-RET\" (the \"return\" key with a meta modifier) + \"C-M-<space>\" (the \"space\" key with both the control and meta modifiers) + +These are the characters that have shorthand syntax: +NUL, RET, TAB, LFD, ESC, SPC, DEL. + +Modifiers have to be specified in this order: + + A-C-H-M-S-s + +which is + + Alt-Control-Hyper-Meta-Shift-super" + (declare (pure t) (side-effect-free t)) + (and + (stringp keys) + (string-match-p "\\`[^ ]+\\( [^ ]+\\)*\\'" keys) + (save-match-data + (catch 'exit + (let ((prefixes + "\\(A-\\)?\\(C-\\)?\\(H-\\)?\\(M-\\)?\\(S-\\)?\\(s-\\)?") + (case-fold-search nil)) + (dolist (key (split-string keys " ")) + ;; Every key might have these modifiers, and they should be + ;; in this order. + (when (string-match (concat "\\`" prefixes) key) + (setq key (substring key (match-end 0)))) + (unless (or (and (= (length key) 1) + ;; Don't accept control characters as keys. + (not (< (aref key 0) ?\s)) + ;; Don't accept Meta'd characters as keys. + (or (multibyte-string-p key) + (not (<= 127 (aref key 0) 255)))) + (and (string-match-p "\\`<[-_A-Za-z0-9]+>\\'" key) + ;; Don't allow <M-C-down>. + (= (progn + (string-match + (concat "\\`<" prefixes) key) + (match-end 0)) + 1)) + (string-match-p + "\\`\\(NUL\\|RET\\|TAB\\|LFD\\|ESC\\|SPC\\|DEL\\)\\'" + key)) + ;; Invalid. + (throw 'exit nil))) + t))))) + +(defun key-translate (from to) + "Translate character FROM to TO on the current terminal. +This function creates a `keyboard-translate-table' if necessary +and then modifies one entry in it. + +Both KEY and TO are strings that satisfy `key-valid-p'." + (declare (compiler-macro + (lambda (form) (keymap--compile-check from to) form))) + (keymap--check from) + (keymap--check to) + (or (char-table-p keyboard-translate-table) + (setq keyboard-translate-table + (make-char-table 'keyboard-translate-table nil))) + (aset keyboard-translate-table (key-parse from) (key-parse to))) + +(defun keymap-lookup (keymap key &optional accept-default no-remap position) + "Return the binding for command KEY. +KEY is a string that satisfies `key-valid-p'. + +If KEYMAP is nil, look up in the current keymaps. If non-nil, it +should either be a keymap or a list of keymaps, and only these +keymap(s) will be consulted. + +The binding is probably a symbol with a function definition. + +Normally, `keymap-lookup' ignores bindings for t, which act as +default bindings, used when nothing else in the keymap applies; +this makes it usable as a general function for probing keymaps. +However, if the optional second argument ACCEPT-DEFAULT is +non-nil, `keymap-lookup' does recognize the default bindings, +just as `read-key-sequence' does. + +Like the normal command loop, `keymap-lookup' will remap the +command resulting from looking up KEY by looking up the command +in the current keymaps. However, if the optional third argument +NO-REMAP is non-nil, `keymap-lookup' returns the unmapped +command. + +If KEY is a key sequence initiated with the mouse, the used keymaps +will depend on the clicked mouse position with regard to the buffer +and possible local keymaps on strings. + +If the optional argument POSITION is non-nil, it specifies a mouse +position as returned by `event-start' and `event-end', and the lookup +occurs in the keymaps associated with it instead of KEY. It can also +be a number or marker, in which case the keymap properties at the +specified buffer position instead of point are used." + (declare (compiler-macro (lambda (form) (keymap--compile-check key) form))) + (keymap--check key) + (when (and keymap position) + (error "Can't pass in both keymap and position")) + (if keymap + (let ((value (lookup-key keymap (key-parse key) accept-default))) + (if (and (not no-remap) + (symbolp value)) + (or (command-remapping value) value) + value)) + (key-binding (kbd key) accept-default no-remap position))) + +(defun keymap-local-lookup (keys &optional accept-default) + "Return the binding for command KEYS in current local keymap only. +KEY is a string that satisfies `key-valid-p'. + +The binding is probably a symbol with a function definition. + +If optional argument ACCEPT-DEFAULT is non-nil, recognize default +bindings; see the description of `keymap-lookup' for more details +about this." + (declare (compiler-macro (lambda (form) (keymap--compile-check keys) form))) + (when-let ((map (current-local-map))) + (keymap-lookup map keys accept-default))) + +(defun keymap-global-lookup (keys &optional accept-default message) + "Return the binding for command KEYS in current global keymap only. +KEY is a string that satisfies `key-valid-p'. + +The binding is probably a symbol with a function definition. +This function's return values are the same as those of `keymap-lookup' +\(which see). + +If optional argument ACCEPT-DEFAULT is non-nil, recognize default +bindings; see the description of `keymap-lookup' for more details +about this. + +If MESSAGE (and interactively), message the result." + (declare (compiler-macro (lambda (form) (keymap--compile-check keys) form))) + (interactive + (list (key-description (read-key-sequence "Look up key in global keymap: ")) + nil t)) + (let ((def (keymap-lookup (current-global-map) keys accept-default))) + (when message + (message "%s is bound to %s globally" keys def)) + def)) + +(provide 'keymap) + +;;; keymap.el ends here diff --git a/lisp/language/cyril-util.el b/lisp/language/cyril-util.el index 04e681d743d..e404288ddca 100644 --- a/lisp/language/cyril-util.el +++ b/lisp/language/cyril-util.el @@ -60,7 +60,7 @@ If the argument is nil, we return the display table to its standard state." (list (let* ((completion-ignore-case t)) (completing-read - "Cyrillic language (default nil): " + (format-prompt "Cyrillic language" "nil") cyrillic-language-alist nil t nil nil nil)))) (or standard-display-table diff --git a/lisp/language/hanja-util.el b/lisp/language/hanja-util.el index 9e9213536cb..fe6323d42ba 100644 --- a/lisp/language/hanja-util.el +++ b/lisp/language/hanja-util.el @@ -6573,8 +6573,8 @@ The value is a hanja character that is selected interactively." (hanja-filter (lambda (x) (car x)) (mapcar (lambda (c) (if (listp c) - (cons (decode-char 'ucs (car c)) (cdr c)) - (list (decode-char 'ucs c)))) + (cons (car c) (cdr c)) + (list c))) (aref hanja-table char))))) (unwind-protect (when (aref hanja-conversions 2) diff --git a/lisp/language/lao.el b/lisp/language/lao.el index c699d57c15a..93849461eae 100644 --- a/lisp/language/lao.el +++ b/lisp/language/lao.el @@ -59,11 +59,11 @@ (let* ((chars (car l)) (len (length chars)) ;; Replace `c', `t', `v' to consonant, tone, and vowel. - (regexp (mapconcat #'(lambda (c) - (cond ((= c ?c) consonant) - ((= c ?t) tone) - ((= c ?v) vowel-upper-lower) - (t (string c)))) + (regexp (mapconcat (lambda (c) + (cond ((= c ?c) consonant) + ((= c ?t) tone) + ((= c ?v) vowel-upper-lower) + (t (string c)))) (cdr l) "")) ;; Element of composition-function-table. (elt (list (vector regexp 1 #'lao-composition-function) diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el index 58de4c0cc4a..0fbae8508a0 100644 --- a/lisp/ldefs-boot.el +++ b/lisp/ldefs-boot.el @@ -1,4 +1,5 @@ ;;; loaddefs.el --- automatically extracted autoloads -*- lexical-binding: t -*- +;; This file will be copied to ldefs-boot.el and checked in periodically. ;; ;;; Code: @@ -338,11 +339,22 @@ usage: (defadvice FUNCTION (CLASS NAME [POSITION] [ARGLIST] FLAG...) (autoload 'align "align" "\ Attempt to align a region based on a set of alignment rules. -BEG and END mark the region. If BEG and END are specifically set to -nil (this can only be done programmatically), the beginning and end of -the current alignment section will be calculated based on the location -of point, and the value of `align-region-separate' (or possibly each -rule's `separate' attribute). +Interactively, BEG and END are the mark/point of the current region. + +Many modes define specific alignment rules, and some of these +rules in some modes react to the current prefix argument. For +instance, in `text-mode', `M-x align' will align into columns +based on space delimiters, while `C-u - M-x align' will align +into columns based on the \"$\" character. See the +`align-rules-list' variable definition for the specific rules. + +Also see `align-regexp', which will guide you through various +parameters for aligning text. + +Non-interactively, if BEG and END are nil, the beginning and end +of the current alignment section will be calculated based on the +location of point, and the value of `align-region-separate' (or +possibly each rule's `separate' attribute). If SEPARATE is non-nil, it overrides the value of `align-region-separate' for all rules, except those that have their @@ -360,6 +372,15 @@ Align the current region using an ad-hoc rule read from the minibuffer. BEG and END mark the limits of the region. Interactively, this function prompts for the regular expression REGEXP to align with. +Interactively, if you specify a prefix argument, the function +will guide you through entering the full regular expression, and +then prompts for which subexpression parenthesis GROUP (default +1) within REGEXP to modify, the amount of SPACING (default +`align-default-spacing') to use, and whether or not to REPEAT the +rule throughout the line. + +See `align-rules-list' for more information about these options. + For example, let's say you had a list of phone numbers, and wanted to align them so that the opening parentheses would line up: @@ -379,15 +400,8 @@ regular expression after you enter it. Interactively, you only need to supply the characters to be lined up, and any preceding whitespace is replaced. -Non-interactively (or if you specify a prefix argument), you must -enter the full regular expression, including the subexpression. -Interactively, the function also then prompts for which -subexpression parenthesis GROUP (default 1) within REGEXP to -modify, the amount of SPACING (default `align-default-spacing') -to use, and whether or not to REPEAT the rule throughout the -line. - -See `align-rules-list' for more information about these options. +Non-interactively, you must enter the full regular expression, +including the subexpression. The non-interactive form of the previous example would look something like: (align-regexp (point-min) (point-max) \"\\\\(\\\\s-*\\\\)(\") @@ -1665,6 +1679,8 @@ or if CONDITION had no actions, after all other CONDITIONs. \(fn CONDITION ACTION &optional AFTER)" nil nil) +(function-put 'define-auto-insert 'lisp-indent-function 'defun) + (defvar auto-insert-mode nil "\ Non-nil if Auto-Insert mode is enabled. See the `auto-insert-mode' command @@ -2366,12 +2382,7 @@ a reflection. (define-key ctl-x-r-map "M" 'bookmark-set-no-overwrite) (define-key ctl-x-r-map "l" 'bookmark-bmenu-list) -(defvar bookmark-map (let ((map (make-sparse-keymap))) (define-key map "x" 'bookmark-set) (define-key map "m" 'bookmark-set) (define-key map "M" 'bookmark-set-no-overwrite) (define-key map "j" 'bookmark-jump) (define-key map "g" 'bookmark-jump) (define-key map "o" 'bookmark-jump-other-window) (define-key map "5" 'bookmark-jump-other-frame) (define-key map "i" 'bookmark-insert) (define-key map "e" 'edit-bookmarks) (define-key map "f" 'bookmark-insert-location) (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) map) "\ -Keymap containing bindings to bookmark functions. -It is not bound to any key by default: to bind it -so that you have a bookmark prefix, just use `global-set-key' and bind a -key of your choice to variable `bookmark-map'. All interactive bookmark -functions have a binding in this keymap.") +(defvar-keymap bookmark-map :doc "Keymap containing bindings to bookmark functions.\nIt is not bound to any key by default: to bind it\nso that you have a bookmark prefix, just use `global-set-key' and bind a\nkey of your choice to variable `bookmark-map'. All interactive bookmark\nfunctions have a binding in this keymap." "x" #'bookmark-set "m" #'bookmark-set "M" #'bookmark-set-no-overwrite "j" #'bookmark-jump "g" #'bookmark-jump "o" #'bookmark-jump-other-window "5" #'bookmark-jump-other-frame "i" #'bookmark-insert "e" #'edit-bookmarks "f" #'bookmark-insert-location "r" #'bookmark-rename "d" #'bookmark-delete "D" #'bookmark-delete-all "l" #'bookmark-load "w" #'bookmark-write "s" #'bookmark-save) (fset 'bookmark-map bookmark-map) (autoload 'bookmark-set "bookmark" "\ @@ -2800,6 +2811,13 @@ used instead of `browse-url-new-window-flag'. (make-obsolete 'browse-url-galeon 'nil '"25.1") +(autoload 'browse-url-webpositive "browse-url" "\ +Ask the WebPositive WWW browser to load URL. +Default to the URL around or before point. +The optional argument NEW-WINDOW is not used. + +\(fn URL &optional NEW-WINDOW)" t nil) + (autoload 'browse-url-emacs "browse-url" "\ Ask Emacs to load URL into a buffer and show it in another window. Optional argument SAME-WINDOW non-nil means show the URL in the @@ -3082,6 +3100,11 @@ disabled. (put 'byte-compile-warnings 'safe-local-variable (lambda (v) (or (symbolp v) (null (delq nil (mapcar (lambda (x) (not (symbolp x))) v)))))) +(autoload 'byte-compile-warning-enabled-p "bytecomp" "\ +Return non-nil if WARNING is enabled, according to `byte-compile-warnings'. + +\(fn WARNING &optional SYMBOL)" nil nil) + (autoload 'byte-compile-disable-warning "bytecomp" "\ Change `byte-compile-warnings' to disable WARNING. If `byte-compile-warnings' is t, set it to `(not WARNING)'. @@ -3438,6 +3461,8 @@ See Info node `(calc)Defining Functions'. (function-put 'defmath 'doc-string-elt '3) +(function-put 'defmath 'lisp-indent-function 'defun) + (register-definition-prefixes "calc" '("calc" "defcalcmodevar" "inexact-result" "math-" "var-")) ;;;*** @@ -4467,6 +4492,8 @@ MAP-ID := integer (function-put 'define-ccl-program 'doc-string-elt '3) +(function-put 'define-ccl-program 'lisp-indent-function 'defun) + (autoload 'check-ccl-program "ccl" "\ Check validity of CCL-PROGRAM. If CCL-PROGRAM is a symbol denoting a CCL program, return @@ -4753,6 +4780,14 @@ space at the end of each line. \(fn &optional NO-ERROR)" t nil) +(autoload 'checkdoc-dired "checkdoc" "\ +In Dired, run `checkdoc' on marked files. +Skip anything that doesn't have the Emacs Lisp library file +extension (\".el\"). +When called from Lisp, FILES is a list of filenames. + +\(fn FILES)" '(dired-mode) nil) + (autoload 'checkdoc-ispell "checkdoc" "\ Check the style and spelling of everything interactively. Calls `checkdoc' with spell-checking turned on. @@ -7409,6 +7444,8 @@ See Info node `(elisp)Derived Modes' for more details. (function-put 'define-derived-mode 'doc-string-elt '4) +(function-put 'define-derived-mode 'lisp-indent-function 'defun) + (autoload 'derived-mode-init-mode-variables "derived" "\ Initialize variables for a new MODE. Right now, if they don't already exist, set up a blank keymap, an @@ -8801,6 +8838,8 @@ INIT-VALUE LIGHTER KEYMAP. (function-put 'define-minor-mode 'doc-string-elt '2) +(function-put 'define-minor-mode 'lisp-indent-function 'defun) + (defalias 'easy-mmode-define-global-mode #'define-globalized-minor-mode) (defalias 'define-global-minor-mode #'define-globalized-minor-mode) @@ -8838,6 +8877,8 @@ on if the hook has explicitly disabled it. (function-put 'define-globalized-minor-mode 'doc-string-elt '2) +(function-put 'define-globalized-minor-mode 'lisp-indent-function 'defun) + (autoload 'easy-mmode-define-keymap "easy-mmode" "\ Return a keymap built from bindings BS. BS must be a list of (KEY . BINDING) where @@ -10487,6 +10528,40 @@ Emerge two RCS revisions of a file, with another revision as ancestor. ;;;*** +;;;### (autoloads nil "emoji" "international/emoji.el" (0 0 0 0)) +;;; Generated autoloads from international/emoji.el + +(autoload 'emoji-insert "emoji" "\ +Choose and insert an emoji glyph. +If TEXT (interactively, the prefix), use a textual search instead +of a visual interface. + +\(fn &optional TEXT)" t nil) + +(autoload 'emoji-recent "emoji" "\ +Choose and insert a recently used emoji glyph." t nil) + +(autoload 'emoji-search "emoji" "\ +Choose and insert an emoji glyph by searching for an emoji name." t nil) + +(autoload 'emoji-list "emoji" "\ +List emojis and insert the one that's selected. +The character will be inserted into the buffer that was selected +when the command was issued." t nil) + +(autoload 'emoji-describe "emoji" "\ +Say what the name of the composed grapheme cluster GLYPH is. +If it's not known, this function returns nil. + +Interactively, it will message what the name of the emoji (or +character) under point is. + +\(fn GLYPH &optional INTERACTIVE)" t nil) + +(register-definition-prefixes "emoji" '("emoji-")) + +;;;*** + ;;;### (autoloads nil "enriched" "textmodes/enriched.el" (0 0 0 0)) ;;; Generated autoloads from textmodes/enriched.el @@ -10929,7 +11004,7 @@ Look at CONFIG and try to expand GROUP. ;;;### (autoloads nil "erc" "erc/erc.el" (0 0 0 0)) ;;; Generated autoloads from erc/erc.el -(push (purecopy '(erc 5 4)) package--builtin-versions) +(push (purecopy '(erc 5 4 1)) package--builtin-versions) (autoload 'erc-select-read-args "erc" "\ Prompt the user for values of nick, server, port, and password." nil nil) @@ -11076,6 +11151,9 @@ Macros in BODY are expanded when the test is defined, not when it is run. If a macro (possibly with side effects) is to be tested, it has to be wrapped in `(eval (quote ...))'. +If NAME is already defined as a test and Emacs is running +in batch mode, an error is signalled. + \(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] [:tags \\='(TAG...)] BODY...)" nil t) (function-put 'ert-deftest 'doc-string-elt '3) @@ -11108,11 +11186,8 @@ the tests). Run the tests specified by SELECTOR and display the results in a buffer. SELECTOR works as described in `ert-select-tests'. -OUTPUT-BUFFER-NAME and MESSAGE-FN should normally be nil; they -are used for automated self-tests and specify which buffer to use -and how to display message. -\(fn SELECTOR &optional OUTPUT-BUFFER-NAME MESSAGE-FN)" t nil) +\(fn SELECTOR)" t nil) (defalias 'ert #'ert-run-tests-interactively) @@ -11135,6 +11210,22 @@ Kill all test buffers that are still live." t nil) ;;;*** +;;;### (autoloads nil "erts-mode" "progmodes/erts-mode.el" (0 0 0 +;;;;;; 0)) +;;; Generated autoloads from progmodes/erts-mode.el + +(autoload 'erts-mode "erts-mode" "\ +Major mode for editing erts (Emacs testing) files. +This mode mainly provides some font locking. + +\\{erts-mode-map} + +\(fn)" t nil) + +(register-definition-prefixes "erts-mode" '("erts-")) + +;;;*** + ;;;### (autoloads nil "esh-arg" "eshell/esh-arg.el" (0 0 0 0)) ;;; Generated autoloads from eshell/esh-arg.el @@ -11479,7 +11570,7 @@ See documentation of variable `tags-file-name'. (make-obsolete 'find-tag-regexp 'xref-find-apropos '"25.1") -(defalias 'pop-tag-mark 'xref-pop-marker-stack) +(defalias 'pop-tag-mark 'xref-go-back) (defalias 'next-file 'tags-next-file) @@ -11956,14 +12047,14 @@ 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. +If NEW-BUFFER is non-nil (interactively, the prefix arg), use a +new buffer instead of reusing 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. -\(fn URL &optional ARG BUFFER)" t nil) +\(fn URL &optional NEW-BUFFER BUFFER)" t nil) (defalias 'browse-web 'eww) (autoload 'eww-open-file "eww" "\ @@ -14456,7 +14547,7 @@ CLEAN is obsolete and ignored. (autoload 'gnus-article-prepare-display "gnus-art" "\ Make the current buffer look like a nice article." nil nil) -(register-definition-prefixes "gnus-art" '("article-" "gnus-")) +(register-definition-prefixes "gnus-art" '(":keymap" "article-" "gnus-")) ;;;*** @@ -14764,7 +14855,7 @@ The arguments have the same meaning as those of \(fn IDS &optional WINDOW-CONF)" t nil) -(register-definition-prefixes "gnus-group" '("gnus-")) +(register-definition-prefixes "gnus-group" '(":keymap" "gnus-")) ;;;*** @@ -14991,7 +15082,7 @@ Like `message-reply'. (define-mail-user-agent 'gnus-user-agent 'gnus-msg-mail 'message-send-and-exit 'message-kill-buffer 'message-send-hook) -(register-definition-prefixes "gnus-msg" '("gnus-")) +(register-definition-prefixes "gnus-msg" '(":prefix" "gnus-")) ;;;*** @@ -15205,7 +15296,7 @@ BOOKMARK is a bookmark name or a bookmark record. \(fn BOOKMARK)" nil nil) -(register-definition-prefixes "gnus-sum" '("gnus-")) +(register-definition-prefixes "gnus-sum" '(":keymap" "gnus-")) ;;;*** @@ -16232,6 +16323,11 @@ gives the window that lists the options.") ;;;### (autoloads nil "help-mode" "help-mode.el" (0 0 0 0)) ;;; Generated autoloads from help-mode.el +(autoload 'help-mode--add-function-link "help-mode" "\ + + +\(fn STR FUN)" nil nil) + (autoload 'help-mode "help-mode" "\ Major mode for viewing help text and navigating references in it. Entry to this mode runs the normal hook `help-mode-hook'. @@ -18256,7 +18352,11 @@ specifying the X and Y positions and WIDTH and HEIGHT of image area to insert. A float value 0.0 - 1.0 means relative to the width or height of the image; integer values are taken as pixel values. -\(fn IMAGE &optional STRING AREA SLICE)" nil nil) +Normally `isearch' is able to search for STRING in the buffer +even if it's hidden behind a displayed image. If INHIBIT-ISEARCH +is non-nil, this is inhibited. + +\(fn IMAGE &optional STRING AREA SLICE INHIBIT-ISEARCH)" nil nil) (autoload 'insert-sliced-image "image" "\ Insert IMAGE into current buffer at point. @@ -18325,6 +18425,8 @@ Example: (function-put 'defimage 'doc-string-elt '3) +(function-put 'defimage 'lisp-indent-function 'defun) + (autoload 'imagemagick-register-types "image" "\ Register file types that can be handled by ImageMagick. This function is called at startup, after loading the init file. @@ -18337,6 +18439,9 @@ recognizes these files as having image type `imagemagick'. If Emacs is compiled without ImageMagick support, this does nothing." nil nil) +(autoload 'image-at-point-p "image" "\ +Return non-nil if there is an image at point." nil nil) + (register-definition-prefixes "image" '("find-image--cache" "image" "unknown-image-type")) ;;;*** @@ -18406,17 +18511,19 @@ thumbnail buffer to be selected. \(fn &optional ARG APPEND DO-NOT-POP)" t nil) (autoload 'image-dired-show-all-from-dir "image-dired" "\ -Make a preview buffer for all images in DIR and display it. -If the number of files in DIR matching `image-file-name-regexp' -exceeds `image-dired-show-all-from-dir-max-files', a warning will be -displayed. +Make a thumbnail buffer for all images in DIR and display it. +Any file matching `image-file-name-regexp' is considered an image +file. + +If the number of image files in DIR exceeds +`image-dired-show-all-from-dir-max-files', ask for confirmation +before creating the thumbnail buffer. If that variable is nil, +never ask for confirmation. \(fn DIR)" t nil) (defalias 'image-dired 'image-dired-show-all-from-dir) -(define-obsolete-function-alias 'tumme 'image-dired "24.4") - (autoload 'image-dired-tag-files "image-dired" "\ Tag marked file(s) in Dired. With prefix ARG, tag file at point. @@ -18434,7 +18541,7 @@ Jump to thumbnail buffer." t nil) (autoload 'image-dired-minor-mode "image-dired" "\ Setup easy-to-use keybindings for the commands to be used in Dired mode. Note that n, p and <down> and <up> will be hijacked and bound to -`image-dired-dired-x-line'. +`image-dired-dired-next-line' and `image-dired-dired-previous-line'. This is a minor mode. If called interactively, toggle the `Image-Dired minor mode' mode. If the prefix argument is positive, @@ -18452,8 +18559,6 @@ disabled. \(fn &optional ARG)" t nil) -(define-obsolete-function-alias 'image-dired-setup-dired-keybindings 'image-dired-minor-mode "26.1") - (autoload 'image-dired-display-thumbs-append "image-dired" "\ Append thumbnails to `image-dired-thumbnail-buffer'." t nil) @@ -18486,6 +18591,15 @@ Edit comment and tags of current or marked image files. Edit comment and tags for all marked image files in an easy-to-use form." t nil) +(autoload 'image-dired-bookmark-jump "image-dired" "\ +Default bookmark handler for Image-Dired buffers. + +\(fn BOOKMARK)" nil nil) + +(define-obsolete-function-alias 'tumme #'image-dired "24.4") + +(define-obsolete-function-alias 'image-dired-setup-dired-keybindings #'image-dired-minor-mode "26.1") + (register-definition-prefixes "image-dired" '("image-dired-")) ;;;*** @@ -18493,7 +18607,7 @@ easy-to-use form." t nil) ;;;### (autoloads nil "image-file" "image-file.el" (0 0 0 0)) ;;; Generated autoloads from image-file.el -(defvar image-file-name-extensions (purecopy '("png" "jpeg" "jpg" "gif" "tiff" "tif" "xbm" "xpm" "pbm" "pgm" "ppm" "pnm" "svg")) "\ +(defvar image-file-name-extensions (purecopy '("png" "jpeg" "jpg" "gif" "tiff" "tif" "xbm" "xpm" "pbm" "pgm" "ppm" "pnm" "svg" "webp")) "\ A list of image-file filename extensions. Filenames having one of these extensions are considered image files, in addition to those matching `image-file-name-regexps'. @@ -19440,24 +19554,24 @@ Display a list of the options available when a misspelling is encountered. Selections are: -DIGIT: Replace the word with a digit offered in the *Choices* buffer. -SPC: Accept word this time. -`i': Accept word and insert into private dictionary. -`a': Accept word for this session. -`A': Accept word and place in `buffer-local dictionary'. -`r': Replace word with typed-in value. Rechecked. -`R': Replace word with typed-in value. Query-replaced in buffer. Rechecked. -`?': Show these commands. -`x': Exit spelling buffer. Move cursor to original point. -`X': Exit spelling buffer. Leaves cursor at the current point, and permits +\\`0'..\\`9' Replace the word with a digit offered in the *Choices* buffer. +\\`SPC' Accept word this time. +\\`i' Accept word and insert into private dictionary. +\\`a' Accept word for this session. +\\`A' Accept word and place in `buffer-local dictionary'. +\\`r' Replace word with typed-in value. Rechecked. +\\`R' Replace word with typed-in value. Query-replaced in buffer. Rechecked. +\\`?' Show these commands. +\\`x' Exit spelling buffer. Move cursor to original point. +\\`X' Exit spelling buffer. Leaves cursor at the current point, and permits the aborted check to be completed later. -`q': Quit spelling session (Kills ispell process). -`l': Look up typed-in replacement in alternate dictionary. Wildcards okay. -`u': Like `i', but the word is lower-cased first. -`m': Place typed-in value in personal dictionary, then recheck current word. -`C-l': Redraw screen. -`C-r': Recursive edit. -`C-z': Suspend Emacs or iconify frame." nil nil) +\\`q' Quit spelling session (Kills ispell process). +\\`l' Look up typed-in replacement in alternate dictionary. Wildcards okay. +\\`u' Like \\`i', but the word is lower-cased first. +\\`m' Place typed-in value in personal dictionary, then recheck current word. +\\`C-l' Redraw screen. +\\`C-r' Recursive edit. +\\`C-z' Suspend Emacs or iconify frame." nil nil) (autoload 'ispell-kill-ispell "ispell" "\ Kill current Ispell process (so that you may start a fresh one). @@ -19564,8 +19678,8 @@ Don't check spelling of message headers except the Subject field. Don't check included messages. To abort spell checking of a message region and send the message anyway, -use the `x' command. (Any subsequent regions will be checked.) -The `X' command aborts sending the message so that you can edit the buffer. +use the \\`x' command. (Any subsequent regions will be checked.) +The \\`X' command aborts sending the message so that you can edit the buffer. To spell-check whenever a message is sent, include the appropriate lines in your init file: @@ -19725,7 +19839,7 @@ one of the aforementioned options instead of using this mode. (dolist (name (list "node" "nodejs" "gjs" "rhino")) (add-to-list 'interpreter-mode-alist (cons (purecopy name) 'js-mode))) -(register-definition-prefixes "js" '("js-" "with-js")) +(register-definition-prefixes "js" '("js-")) ;;;*** @@ -20922,6 +21036,12 @@ current header, calls `mail-complete-function' and passes prefix ARG if any. ;;;### (autoloads nil "mailcap" "net/mailcap.el" (0 0 0 0)) ;;; Generated autoloads from net/mailcap.el +(autoload 'mailcap-mime-type-to-extension "mailcap" "\ +Return a file name extension based on a MIME-TYPE. +For instance, `image/png' will result in `png'. + +\(fn MIME-TYPE)" nil nil) + (register-definition-prefixes "mailcap" '("mailcap-")) ;;;*** @@ -21659,7 +21779,7 @@ perform the operation on all messages in that region. \(fn)" t nil) -(register-definition-prefixes "mh-folder" '("mh-")) +(register-definition-prefixes "mh-folder" '(":keymap" "mh-")) ;;;*** @@ -21695,7 +21815,7 @@ perform the operation on all messages in that region. ;;;### (autoloads nil "mh-letter" "mh-e/mh-letter.el" (0 0 0 0)) ;;; Generated autoloads from mh-e/mh-letter.el -(register-definition-prefixes "mh-letter" '("mh-")) +(register-definition-prefixes "mh-letter" '(":keymap" "mh-")) ;;;*** @@ -21730,7 +21850,7 @@ perform the operation on all messages in that region. ;;;### (autoloads nil "mh-search" "mh-e/mh-search.el" (0 0 0 0)) ;;; Generated autoloads from mh-e/mh-search.el -(register-definition-prefixes "mh-search" '("mh-")) +(register-definition-prefixes "mh-search" '(":keymap" "mh-")) ;;;*** @@ -21744,14 +21864,14 @@ perform the operation on all messages in that region. ;;;### (autoloads nil "mh-show" "mh-e/mh-show.el" (0 0 0 0)) ;;; Generated autoloads from mh-e/mh-show.el -(register-definition-prefixes "mh-show" '("mh-")) +(register-definition-prefixes "mh-show" '(":keymap" "mh-")) ;;;*** ;;;### (autoloads nil "mh-speed" "mh-e/mh-speed.el" (0 0 0 0)) ;;; Generated autoloads from mh-e/mh-speed.el -(register-definition-prefixes "mh-speed" '("mh-")) +(register-definition-prefixes "mh-speed" '(":keymap" "mh-")) ;;;*** @@ -22214,6 +22334,8 @@ specifies how the attachment is intended to be displayed. It can be either \"inline\" (displayed automatically within the message body) or \"attachment\" (separate from the body). +Also see the `mml-attach-file-at-the-end' variable. + If given a prefix interactively, no prompting will be done for the TYPE, DESCRIPTION or DISPOSITION values. Instead defaults will be computed and used. @@ -25758,6 +25880,14 @@ they are not by default assigned to keys." t nil) ;;;*** +;;;### (autoloads nil "pixel-fill" "textmodes/pixel-fill.el" (0 0 +;;;;;; 0 0)) +;;; Generated autoloads from textmodes/pixel-fill.el + +(register-definition-prefixes "pixel-fill" '("pixel-fill-")) + +;;;*** + ;;;### (autoloads nil "pixel-scroll" "pixel-scroll.el" (0 0 0 0)) ;;; Generated autoloads from pixel-scroll.el @@ -25790,6 +25920,38 @@ disabled. \(fn &optional ARG)" t nil) +(defvar pixel-scroll-precision-mode nil "\ +Non-nil if Pixel-Scroll-Precision mode is enabled. +See the `pixel-scroll-precision-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 `pixel-scroll-precision-mode'.") + +(custom-autoload 'pixel-scroll-precision-mode "pixel-scroll" nil) + +(autoload 'pixel-scroll-precision-mode "pixel-scroll" "\ +Toggle pixel scrolling. +When enabled, this minor mode allows to scroll the display +precisely, according to the turning of the mouse wheel. + +This is a minor mode. If called interactively, toggle the +`Pixel-Scroll-Precision mode' mode. If the prefix argument is +positive, enable the mode, and if it is zero or negative, disable the +mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the +mode if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate `(default-value \\='pixel-scroll-precision-mode)'. + +The mode's hook is called both when the mode is enabled and when it is +disabled. + +\(fn &optional ARG)" t nil) + (register-definition-prefixes "pixel-scroll" '("pixel-")) ;;;*** @@ -25870,10 +26032,26 @@ Prettify the current buffer with printed representation of a Lisp object." t nil Output the pretty-printed representation of OBJECT, any Lisp object. Quoting characters are printed as needed to make output that `read' can handle, whenever this is possible. + +This function does not apply special formatting rules for Emacs +Lisp code. See `pp-emacs-lisp-code' instead. + +By default, this function won't limit the line length of lists +and vectors. Bind `pp-use-max-width' to a non-nil value to do so. + Output stream is STREAM, or value of `standard-output' (which see). \(fn OBJECT &optional STREAM)" nil nil) +(autoload 'pp-display-expression "pp" "\ +Prettify and display EXPRESSION in an appropriate way, depending on length. +If LISP, format with `pp-emacs-lisp-code'; use `pp' otherwise. + +If a temporary buffer is needed for representation, it will be named +after OUT-BUFFER-NAME. + +\(fn EXPRESSION OUT-BUFFER-NAME &optional LISP)" nil nil) + (autoload 'pp-eval-expression "pp" "\ Evaluate EXPRESSION and pretty-print its value. Also add the value to the front of the list in the variable `values'. @@ -25899,6 +26077,12 @@ Ignores leading comment characters. \(fn ARG)" t nil) +(autoload 'pp-emacs-lisp-code "pp" "\ +Insert SEXP into the current buffer, formatted as Emacs Lisp code. +Use the `pp-max-width' variable to control the desired line length. + +\(fn SEXP)" nil nil) + (register-definition-prefixes "pp" '("pp-")) ;;;*** @@ -26573,13 +26757,25 @@ pattern to search for. Visit a file (with completion) in the current project. The filename at point (determined by `thing-at-point'), if any, -is available as part of \"future history\"." t nil) +is available as part of \"future history\". + +If INCLUDE-ALL is non-nil, or with prefix argument when called +interactively, include all files under the project root, except +for VCS directories listed in `vc-directory-exclusion-list'. + +\(fn &optional INCLUDE-ALL)" t nil) (autoload 'project-or-external-find-file "project" "\ Visit a file (with completion) in the current project or external roots. The filename at point (determined by `thing-at-point'), if any, -is available as part of \"future history\"." t nil) +is available as part of \"future history\". + +If INCLUDE-ALL is non-nil, or with prefix argument when called +interactively, include all files under the project root, except +for VCS directories listed in `vc-directory-exclusion-list'. + +\(fn &optional INCLUDE-ALL)" t nil) (autoload 'project-find-dir "project" "\ Start Dired in a directory inside the current project." t nil) @@ -27536,11 +27732,11 @@ If ARG is non-nil, instead prompt for connection parameters. (autoload 'rcirc-connect "rcirc" "\ Connect to SERVER. The arguments PORT, NICK, USER-NAME, FULL-NAME, PASSWORD, -ENCRYPTION, SERVER-ALIAS are interpreted as in +ENCRYPTION, CERTFP, SERVER-ALIAS are interpreted as in `rcirc-server-alist'. STARTUP-CHANNELS is a list of channels that are joined after authentication. -\(fn SERVER &optional PORT NICK USER-NAME FULL-NAME STARTUP-CHANNELS PASSWORD ENCRYPTION SERVER-ALIAS)" nil nil) +\(fn SERVER &optional PORT NICK USER-NAME FULL-NAME STARTUP-CHANNELS PASSWORD ENCRYPTION CERTFP SERVER-ALIAS)" nil nil) (defvar rcirc-track-minor-mode nil "\ Non-nil if Rcirc-Track minor mode is enabled. @@ -30272,6 +30468,29 @@ only these files will be asked to be saved. \(fn ARG)" nil nil) +(autoload 'server-stop-automatically "server" "\ +Automatically stop server as specified by ARG. + +If ARG is the symbol `empty', stop the server when it has no +remaining clients, no remaining unsaved file-visiting buffers, +and no running processes with a `query-on-exit' flag. + +If ARG is the symbol `delete-frame', ask the user when the last +frame is deleted whether each unsaved file-visiting buffer must +be saved and each running process with a `query-on-exit' flag +can be stopped, and if so, stop the server itself. + +If ARG is the symbol `kill-terminal', ask the user when the +terminal is killed with \\[save-buffers-kill-terminal] whether each unsaved file-visiting +buffer must be saved and each running process with a `query-on-exit' +flag can be stopped, and if so, stop the server itself. + +Any other value of ARG will cause this function to signal an error. + +This function is meant to be called from the user init file. + +\(fn ARG)" nil nil) + (register-definition-prefixes "server" '("server-")) ;;;*** @@ -30608,7 +30827,7 @@ If FUNCTION is non-nil, place point on the entry for FUNCTION (if any). \(fn GROUP &optional FUNCTION)" t nil) -(register-definition-prefixes "shortdoc" '("alist" "buffer" "define-short-documentation-group" "file" "hash-table" "list" "number" "overlay" "process" "regexp" "sequence" "shortdoc-" "string" "text-properties" "vector")) +(register-definition-prefixes "shortdoc" '("alist" "buffer" "define-short-documentation-group" "file" "hash-table" "keymaps" "list" "number" "overlay" "process" "regexp" "sequence" "shortdoc-" "string" "text-properties" "vector")) ;;;*** @@ -30748,6 +30967,8 @@ SKELETON is as defined under `skeleton-insert'. (function-put 'define-skeleton 'doc-string-elt '2) +(function-put 'define-skeleton 'lisp-indent-function 'defun) + (autoload 'skeleton-proxy-new "skeleton" "\ Insert SKELETON. Prefix ARG allows wrapping around words or regions (see `skeleton-insert'). @@ -31460,7 +31681,7 @@ installed through `spam-necessary-extra-headers'. \(fn &rest SYMBOLS)" t nil) -(register-definition-prefixes "spam" '("spam-")) +(register-definition-prefixes "spam" '(":keymap" "spam-")) ;;;*** @@ -32344,7 +32565,43 @@ If OMIT-NULLS, empty lines will be removed from the results. \(fn STRING &optional OMIT-NULLS)" nil nil) -(register-definition-prefixes "subr-x" '("and-let*" "hash-table-" "if-let*" "internal--" "named-let" "replace-region-contents" "string-" "thread-" "when-let*")) +(autoload 'ensure-empty-lines "subr-x" "\ +Ensure that there are LINES number of empty lines before point. +If LINES is nil or omitted, ensure that there is a single empty +line before point. + +If called interactively, LINES is given by the prefix argument. + +If there are more than LINES empty lines before point, the number +of empty lines is reduced to LINES. + +If point is not at the beginning of a line, a newline character +is inserted before adjusting the number of empty lines. + +\(fn &optional LINES)" t nil) + +(autoload 'string-pixel-width "subr-x" "\ +Return the width of STRING in pixels. + +\(fn STRING)" nil nil) + +(autoload 'string-glyph-split "subr-x" "\ +Split STRING into a list of strings representing separate glyphs. +This takes into account combining characters and grapheme clusters. + +\(fn STRING)" nil nil) + +(autoload 'add-display-text-property "subr-x" "\ +Add display property PROP with VALUE to the text from START to END. +If any text in the region has a non-nil `display' property, those +properties are retained. + +If OBJECT is non-nil, it should be a string or a buffer. If nil, +this defaults to the current buffer. + +\(fn START END PROP VALUE &optional OBJECT)" nil nil) + +(register-definition-prefixes "subr-x" '("and-let*" "hash-table-" "if-let*" "internal--" "named-let" "replace-region-contents" "string-" "thread-" "when-let*" "with-memoization")) ;;;*** @@ -34978,7 +35235,7 @@ Add archive file name handler to `file-name-handler-alist'." (when tramp-archive ;;;;;; 0)) ;;; Generated autoloads from net/tramp-compat.el -(register-definition-prefixes "tramp-compat" '("tramp-")) +(register-definition-prefixes "tramp-compat" '("tramp-compat-")) ;;;*** @@ -35064,7 +35321,7 @@ Add archive file name handler to `file-name-handler-alist'." (when tramp-archive ;;;### (autoloads nil "trampver" "net/trampver.el" (0 0 0 0)) ;;; Generated autoloads from net/trampver.el -(push (purecopy '(tramp 2 5 2 -1)) package--builtin-versions) +(push (purecopy '(tramp 2 6 0 -1)) package--builtin-versions) (register-definition-prefixes "trampver" '("tramp-")) @@ -35387,65 +35644,25 @@ You might need to set `uce-mail-reader' before using this. ;;;;;; (0 0 0 0)) ;;; Generated autoloads from international/ucs-normalize.el -(autoload 'ucs-normalize-NFD-region "ucs-normalize" "\ -Normalize the current region by the Unicode NFD. - -\(fn FROM TO)" t nil) - -(autoload 'ucs-normalize-NFD-string "ucs-normalize" "\ -Normalize the string STR by the Unicode NFD. - -\(fn STR)" nil nil) - -(autoload 'ucs-normalize-NFC-region "ucs-normalize" "\ -Normalize the current region by the Unicode NFC. - -\(fn FROM TO)" t nil) - -(autoload 'ucs-normalize-NFC-string "ucs-normalize" "\ -Normalize the string STR by the Unicode NFC. - -\(fn STR)" nil nil) - -(autoload 'ucs-normalize-NFKD-region "ucs-normalize" "\ -Normalize the current region by the Unicode NFKD. - -\(fn FROM TO)" t nil) - -(autoload 'ucs-normalize-NFKD-string "ucs-normalize" "\ -Normalize the string STR by the Unicode NFKD. - -\(fn STR)" nil nil) - -(autoload 'ucs-normalize-NFKC-region "ucs-normalize" "\ -Normalize the current region by the Unicode NFKC. - -\(fn FROM TO)" t nil) - -(autoload 'ucs-normalize-NFKC-string "ucs-normalize" "\ -Normalize the string STR by the Unicode NFKC. - -\(fn STR)" nil nil) - -(autoload 'ucs-normalize-HFS-NFD-region "ucs-normalize" "\ -Normalize the current region by the Unicode NFD and Mac OS's HFS Plus. - -\(fn FROM TO)" t nil) - -(autoload 'ucs-normalize-HFS-NFD-string "ucs-normalize" "\ -Normalize the string STR by the Unicode NFD and Mac OS's HFS Plus. +(autoload 'string-glyph-compose "ucs-normalize" "\ +Compose STRING according to the Unicode NFC. +This returns a new string obtained by canonical decomposition +of STRING (see `ucs-normalize-NFC-string') followed by canonical +composition, a.k.a. the \"Unicode Normalization Form C\" of STRING. +For instance: -\(fn STR)" nil nil) + (string-glyph-compose \"Å\") => \"Å\" -(autoload 'ucs-normalize-HFS-NFC-region "ucs-normalize" "\ -Normalize the current region by the Unicode NFC and Mac OS's HFS Plus. +\(fn STRING)" nil nil) -\(fn FROM TO)" t nil) +(autoload 'string-glyph-decompose "ucs-normalize" "\ +Decompose STRING according to the Unicode NFD. +This returns a new string that is the canonical decomposition of STRING, +a.k.a. the \"Unicode Normalization Form D\" of STRING. For instance: -(autoload 'ucs-normalize-HFS-NFC-string "ucs-normalize" "\ -Normalize the string STR by the Unicode NFC and Mac OS's HFS Plus. + (ucs-normalize-NFD-string \"Å\") => \"Å\" -\(fn STR)" nil nil) +\(fn STRING)" nil nil) (register-definition-prefixes "ucs-normalize" '("ucs-normalize-" "utf-8-hfs")) @@ -36309,7 +36526,7 @@ Report an ERROR that occurred while unlocking a file. \(fn ERROR)" nil nil) -(register-definition-prefixes "userlock" '("ask-user-about-" "file-" "userlock--")) +(register-definition-prefixes "userlock" '("ask-user-about-" "file-" "userlock--check-content-unchanged")) ;;;*** @@ -36439,6 +36656,10 @@ For old-style locking-based version control systems, like RCS: If every file is locked by you and unchanged, unlock them. If every file is locked by someone else, offer to steal the lock. +When using this command to register a new file (or files), it +will automatically deduce which VC repository to register it +with, using the most specific one. + \(fn VERBOSE)" t nil) (autoload 'vc-register "vc" "\ @@ -37093,7 +37314,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 2021 9 23 89128420)) package--builtin-versions) +(push (purecopy '(verilog-mode 2021 10 14 127365406)) package--builtin-versions) (autoload 'verilog-mode "verilog-mode" "\ Major mode for editing Verilog code. @@ -39018,7 +39239,7 @@ where PREFIX is a prefix key and MODIFIERS is either a list of modifiers or a single modifier. If PREFIX is `none', no prefix is used. If MODIFIERS is `none', the keybindings are directly bound to the arrow keys. -Default value of PREFIX is `C-x' and MODIFIERS is `shift'. +Default value of PREFIX is \\`C-x' and MODIFIERS is `shift'. \(fn &optional PREFIX MODIFIERS)" t nil) @@ -39241,15 +39462,24 @@ 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 3 0)) package--builtin-versions) +(push (purecopy '(xref 1 3 2)) package--builtin-versions) (autoload 'xref-find-backend "xref" nil nil nil) -(autoload 'xref-pop-marker-stack "xref" "\ -Pop back to where \\[xref-find-definitions] was last invoked." t nil) +(define-obsolete-function-alias 'xref-pop-marker-stack #'xref-go-back "29.1") + +(autoload 'xref-go-back "xref" "\ +Go back to the previous position in xref history. +To undo, use \\[xref-go-forward]." t nil) + +(autoload 'xref-go-forward "xref" "\ +Got to the point where a previous \\[xref-go-back] was invoked." t nil) (autoload 'xref-marker-stack-empty-p "xref" "\ -Return t if the marker stack is empty; nil otherwise." nil nil) +Whether the xref back-history is empty." nil nil) + +(autoload 'xref-forward-history-empty-p "xref" "\ +Whether the xref forward-history is empty." nil nil) (autoload 'xref-find-definitions "xref" "\ Find the definition of the identifier at point. @@ -39261,7 +39491,7 @@ definition for IDENTIFIER, display it in the selected window. Otherwise, display the list of the possible definitions in a buffer where the user can select from the list. -Use \\[xref-pop-marker-stack] to return back to where you invoked this command. +Use \\[xref-go-back] to return back to where you invoked this command. \(fn IDENTIFIER)" t nil) @@ -39305,7 +39535,8 @@ output of this command when the backend is etags. \(fn PATTERN)" t nil) (define-key esc-map "." #'xref-find-definitions) - (define-key esc-map "," #'xref-pop-marker-stack) + (define-key esc-map "," #'xref-go-back) + (define-key esc-map [?\C-,] #'xref-go-forward) (define-key esc-map "?" #'xref-find-references) (define-key esc-map [?\C-.] #'xref-find-apropos) (define-key ctl-x-4-map "." #'xref-find-definitions-other-window) @@ -39415,6 +39646,33 @@ Interactively, URL defaults to the string looking like a url around point. ;;;*** +;;;### (autoloads nil "yank-media" "yank-media.el" (0 0 0 0)) +;;; Generated autoloads from yank-media.el + +(autoload 'yank-media "yank-media" "\ +Yank media (images, HTML and the like) from the clipboard. +This command depends on the current major mode having support for +accepting the media type. The mode has to register itself using +the `yank-media-handler' mechanism. + +Also see `yank-media-types' for a command that lets you explore +all the different selection types." t nil) + +(autoload 'yank-media-handler "yank-media" "\ +Register HANDLER for dealing with `yank-media' actions for TYPES. +TYPES should be a MIME media type symbol, a regexp, or a list +that can contain both symbols and regexps. + +HANDLER is a function that will be called with two arguments: The +MIME type (a symbol on the form `image/png') and the selection +data (a string). + +\(fn TYPES HANDLER)" nil nil) + +(register-definition-prefixes "yank-media" '("yank-media-")) + +;;;*** + ;;;### (autoloads nil "yenc" "mail/yenc.el" (0 0 0 0)) ;;; Generated autoloads from mail/yenc.el @@ -39449,12 +39707,10 @@ Zone out, completely." t nil) ;;;### (autoloads nil nil ("abbrev.el" "bindings.el" "buff-menu.el" ;;;;;; "button.el" "calc/calc-aent.el" "calc/calc-embed.el" "calc/calc-misc.el" -;;;;;; "calc/calc-yank.el" "calendar/cal-loaddefs.el" "calendar/diary-loaddefs.el" -;;;;;; "calendar/hol-loaddefs.el" "case-table.el" "cedet/ede/base.el" -;;;;;; "cedet/ede/config.el" "cedet/ede/cpp-root.el" "cedet/ede/custom.el" -;;;;;; "cedet/ede/dired.el" "cedet/ede/emacs.el" "cedet/ede/files.el" -;;;;;; "cedet/ede/generic.el" "cedet/ede/linux.el" "cedet/ede/locate.el" -;;;;;; "cedet/ede/make.el" "cedet/ede/shell.el" "cedet/ede/speedbar.el" +;;;;;; "calc/calc-yank.el" "case-table.el" "cedet/ede/cpp-root.el" +;;;;;; "cedet/ede/custom.el" "cedet/ede/dired.el" "cedet/ede/emacs.el" +;;;;;; "cedet/ede/files.el" "cedet/ede/generic.el" "cedet/ede/linux.el" +;;;;;; "cedet/ede/locate.el" "cedet/ede/make.el" "cedet/ede/speedbar.el" ;;;;;; "cedet/ede/system.el" "cedet/ede/util.el" "cedet/semantic/analyze.el" ;;;;;; "cedet/semantic/analyze/complete.el" "cedet/semantic/analyze/refs.el" ;;;;;; "cedet/semantic/bovine.el" "cedet/semantic/bovine/c-by.el" @@ -39486,8 +39742,8 @@ Zone out, completely." t nil) ;;;;;; "cedet/srecode/insert.el" "cedet/srecode/java.el" "cedet/srecode/map.el" ;;;;;; "cedet/srecode/mode.el" "cedet/srecode/srt-wy.el" "cedet/srecode/srt.el" ;;;;;; "cedet/srecode/template.el" "cedet/srecode/texi.el" "composite.el" -;;;;;; "cus-face.el" "cus-start.el" "custom.el" "dired-aux.el" "dired-x.el" -;;;;;; "electric.el" "emacs-lisp/backquote.el" "emacs-lisp/byte-run.el" +;;;;;; "cus-face.el" "cus-load.el" "cus-start.el" "custom.el" "dired-aux.el" +;;;;;; "dired-x.el" "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/easymenu.el" "emacs-lisp/eieio-compat.el" ;;;;;; "emacs-lisp/eieio-custom.el" "emacs-lisp/eieio-opt.el" "emacs-lisp/float-sup.el" @@ -39509,44 +39765,46 @@ Zone out, completely." t nil) ;;;;;; "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" "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" +;;;;;; "eshell/em-xtra.el" "eshell/esh-groups.el" "faces.el" "files.el" +;;;;;; "finder-inf.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/emoji-zwj.el" "international/eucjp-ms.el" -;;;;;; "international/iso-transl.el" "international/mule-cmds.el" -;;;;;; "international/mule-conf.el" "international/mule.el" "international/uni-bidi.el" -;;;;;; "international/uni-brackets.el" "international/uni-category.el" -;;;;;; "international/uni-combining.el" "international/uni-comment.el" -;;;;;; "international/uni-decimal.el" "international/uni-decomposition.el" -;;;;;; "international/uni-digit.el" "international/uni-lowercase.el" -;;;;;; "international/uni-mirrored.el" "international/uni-name.el" -;;;;;; "international/uni-numeric.el" "international/uni-old-name.el" -;;;;;; "international/uni-special-lowercase.el" "international/uni-special-titlecase.el" -;;;;;; "international/uni-special-uppercase.el" "international/uni-titlecase.el" -;;;;;; "international/uni-uppercase.el" "isearch.el" "jit-lock.el" -;;;;;; "jka-cmpr-hook.el" "language/burmese.el" "language/cham.el" -;;;;;; "language/chinese.el" "language/cyrillic.el" "language/czech.el" -;;;;;; "language/english.el" "language/ethiopic.el" "language/european.el" -;;;;;; "language/georgian.el" "language/greek.el" "language/hebrew.el" -;;;;;; "language/indian.el" "language/japanese.el" "language/khmer.el" -;;;;;; "language/korean.el" "language/lao.el" "language/misc-lang.el" -;;;;;; "language/romanian.el" "language/sinhala.el" "language/slovak.el" -;;;;;; "language/tai-viet.el" "language/thai.el" "language/tibetan.el" -;;;;;; "language/utf-8-lang.el" "language/vietnamese.el" "ldefs-boot.el" -;;;;;; "leim/ja-dic/ja-dic.el" "leim/leim-list.el" "leim/quail/4Corner.el" -;;;;;; "leim/quail/ARRAY30.el" "leim/quail/CCDOSPY.el" "leim/quail/CTLau-b5.el" -;;;;;; "leim/quail/CTLau.el" "leim/quail/ECDICT.el" "leim/quail/ETZY.el" -;;;;;; "leim/quail/PY-b5.el" "leim/quail/PY.el" "leim/quail/Punct-b5.el" -;;;;;; "leim/quail/Punct.el" "leim/quail/QJ-b5.el" "leim/quail/QJ.el" -;;;;;; "leim/quail/SW.el" "leim/quail/TONEPY.el" "leim/quail/ZIRANMA.el" -;;;;;; "leim/quail/ZOZY.el" "leim/quail/arabic.el" "leim/quail/cham.el" -;;;;;; "leim/quail/compose.el" "leim/quail/croatian.el" "leim/quail/cyril-jis.el" -;;;;;; "leim/quail/cyrillic.el" "leim/quail/czech.el" "leim/quail/georgian.el" -;;;;;; "leim/quail/greek.el" "leim/quail/hanja-jis.el" "leim/quail/hanja.el" -;;;;;; "leim/quail/hanja3.el" "leim/quail/hebrew.el" "leim/quail/ipa-praat.el" -;;;;;; "leim/quail/latin-alt.el" "leim/quail/latin-ltx.el" "leim/quail/latin-post.el" -;;;;;; "leim/quail/latin-pre.el" "leim/quail/persian.el" "leim/quail/programmer-dvorak.el" +;;;;;; "international/emoji-labels.el" "international/emoji-zwj.el" +;;;;;; "international/eucjp-ms.el" "international/iso-transl.el" +;;;;;; "international/mule-cmds.el" "international/mule-conf.el" +;;;;;; "international/mule.el" "international/uni-bidi.el" "international/uni-brackets.el" +;;;;;; "international/uni-category.el" "international/uni-combining.el" +;;;;;; "international/uni-comment.el" "international/uni-decimal.el" +;;;;;; "international/uni-decomposition.el" "international/uni-digit.el" +;;;;;; "international/uni-lowercase.el" "international/uni-mirrored.el" +;;;;;; "international/uni-name.el" "international/uni-numeric.el" +;;;;;; "international/uni-old-name.el" "international/uni-special-lowercase.el" +;;;;;; "international/uni-special-titlecase.el" "international/uni-special-uppercase.el" +;;;;;; "international/uni-titlecase.el" "international/uni-uppercase.el" +;;;;;; "isearch.el" "jit-lock.el" "jka-cmpr-hook.el" "keymap.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" "language/indian.el" +;;;;;; "language/japanese.el" "language/khmer.el" "language/korean.el" +;;;;;; "language/lao.el" "language/misc-lang.el" "language/romanian.el" +;;;;;; "language/sinhala.el" "language/slovak.el" "language/tai-viet.el" +;;;;;; "language/thai.el" "language/tibetan.el" "language/utf-8-lang.el" +;;;;;; "language/vietnamese.el" "ldefs-boot.el" "leim/ja-dic/ja-dic.el" +;;;;;; "leim/leim-list.el" "leim/quail/4Corner.el" "leim/quail/ARRAY30.el" +;;;;;; "leim/quail/CCDOSPY.el" "leim/quail/CTLau-b5.el" "leim/quail/CTLau.el" +;;;;;; "leim/quail/ECDICT.el" "leim/quail/ETZY.el" "leim/quail/PY-b5.el" +;;;;;; "leim/quail/PY.el" "leim/quail/Punct-b5.el" "leim/quail/Punct.el" +;;;;;; "leim/quail/QJ-b5.el" "leim/quail/QJ.el" "leim/quail/SW.el" +;;;;;; "leim/quail/TONEPY.el" "leim/quail/ZIRANMA.el" "leim/quail/ZOZY.el" +;;;;;; "leim/quail/arabic.el" "leim/quail/cham.el" "leim/quail/compose.el" +;;;;;; "leim/quail/croatian.el" "leim/quail/cyril-jis.el" "leim/quail/cyrillic.el" +;;;;;; "leim/quail/czech.el" "leim/quail/georgian.el" "leim/quail/greek.el" +;;;;;; "leim/quail/hanja-jis.el" "leim/quail/hanja.el" "leim/quail/hanja3.el" +;;;;;; "leim/quail/hebrew.el" "leim/quail/ipa-praat.el" "leim/quail/latin-alt.el" +;;;;;; "leim/quail/latin-ltx.el" "leim/quail/latin-post.el" "leim/quail/latin-pre.el" +;;;;;; "leim/quail/persian.el" "leim/quail/programmer-dvorak.el" ;;;;;; "leim/quail/py-punct.el" "leim/quail/pypunct-b5.el" "leim/quail/quick-b5.el" ;;;;;; "leim/quail/quick-cns.el" "leim/quail/rfc1345.el" "leim/quail/sami.el" ;;;;;; "leim/quail/sgml-input.el" "leim/quail/slovak.el" "leim/quail/symbol-ksc.el" @@ -39555,14 +39813,13 @@ Zone out, completely." t nil) ;;;;;; "loadup.el" "mail/blessmail.el" "mail/rmailedit.el" "mail/rmailkwd.el" ;;;;;; "mail/rmailmm.el" "mail/rmailmsc.el" "mail/rmailsort.el" ;;;;;; "mail/rmailsum.el" "mail/undigest.el" "menu-bar.el" "mh-e/mh-gnus.el" -;;;;;; "mh-e/mh-loaddefs.el" "minibuffer.el" "mouse.el" "net/tramp-loaddefs.el" -;;;;;; "newcomment.el" "obarray.el" "org/ob-core.el" "org/ob-lob.el" -;;;;;; "org/ob-matlab.el" "org/ob-tangle.el" "org/ob.el" "org/ol-bbdb.el" -;;;;;; "org/ol-irc.el" "org/ol.el" "org/org-archive.el" "org/org-attach.el" -;;;;;; "org/org-clock.el" "org/org-colview.el" "org/org-compat.el" -;;;;;; "org/org-datetree.el" "org/org-duration.el" "org/org-element.el" -;;;;;; "org/org-feed.el" "org/org-footnote.el" "org/org-goto.el" -;;;;;; "org/org-id.el" "org/org-indent.el" "org/org-install.el" +;;;;;; "minibuffer.el" "mouse.el" "newcomment.el" "obarray.el" "org/ob-core.el" +;;;;;; "org/ob-lob.el" "org/ob-matlab.el" "org/ob-tangle.el" "org/ob.el" +;;;;;; "org/ol-bbdb.el" "org/ol-irc.el" "org/ol.el" "org/org-archive.el" +;;;;;; "org/org-attach.el" "org/org-clock.el" "org/org-colview.el" +;;;;;; "org/org-compat.el" "org/org-datetree.el" "org/org-duration.el" +;;;;;; "org/org-element.el" "org/org-feed.el" "org/org-footnote.el" +;;;;;; "org/org-goto.el" "org/org-id.el" "org/org-indent.el" "org/org-install.el" ;;;;;; "org/org-keys.el" "org/org-lint.el" "org/org-list.el" "org/org-macs.el" ;;;;;; "org/org-mobile.el" "org/org-num.el" "org/org-plot.el" "org/org-refile.el" ;;;;;; "org/org-table.el" "org/org-timer.el" "org/ox-ascii.el" "org/ox-beamer.el" diff --git a/lisp/leim/quail/hangul.el b/lisp/leim/quail/hangul.el index c03e86b33c0..d069b5b68e1 100644 --- a/lisp/leim/quail/hangul.el +++ b/lisp/leim/quail/hangul.el @@ -429,7 +429,7 @@ When a Korean input method is off, convert the following hangul character." (hangul3-input-method-jong char)) (t (setq hangul-queue (make-vector 6 0)) - (insert (decode-char 'ucs char)) + (insert char) (move-overlay quail-overlay (point) (point)))))) (defun hangul3-input-method (key) @@ -476,7 +476,7 @@ When a Korean input method is off, convert the following hangul character." (hangul3-input-method-jong char)) (t (setq hangul-queue (make-vector 6 0)) - (insert (decode-char 'ucs char)) + (insert char) (move-overlay quail-overlay (point) (point)))))) (defun hangul390-input-method (key) diff --git a/lisp/leim/quail/ipa.el b/lisp/leim/quail/ipa.el index c25687574ed..ba6ea938425 100644 --- a/lisp/leim/quail/ipa.el +++ b/lisp/leim/quail/ipa.el @@ -278,10 +278,10 @@ string." (list (apply #'vector (mapcar - #'(lambda (entry) - (cl-assert (char-or-string-p entry) t) - (format "%s%s" to-prepend - (if (integerp entry) (string entry) entry))) + (lambda (entry) + (cl-assert (char-or-string-p entry) t) + (format "%s%s" to-prepend + (if (integerp entry) (string entry) entry))) quail-keymap)))) (defun ipa-x-sampa-underscore-implosive (input-string length) diff --git a/lisp/leim/quail/latin-post.el b/lisp/leim/quail/latin-post.el index 8329fff82ed..0e1afba1a34 100644 --- a/lisp/leim/quail/latin-post.el +++ b/lisp/leim/quail/latin-post.el @@ -215,7 +215,15 @@ Doubling the postfix separates the letter and postfix: e.g. a\\='\\=' -> a\\=' others | / | s/ -> ß Doubling the postfix separates the letter and postfix: e.g. a\\='\\=' -> a\\=' -" nil t nil nil nil nil nil nil nil nil t) +" + '(("\C-?" . quail-delete-last-char) + (">" . quail-next-translation) + ("\C-f" . quail-next-translation) + ([right] . quail-next-translation) + ("<" . quail-prev-translation) + ("\C-b" . quail-prev-translation) + ([left] . quail-prev-translation)) + t nil nil nil nil nil nil nil nil t) (quail-define-rules ("A'" ?Á) @@ -246,9 +254,9 @@ Doubling the postfix separates the letter and postfix: e.g. a\\='\\=' -> a\\=' ("R'" ?Ŕ) ("R~" ?Ř) ("S'" ?Ś) - ("S," ?Ş) + ("S," "ŞȘ") ; the second variant is for Romanian ("S~" ?Š) - ("T," ?Ţ) + ("T," "ŢȚ") ; the second variant is for Romanian ("T~" ?Ť) ("U'" ?Ú) ("U:" ?Ű) @@ -286,10 +294,10 @@ Doubling the postfix separates the letter and postfix: e.g. a\\='\\=' -> a\\=' ("r'" ?ŕ) ("r~" ?ř) ("s'" ?ś) - ("s," ?ş) + ("s," "şș") ; the second variant is for Romanian ("s/" ?ß) ("s~" ?š) - ("t," ?ţ) + ("t," "ţț") ; the second variant is for Romanian ("t~" ?ť) ("u'" ?ú) ("u:" ?ű) diff --git a/lisp/leim/quail/latin-pre.el b/lisp/leim/quail/latin-pre.el index 3b9c942a8c1..3492de5fbae 100644 --- a/lisp/leim/quail/latin-pre.el +++ b/lisp/leim/quail/latin-pre.el @@ -497,7 +497,15 @@ Key translation rules are: cedilla | \\=` | \\=`c -> ç \\=`e -> ?ę misc | \\=' \\=` ~ | \\='d -> đ \\=`l -> ł \\=`z -> ż ~o -> ő ~u -> ű symbol | ~ | \\=`. -> ˙ ~~ -> ˘ ~. -> ?¸ -" nil t nil nil nil nil nil nil nil nil t) +" + '(("\C-?" . quail-delete-last-char) + (">" . quail-next-translation) + ("\C-f" . quail-next-translation) + ([right] . quail-next-translation) + ("<" . quail-prev-translation) + ("\C-b" . quail-prev-translation) + ([left] . quail-prev-translation)) + t nil nil nil nil nil nil nil nil t) (quail-define-rules ("'A" ?Á) @@ -532,15 +540,15 @@ Key translation rules are: ("`C" ?Ç) ("`E" ?Ę) ("`L" ?Ł) - ("`S" ?Ş) - ("`T" ?Ţ) + ("`S" "ŞȘ") + ("`T" "ŢȚ") ; the second variant is for Romanian ("`Z" ?Ż) ("`a" ?ą) ("`l" ?ł) ("`c" ?ç) ("`e" ?ę) - ("`s" ?ş) - ("`t" ?ţ) + ("`s" "şș") + ("`t" "ţț") ; the second variant is for Romanian ("`z" ?ż) ("``" ?Ş) ("`." ?˙) diff --git a/lisp/loadup.el b/lisp/loadup.el index 4da0ff73851..71d6a501b94 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -131,6 +131,7 @@ (load "emacs-lisp/byte-run") (load "emacs-lisp/backquote") (load "subr") +(load "keymap") ;; Do it after subr, since both after-load-functions and add-hook are ;; implemented in subr.el. @@ -302,6 +303,11 @@ (load "term/common-win") (load "term/x-win"))) +(if (featurep 'haiku) + (progn + (load "term/common-win") + (load "term/haiku-win"))) + (if (or (eq system-type 'windows-nt) (featurep 'w32)) (progn @@ -559,6 +565,7 @@ lost after dumping"))) (delete-file output))))) ;; Recompute NAME now, so that it isn't set when we dump. (if (not (or (eq system-type 'ms-dos) + (eq system-type 'haiku) ;; BFS doesn't support hard links ;; Don't bother adding another name if we're just ;; building bootstrap-emacs. (member dump-mode '("pbootstrap" "bootstrap")))) diff --git a/lisp/ls-lisp.el b/lisp/ls-lisp.el index 82153ff0adb..25d196392ab 100644 --- a/lisp/ls-lisp.el +++ b/lisp/ls-lisp.el @@ -337,18 +337,7 @@ are also supported; unsupported long options are silently ignored." (ls-lisp-insert-directory file switches (ls-lisp-time-index switches) nil full-directory-p)) - (signal (car err) (cdr err))))) - ;; Try to insert the amount of free space. - (save-excursion - (goto-char (point-min)) - ;; First find the line to put it on. - (when (re-search-forward "^total" nil t) - (let ((available (get-free-disk-space "."))) - (when available - ;; Replace "total" with "total used", to avoid confusion. - (replace-match "total used in directory") - (end-of-line) - (insert " available " available))))))))) + (signal (car err) (cdr err))))))))) (advice-add 'insert-directory :around #'ls-lisp--insert-directory) (defun ls-lisp-insert-directory diff --git a/lisp/mail/feedmail.el b/lisp/mail/feedmail.el index fe686cb6f86..32edc292619 100644 --- a/lisp/mail/feedmail.el +++ b/lisp/mail/feedmail.el @@ -2336,19 +2336,14 @@ mapped to mostly alphanumerics for safety." ;; from a similar function in mail-utils.el (defun feedmail-rfc822-time-zone (time) + (declare (obsolete format-time-string "29.1")) (feedmail-say-debug ">in-> feedmail-rfc822-time-zone %s" time) - (let* ((sec (or (car (current-time-zone time)) 0)) - (absmin (/ (abs sec) 60))) - (format "%c%02d%02d" (if (< sec 0) ?- ?+) (/ absmin 60) (% absmin 60)))) + (format-time-string "%z" time)) (defun feedmail-rfc822-date (arg-time) (feedmail-say-debug ">in-> feedmail-rfc822-date %s" arg-time) - (let ((time (or arg-time (current-time))) - (system-time-locale "C")) - (concat - (format-time-string "%a, %e %b %Y %T " time) - (feedmail-rfc822-time-zone time) - ))) + (let ((system-time-locale "C")) + (format-time-string "%a, %e %b %Y %T %z" arg-time))) (defun feedmail-send-it-immediately-wrapper () "Wrapper to catch skip-me-i." @@ -2847,10 +2842,9 @@ probably not appropriate for you." (if (and (not feedmail-queue-use-send-time-for-message-id) maybe-file) (setq date-time (file-attribute-modification-time (file-attributes maybe-file)))) - (format "<%d-%s%s%s>" + (format "<%d-%s%s>" (mod (random) 10000) - (format-time-string "%a%d%b%Y%H%M%S" date-time) - (feedmail-rfc822-time-zone date-time) + (format-time-string "%a%d%b%Y%H%M%S%z" date-time) end-stuff)) ) diff --git a/lisp/mail/footnote.el b/lisp/mail/footnote.el index 716348a9c19..ef040ca90b3 100644 --- a/lisp/mail/footnote.el +++ b/lisp/mail/footnote.el @@ -898,7 +898,7 @@ play around with the following keys: (make-local-variable 'footnote-end-tag) (make-local-variable 'adaptive-fill-function) - ;; Filladapt was an XEmacs package which is now in GNU ELPA. + ;; Filladapt is a GNU ELPA package. (when (boundp 'filladapt-token-table) ;; add tokens to filladapt to match footnotes ;; 1] xxxxxxxxxxx x x x or [1] x x x x x x x diff --git a/lisp/mail/mail-utils.el b/lisp/mail/mail-utils.el index 3eb3ccb93de..f1b0590bec7 100644 --- a/lisp/mail/mail-utils.el +++ b/lisp/mail/mail-utils.el @@ -368,19 +368,12 @@ matches may be returned from the message body." labels) (defun mail-rfc822-time-zone (time) - (let* ((sec (or (car (current-time-zone time)) 0)) - (absmin (/ (abs sec) 60))) - (format "%c%02d%02d" (if (< sec 0) ?- ?+) (/ absmin 60) (% absmin 60)))) + (declare (obsolete format-time-string "29.1")) + (format-time-string "%z" time)) (defun mail-rfc822-date () - (let* ((time (current-time)) - (s (current-time-string time))) - (string-match "[^ ]+ +\\([^ ]+\\) +\\([^ ]+\\) \\([^ ]+\\) \\([^ ]+\\)" s) - (concat (substring s (match-beginning 2) (match-end 2)) " " - (substring s (match-beginning 1) (match-end 1)) " " - (substring s (match-beginning 4) (match-end 4)) " " - (substring s (match-beginning 3) (match-end 3)) " " - (mail-rfc822-time-zone time)))) + (let ((system-time-locale "C")) + (format-time-string "%-d %b %Y %T %z"))) (defun mail-mbox-from () "Return an mbox \"From \" line for the current message. diff --git a/lisp/mail/rmail.el b/lisp/mail/rmail.el index 9fbc9ba180f..afcb7f39bf2 100644 --- a/lisp/mail/rmail.el +++ b/lisp/mail/rmail.el @@ -4125,10 +4125,8 @@ typically for purposes of moderating a list." "A regexp that matches the separator before the text of a failed message.") (defvar mail-mime-unsent-header "^Content-Type: message/rfc822 *$" - "A regexp that matches the header of a MIME body part with a failed message.") + "A regexp that matches the header of a MIME body part with a failed message.") -;; This is a cut-down version of rmail-clear-headers from Emacs 22. -;; It doesn't have the same functionality, hence the name change. (defun rmail-delete-headers (regexp) "Delete any mail headers matching REGEXP. The message should be narrowed to just the headers." @@ -4136,10 +4134,6 @@ The message should be narrowed to just the headers." (goto-char (point-min)) (while (re-search-forward regexp nil t) (beginning-of-line) - ;; This code from Emacs 22 doesn't seem right, since r-n-h is - ;; just for display. -;;; (if (looking-at rmail-nonignored-headers) -;;; (forward-line 1) (delete-region (point) (save-excursion (if (re-search-forward "\n[^ \t]" nil t) diff --git a/lisp/mail/rmailkwd.el b/lisp/mail/rmailkwd.el index 58a8eb7a370..d8fcc1c0a99 100644 --- a/lisp/mail/rmailkwd.el +++ b/lisp/mail/rmailkwd.el @@ -74,12 +74,9 @@ according to the choice made, and returns a symbol." (rmail-summary-exists) (and (setq old (rmail-get-keywords)) (mapc #'rmail-make-label (split-string old ", ")))) - (completing-read (concat prompt - (if rmail-last-label - (concat " (default " - (symbol-name rmail-last-label) - "): ") - ": ")) + (completing-read (format-prompt prompt + (and rmail-last-label + (symbol-name rmail-last-label))) rmail-label-obarray nil nil)))) diff --git a/lisp/mail/rmailmm.el b/lisp/mail/rmailmm.el index 99bff66657b..66a1e9a4dbd 100644 --- a/lisp/mail/rmailmm.el +++ b/lisp/mail/rmailmm.el @@ -254,7 +254,7 @@ TRUNCATED is non-nil if the text of this entity was truncated.")) (unless (y-or-n-p "This entity is truncated; save anyway? ") (error "Aborted"))) (setq filename (expand-file-name - (read-file-name (format "Save as (default: %s): " filename) + (read-file-name (format-prompt "Save as" filename) directory (expand-file-name filename directory)) directory)) diff --git a/lisp/mail/rmailout.el b/lisp/mail/rmailout.el index 91f86a234d4..1f5bb2d9f1b 100644 --- a/lisp/mail/rmailout.el +++ b/lisp/mail/rmailout.el @@ -107,9 +107,8 @@ error: %S\n" (read-file (expand-file-name (read-file-name - (concat "Output message to mail file (default " - (file-name-nondirectory default-file) - "): ") + (format-prompt "Output message to mail file" + (file-name-nondirectory default-file)) (file-name-directory default-file) (abbreviate-file-name default-file)) (file-name-directory default-file)))) diff --git a/lisp/mail/rmailsum.el b/lisp/mail/rmailsum.el index 9dd9573a9fc..8fc3fc095cc 100644 --- a/lisp/mail/rmailsum.el +++ b/lisp/mail/rmailsum.el @@ -1480,13 +1480,11 @@ argument says to read a file name and use that file as the inbox." (declare-function rmail-output-read-file-name "rmailout" ()) (declare-function mail-send-and-exit "sendmail" (&optional arg)) -(defvar rmail-summary-edit-map nil) -(if rmail-summary-edit-map - nil - (setq rmail-summary-edit-map - (nconc (make-sparse-keymap) text-mode-map)) - (define-key rmail-summary-edit-map "\C-c\C-c" 'rmail-cease-edit) - (define-key rmail-summary-edit-map "\C-c\C-]" 'rmail-abort-edit)) +(defvar rmail-summary-edit-map + (let ((map (nconc (make-sparse-keymap) text-mode-map))) + (define-key map "\C-c\C-c" #'rmail-cease-edit) + (define-key map "\C-c\C-]" #'rmail-abort-edit) + map)) (defun rmail-summary-edit-current-message () "Edit the contents of this message." diff --git a/lisp/mail/sendmail.el b/lisp/mail/sendmail.el index d0aff093dfe..d1e8a2f3c69 100644 --- a/lisp/mail/sendmail.el +++ b/lisp/mail/sendmail.el @@ -1391,8 +1391,7 @@ just append to the file, in Babyl format if necessary." (unless (markerp header-end) (error "Value of `header-end' must be a marker")) (let (fcc-list - (mailbuf (current-buffer)) - (time (current-time))) + (mailbuf (current-buffer))) (save-excursion (goto-char (point-min)) (let ((case-fold-search t)) @@ -1408,14 +1407,11 @@ just append to the file, in Babyl format if necessary." (with-temp-buffer ;; This initial newline is not written out if we create a new ;; file (see below). - (insert "\nFrom " (user-login-name) " " (current-time-string time) "\n") - ;; Insert the time zone before the year. - (forward-char -1) - (forward-word-strictly -1) (require 'mail-utils) - (insert (mail-rfc822-time-zone time) " ") - (goto-char (point-max)) - (insert "Date: " (message-make-date) "\n") + (insert "\nFrom " (user-login-name) " " + (let ((system-time-locale "C")) + (format-time-string "%a %b %e %T %z %Y")) + "\nDate: " (message-make-date) "\n") (insert-buffer-substring mailbuf) ;; Make sure messages are separated. (goto-char (point-max)) diff --git a/lisp/mail/supercite.el b/lisp/mail/supercite.el index f393ac773f5..b3080ac416b 100644 --- a/lisp/mail/supercite.el +++ b/lisp/mail/supercite.el @@ -1767,7 +1767,7 @@ is determined non-interactively. The value is queried for in the minibuffer exactly the same way that `set-variable' does it. You can see the current value of the variable when the minibuffer is -querying you by typing `C-h'. Note that the format is changed +querying you by typing \\`C-h'. Note that the format is changed slightly from that used by `set-variable' -- the current value is printed just after the variable's name instead of at the bottom of the help window." diff --git a/lisp/mail/uce.el b/lisp/mail/uce.el index 0a488e176f6..4347ff14022 100644 --- a/lisp/mail/uce.el +++ b/lisp/mail/uce.el @@ -30,26 +30,8 @@ ;; uce-reply-to-uce. Please let me know about your changes so I can ;; incorporate them. I'd appreciate it. -;; -- !!! NOTE !!! --------------------------------------------- -;; -;; Replying to spam is at best pointless, but most likely actively -;; harmful. -;; -;; - You will confirm that your email address is valid, thus ensuring -;; you get more spam. -;; -;; - You will leak information and open yourself up for further -;; attack. For example, they could use your \"geolocation\" to find -;; your home address and phone number. -;; -;; - The sender address is likely fake. -;; -;; - You help them refine their methods of spamming. -;; -;; Therefore, we strongly recommend that you do not use this package. -;; Use a spam filter instead, or just delete the spam. -;; -;; ------------------------------------------------------------- +;; NOTE: We don't recommend using this feature; see the message in +;; 'uce-reply-to-uce' for the reasons. ;; The command uce-reply-to-uce, if called when the current message ;; buffer is a UCE, will setup a reply *mail* buffer as follows. It @@ -234,6 +216,8 @@ These are mostly meant for headers that prevent delivery errors reporting." (declare-function rmail-maybe-set-message-counters "rmail" ()) (declare-function rmail-toggle-header "rmail" (&optional arg)) +(defvar uce--usage-warning-displayed nil) + ;;;###autoload (defun uce-reply-to-uce (&optional _ignored) "Compose a reply to unsolicited commercial email (UCE). @@ -379,7 +363,32 @@ You might need to set `uce-mail-reader' before using this." ;; Run hooks before we leave buffer for editing. Reasonable usage ;; might be to set up special key bindings, replace standard ;; functions in mail-mode, etc. - (run-hooks 'mail-setup-hook 'uce-setup-hook)))) + (run-hooks 'mail-setup-hook 'uce-setup-hook))) + (unless uce--usage-warning-displayed + (setq uce--usage-warning-displayed t) + (pop-to-buffer (get-buffer-create "uce-reply-to-uce warning")) + (insert "\ +-- !!! NOTE !!! --------------------------------------------- + +Replying to spam is at best pointless, but most likely actively +harmful. + +- You will confirm that your email address is valid, thus ensuring + you get more spam. + +- You will leak information and open yourself up for further + attack. For example, they could use your \"geolocation\" to find + your home address and phone number. + +- The sender address is likely fake. + +- You help them refine their methods of spamming. + +Therefore, we strongly recommend that you do not use this package. +Use a spam filter instead, or just delete the spam. + +------------------------------------------------------------- +"))) (defun uce-insert-ranting (&optional _ignored) "Insert text of the usual reply to UCE into current buffer." diff --git a/lisp/man.el b/lisp/man.el index 4ef2deac4f3..fff31baa5f3 100644 --- a/lisp/man.el +++ b/lisp/man.el @@ -1334,7 +1334,7 @@ default type, `Man-xref-man-page' is used for the buttons." (defun Man-highlight-references0 (start-section regexp button-pos target type) ;; Based on `Man-build-references-alist' - (when (or (null start-section) ;; Search regardless of sections. + (when (or (null start-section) ;; Search regardless of sections. ;; Section header is in this chunk. (Man-find-section start-section)) (let ((end (if start-section @@ -1347,18 +1347,24 @@ default type, `Man-xref-man-page' is used for the buttons." (goto-char (point-min)) nil))) (while (re-search-forward regexp end t) - ;; An overlay button is preferable because the underlying text - ;; may have text property highlights (Bug#7881). - (make-button - (match-beginning button-pos) - (match-end button-pos) - 'type type - 'Man-target-string (cond - ((numberp target) - (match-string target)) - ((functionp target) - target) - (t nil))))))) + (let ((b (match-beginning button-pos)) + (e (match-end button-pos)) + (match (match-string button-pos))) + ;; Some lists of references end with ", and ...". Chop the + ;; "and" bit off before making a button. + (when (string-match "\\`and +" match) + (setq b (+ b (- (match-end 0) (match-beginning 0))))) + ;; An overlay button is preferable because the underlying text + ;; may have text property highlights (Bug#7881). + (make-button + b e + 'type type + 'Man-target-string (cond + ((numberp target) + (match-string target)) + ((functionp target) + target) + (t nil)))))))) (defun Man-cleanup-manpage (&optional interactive) "Remove overstriking and underlining from the current buffer. @@ -1786,7 +1792,7 @@ Returns t if section is found, nil otherwise." Man--last-section (car Man--sections))) (completion-ignore-case t) - (prompt (concat "Go to section (default " default "): ")) + (prompt (format-prompt "Go to section" default)) (chosen (completing-read prompt Man--sections nil nil nil nil default))) (list chosen)) @@ -1850,7 +1856,7 @@ Specify which REFERENCE to use; default is based on word at point." (defaults (mapcar 'substring-no-properties (cons default Man--refpages))) - (prompt (concat "Refer to (default " default "): ")) + (prompt (format-prompt "Refer to" default)) (chosen (completing-read prompt Man--refpages nil nil nil nil defaults))) chosen))) diff --git a/lisp/menu-bar.el b/lisp/menu-bar.el index da79aae5295..8c04e35a51f 100644 --- a/lisp/menu-bar.el +++ b/lisp/menu-bar.el @@ -413,8 +413,14 @@ (bindings--define-key menu [separator-tag-file] '(menu-item "--" nil :visible (menu-bar-goto-uses-etags-p))) + (bindings--define-key menu [xref-forward] + '(menu-item "Forward" xref-go-forward + :visible (and (featurep 'xref) + (not (xref-forward-history-empty-p))) + :help "Forward to the position gone Back from")) + (bindings--define-key menu [xref-pop] - '(menu-item "Back" xref-pop-marker-stack + '(menu-item "Back" xref-go-back :visible (and (featurep 'xref) (not (xref-marker-stack-empty-p))) :help "Back to the position of the last search")) @@ -514,7 +520,11 @@ (cdr yank-menu) kill-ring)) (not buffer-read-only)))) - :help "Paste (yank) text most recently cut/copied")) + :help "Paste (yank) text most recently cut/copied" + :keys ,(lambda () + (if cua-mode + "\\[cua-paste]" + "\\[yank]")))) (bindings--define-key menu [copy] ;; ns-win.el said: Substitute a Copy function that works better ;; under X (for GNUstep). @@ -523,14 +533,23 @@ 'kill-ring-save) :enable mark-active :help "Copy text in region between mark and current position" - :keys ,(if (featurep 'ns) - "\\[ns-copy-including-secondary]" - "\\[kill-ring-save]"))) + :keys ,(lambda () + (cond + ((featurep 'ns) + "\\[ns-copy-including-secondary]") + ((and cua-mode mark-active) + "\\[cua-copy-handler]") + (t + "\\[kill-ring-save]"))))) (bindings--define-key menu [cut] - '(menu-item "Cut" kill-region + `(menu-item "Cut" kill-region :enable (and mark-active (not buffer-read-only)) :help - "Cut (kill) text in region between mark and current position")) + "Cut (kill) text in region between mark and current position" + :keys ,(lambda () + (if (and cua-mode mark-active) + "\\[cua-cut-handler]" + "\\[kill-region]")))) ;; ns-win.el said: Separate undo from cut/paste section. (if (featurep 'ns) (bindings--define-key menu [separator-undo] menu-bar-separator)) @@ -1328,14 +1347,13 @@ mail status in mode line")) (frame-parameter (menu-bar-frame-for-menubar) 'menu-bar-lines))))) - (unless (featurep 'ns) - (bindings--define-key menu [showhide-tab-bar] - '(menu-item "Tab Bar" toggle-tab-bar-mode-from-frame - :help "Turn tab bar on/off" - :button - (:toggle . (menu-bar-positive-p - (frame-parameter (menu-bar-frame-for-menubar) - 'tab-bar-lines)))))) + (bindings--define-key menu [showhide-tab-bar] + '(menu-item "Tab Bar" toggle-tab-bar-mode-from-frame + :help "Turn tab bar on/off" + :button + (:toggle . (menu-bar-positive-p + (frame-parameter (menu-bar-frame-for-menubar) + 'tab-bar-lines))))) (if (and (boundp 'menu-bar-showhide-tool-bar-menu) (keymapp menu-bar-showhide-tool-bar-menu)) @@ -1918,10 +1936,7 @@ key, a click, or a menu-item")) (let* ((default (thing-at-point 'sexp)) (topic (read-from-minibuffer - (format "Subject to look up%s: " - (if default - (format " (default \"%s\")" default) - "")) + (format-prompt "Subject to look up" default) nil nil nil nil default))) (list (if (zerop (length topic)) default @@ -2163,6 +2178,12 @@ otherwise it could decide to silently do nothing." :type 'integer :group 'menu) +(defcustom yank-menu-max-items 60 + "Maximum number of entries to display in the `yank-menu'." + :type 'integer + :group 'menu + :version "29.1") + (defun menu-bar-update-yank-menu (string old) (let ((front (car (cdr yank-menu))) (menu-string (if (<= (length string) yank-menu-length) @@ -2186,8 +2207,9 @@ otherwise it could decide to silently do nothing." (cons (cons string (cons menu-string 'menu-bar-select-yank)) (cdr yank-menu))))) - (if (> (length (cdr yank-menu)) kill-ring-max) - (setcdr (nthcdr kill-ring-max yank-menu) nil))) + (let ((max-items (min yank-menu-max-items kill-ring-max))) + (if (> (length (cdr yank-menu)) max-items) + (setcdr (nthcdr max-items yank-menu) nil)))) (put 'menu-bar-select-yank 'apropos-inhibit t) (defun menu-bar-select-yank () @@ -2517,6 +2539,7 @@ See `menu-bar-mode' for more information." (declare-function x-menu-bar-open "term/x-win" (&optional frame)) (declare-function w32-menu-bar-open "term/w32-win" (&optional frame)) +(declare-function haiku-menu-bar-open "haikumenu.c" (&optional frame)) (defun lookup-key-ignore-too-long (map key) "Call `lookup-key' and convert numeric values to nil." @@ -2642,9 +2665,10 @@ first TTY menu-bar menu to be dropped down. Interactively, this is the numeric argument to the command. This function decides which method to use to access the menu depending on FRAME's terminal device. On X displays, it calls -`x-menu-bar-open'; on Windows, `w32-menu-bar-open'; otherwise it -calls either `popup-menu' or `tmm-menubar' depending on whether -`tty-menu-open-use-tmm' is nil or not. +`x-menu-bar-open'; on Windows, `w32-menu-bar-open'; on Haiku, +`haiku-menu-bar-open'; otherwise it calls either `popup-menu' +or `tmm-menubar' depending on whether `tty-menu-open-use-tmm' +is nil or not. If FRAME is nil or not given, use the selected frame." (interactive @@ -2653,6 +2677,7 @@ If FRAME is nil or not given, use the selected frame." (cond ((eq type 'x) (x-menu-bar-open frame)) ((eq type 'w32) (w32-menu-bar-open frame)) + ((eq type 'haiku) (haiku-menu-bar-open frame)) ((and (null tty-menu-open-use-tmm) (not (zerop (or (frame-parameter nil 'menu-bar-lines) 0)))) ;; Make sure the menu bar is up to date. One situation where diff --git a/lisp/mh-e/mh-acros.el b/lisp/mh-e/mh-acros.el index 8fdcf3c62b4..25fff6a8e1b 100644 --- a/lisp/mh-e/mh-acros.el +++ b/lisp/mh-e/mh-acros.el @@ -47,19 +47,20 @@ ;;;###mh-autoload (defmacro mh-do-in-gnu-emacs (&rest body) "Execute BODY if in GNU Emacs." - (declare (debug t) (indent defun)) + (declare (obsolete progn "29.1") (debug t) (indent defun)) (unless (featurep 'xemacs) `(progn ,@body))) ;;;###mh-autoload (defmacro mh-do-in-xemacs (&rest body) "Execute BODY if in XEmacs." - (declare (debug t) (indent defun)) + (declare (obsolete ignore "29.1") (debug t) (indent defun)) (when (featurep 'xemacs) `(progn ,@body))) ;;;###mh-autoload (defmacro mh-funcall-if-exists (function &rest args) "Call FUNCTION with ARGS as parameters if it exists." - (declare (debug (symbolp body))) + (declare (obsolete "use `(when (fboundp 'foo) (foo))' instead." "29.1") + (debug (symbolp body))) ;; FIXME: Not clear when this should be used. If the function happens ;; not to exist at compile-time (e.g. because the corresponding package ;; wasn't loaded), then it won't ever be used :-( @@ -72,7 +73,8 @@ "Create function NAME. If FUNCTION exists, then NAME becomes an alias for FUNCTION. Otherwise, create function NAME with ARG-LIST and BODY." - (declare (indent defun) (doc-string 4) + (declare (obsolete defun "29.1") + (indent defun) (doc-string 4) (debug (&define name symbolp sexp def-body))) `(defalias ',name (if (fboundp ',function) @@ -84,7 +86,8 @@ Otherwise, create function NAME with ARG-LIST and BODY." "Create macro NAME. If MACRO exists, then NAME becomes an alias for MACRO. Otherwise, create macro NAME with ARG-LIST and BODY." - (declare (indent defun) (doc-string 4) + (declare (obsolete defmacro "29.1") + (indent defun) (doc-string 4) (debug (&define name symbolp sexp def-body))) (let ((defined-p (fboundp macro))) (if defined-p @@ -99,22 +102,20 @@ Otherwise, create macro NAME with ARG-LIST and BODY." "Make HOOK local if needed. XEmacs and versions of GNU Emacs before 21.1 require `make-local-hook' to be called." + (declare (obsolete nil "29.1")) (when (and (fboundp 'make-local-hook) (not (get 'make-local-hook 'byte-obsolete-info))) `(make-local-hook ,hook))) ;;;###mh-autoload (defmacro mh-mark-active-p (check-transient-mark-mode-flag) - "A macro that expands into appropriate code in XEmacs and nil in GNU Emacs. -In GNU Emacs if CHECK-TRANSIENT-MARK-MODE-FLAG is non-nil then -check if variable `transient-mark-mode' is active." - (cond ((featurep 'xemacs) ;XEmacs - '(and (boundp 'zmacs-regions) zmacs-regions (region-active-p))) - ((not check-transient-mark-mode-flag) ;GNU Emacs - '(and (boundp 'mark-active) mark-active)) - (t ;GNU Emacs - '(and (boundp 'transient-mark-mode) transient-mark-mode - (boundp 'mark-active) mark-active)))) + "If CHECK-TRANSIENT-MARK-MODE-FLAG is non-nil then check if +variable `transient-mark-mode' is active." + (declare (obsolete nil "29.1")) + (cond ((not check-transient-mark-mode-flag) + 'mark-active) + (t + '(and transient-mark-mode mark-active)))) ;;;###mh-autoload (defmacro with-mh-folder-updating (save-modification-flag &rest body) @@ -164,12 +165,8 @@ preserved." (original-position (make-symbol "original-position")) (modified-flag (make-symbol "modified-flag"))) `(save-excursion - (let* ((,event-window - (or (mh-funcall-if-exists posn-window (event-start ,event)) - (mh-funcall-if-exists event-window ,event))) - (,event-position - (or (mh-funcall-if-exists posn-point (event-start ,event)) - (mh-funcall-if-exists event-closest-point ,event))) + (let* ((,event-window (posn-window (event-start ,event))) + (,event-position (posn-point (event-start ,event))) (,original-window (selected-window)) (,original-position (progn (set-buffer (window-buffer ,event-window)) diff --git a/lisp/mh-e/mh-alias.el b/lisp/mh-e/mh-alias.el index 37fdb166011..d2666211002 100644 --- a/lisp/mh-e/mh-alias.el +++ b/lisp/mh-e/mh-alias.el @@ -67,8 +67,7 @@ Return t if any file listed in the Aliasfile MH profile component has been modified since the timestamp. If ARG is non-nil, set timestamp with the current time." (if arg - (let ((time (current-time))) - (setq mh-alias-tstamp (list (nth 0 time) (nth 1 time)))) + (setq mh-alias-tstamp (current-time)) (let ((stamp)) (car (memq t (mapcar (lambda (file) @@ -112,10 +111,10 @@ COMMA-SEPARATOR is non-nil." (setq res (match-string 1 res))) ;; Replace "&" with capitalized username (if (string-search "&" res) - (setq res (mh-replace-regexp-in-string "&" (capitalize username) res))) + (setq res (replace-regexp-in-string "&" (capitalize username) res))) ;; Remove " character (if (string-search "\"" res) - (setq res (mh-replace-regexp-in-string "\"" "" res))) + (setq res (replace-regexp-in-string "\"" "" res))) ;; If empty string, use username instead (if (string-equal "" res) (setq res username)) @@ -155,7 +154,7 @@ Exclude all aliases already in `mh-alias-alist' from \"ali\"" (if (string-equal username realname) (concat "<" username ">") (concat realname " <" username ">")))) - (when (not (mh-assoc-string alias-name mh-alias-alist t)) + (when (not (assoc-string alias-name mh-alias-alist t)) (setq passwd-alist (cons (list alias-name alias-translation) passwd-alist))))))) (forward-line 1))) @@ -184,12 +183,12 @@ been loaded." (cond ((looking-at "^[ \t]")) ;Continuation line ((looking-at "\\(.+\\): .+: .*$") ; A new -blind- MH alias - (when (not (mh-assoc-string (match-string 1) mh-alias-blind-alist t)) + (when (not (assoc-string (match-string 1) mh-alias-blind-alist t)) (setq mh-alias-blind-alist (cons (list (match-string 1)) mh-alias-blind-alist)) (setq mh-alias-alist (cons (list (match-string 1)) mh-alias-alist)))) ((looking-at "\\(.+\\): .*$") ; A new MH alias - (when (not (mh-assoc-string (match-string 1) mh-alias-alist t)) + (when (not (assoc-string (match-string 1) mh-alias-alist t)) (setq mh-alias-alist (cons (list (match-string 1)) mh-alias-alist))))) (forward-line 1))) @@ -200,7 +199,7 @@ been loaded." user) (while local-users (setq user (car local-users)) - (if (not (mh-assoc-string (car user) mh-alias-alist t)) + (if (not (assoc-string (car user) mh-alias-alist t)) (setq mh-alias-alist (append mh-alias-alist (list user)))) (setq local-users (cdr local-users))))) (run-hooks 'mh-alias-reloaded-hook) @@ -239,16 +238,16 @@ done here." "Return expansion for ALIAS. Blind aliases or users from /etc/passwd are not expanded." (cond - ((mh-assoc-string alias mh-alias-blind-alist t) + ((assoc-string alias mh-alias-blind-alist t) alias) ; Don't expand a blind alias - ((mh-assoc-string alias mh-alias-passwd-alist t) - (cadr (mh-assoc-string alias mh-alias-passwd-alist t))) + ((assoc-string alias mh-alias-passwd-alist t) + (cadr (assoc-string alias mh-alias-passwd-alist t))) (t (mh-alias-ali alias)))) (eval-and-compile - (mh-require 'crm nil t) ; completing-read-multiple - (mh-require 'multi-prompt nil t)) + (require 'crm nil t) ; completing-read-multiple + (require 'multi-prompt nil t)) ;;;###mh-autoload (defun mh-read-address (prompt) @@ -258,15 +257,7 @@ Blind aliases or users from /etc/passwd are not expanded." (read-string prompt) (let* ((minibuffer-local-completion-map mh-alias-read-address-map) (completion-ignore-case mh-alias-completion-ignore-case-flag) - (the-answer - (cond ((fboundp 'completing-read-multiple) - (mh-funcall-if-exists - completing-read-multiple prompt mh-alias-alist nil nil)) - ((featurep 'multi-prompt) - (mh-funcall-if-exists - multi-prompt "," nil prompt mh-alias-alist nil nil)) - (t (split-string - (completing-read prompt mh-alias-alist nil nil) ","))))) + (the-answer (completing-read-multiple prompt mh-alias-alist nil nil))) (if (not mh-alias-expand-aliases-flag) (mapconcat #'identity the-answer ", ") ;; Loop over all elements, checking if in passwd alias or blind first @@ -281,7 +272,7 @@ Blind aliases or users from /etc/passwd are not expanded." (let* ((case-fold-search t) (beg (mh-beginning-of-word)) (the-name (buffer-substring-no-properties beg (point)))) - (if (mh-assoc-string the-name mh-alias-alist t) + (if (assoc-string the-name mh-alias-alist t) (message "%s -> %s" the-name (mh-alias-expand the-name)) ;; Check if it was a single word likely to be an alias (if (and (equal mh-alias-flash-on-comma 1) @@ -313,7 +304,7 @@ Blind aliases or users from /etc/passwd are not expanded." res) res))) ((t) (all-completions string mh-alias-alist pred)) - ((lambda) (mh-test-completion string mh-alias-alist pred))))))))) + ((lambda) (test-completion string mh-alias-alist pred))))))))) ;;; Alias File Updating diff --git a/lisp/mh-e/mh-comp.el b/lisp/mh-e/mh-comp.el index e44c42e2800..a47a6f9cca9 100644 --- a/lisp/mh-e/mh-comp.el +++ b/lisp/mh-e/mh-comp.el @@ -177,9 +177,8 @@ Used by the \\[mh-edit-again] and \\[mh-extract-rejected-mail] commands.") "Messages annotated, either a sequence name or a list of message numbers. This variable can be used by `mh-annotate-msg-hook'.") -(defvar mh-insert-auto-fields-done-local nil +(defvar-local mh-insert-auto-fields-done-local nil "Buffer-local variable set when `mh-insert-auto-fields' called successfully.") -(make-variable-buffer-local 'mh-insert-auto-fields-done-local) @@ -304,21 +303,7 @@ message and scan line." (let ((draft-buffer (current-buffer)) (file-name buffer-file-name) (config mh-previous-window-config) - ;; FIXME this is subtly different to select-message-coding-system. - (coding-system-for-write - (if (fboundp 'select-message-coding-system) - (select-message-coding-system) ; Emacs has this since at least 21.1 - (if (and (local-variable-p 'buffer-file-coding-system - (current-buffer)) ;XEmacs needs two args - ;; We're not sure why, but buffer-file-coding-system - ;; tends to get set to undecided-unix. - (not (memq buffer-file-coding-system - '(undecided undecided-unix undecided-dos)))) - buffer-file-coding-system - (or (and (boundp 'sendmail-coding-system) sendmail-coding-system) - (and (default-boundp 'buffer-file-coding-system) - (default-value 'buffer-file-coding-system)) - 'utf-8))))) + (coding-system-for-write (select-message-coding-system))) ;; Older versions of spost do not support -msgid and -mime. (unless mh-send-uses-spost-flag ;; Adding a Message-ID field looks good, makes it easier to search for @@ -433,7 +418,7 @@ See also `mh-send'." (mh-clean-msg-header (point-min) mh-new-draft-cleaned-headers nil) (mh-insert-header-separator) ;; Merge in components - (mh-mapc + (mapc (lambda (header-field) (let ((field (car header-field)) (value (cdr header-field)) @@ -593,11 +578,12 @@ See also `mh-compose-forward-as-mime-flag', (goto-char (point-min)) ;; Set the local value of mh-mail-header-separator according to what is ;; present in the buffer... - (set (make-local-variable 'mh-mail-header-separator) - (save-excursion - (goto-char (mh-mail-header-end)) - (buffer-substring-no-properties (point) (mh-line-end-position)))) - (set (make-local-variable 'mail-header-separator) mh-mail-header-separator) ;override sendmail.el + (setq-local mh-mail-header-separator + (save-excursion + (goto-char (mh-mail-header-end)) + (buffer-substring-no-properties (point) + (line-end-position)))) + (setq-local mail-header-separator mh-mail-header-separator) ;override sendmail.el ;; If using MML, translate MH-style directive (if (equal mh-compose-insertion 'mml) (save-excursion @@ -699,7 +685,7 @@ message and scan line." ;; For "From", the first value wins, with the identity's "From" ;; trumping anything in the distcomps file. (let ((components-file (mh-bare-components mh-dist-formfile))) - (mh-mapc + (mapc (lambda (header-field) (let ((field (car header-field)) (value (cdr header-field)) @@ -1079,7 +1065,6 @@ letter." ;; Insert identity. (mh-insert-identity mh-identity-default t) (mh-identity-make-menu) - (mh-identity-add-menu) ;; Cleanup possibly RFC2047 encoded subject header (mh-decode-message-subject) @@ -1098,7 +1083,6 @@ letter." (setq mh-previous-window-config config) (setq mode-line-buffer-identification (list " {%b}")) (mh-logo-display) - (mh-make-local-hook 'kill-buffer-hook) (add-hook 'kill-buffer-hook #'mh-tidy-draft-buffer nil t) (run-hook-with-args 'mh-compose-letter-function to subject cc)) @@ -1109,18 +1093,8 @@ The versions of MH-E, Emacs, and MH are shown." ;; Lazily initialize mh-x-mailer-string. (when (and mh-insert-x-mailer-flag (null mh-x-mailer-string)) (setq mh-x-mailer-string - (format "MH-E %s; %s; %sEmacs %s" - mh-version mh-variant-in-use - (if (featurep 'xemacs) "X" "GNU ") - (cond ((not (featurep 'xemacs)) - (string-match "[0-9]+\\.[0-9]+\\(\\.[0-9]+\\)?" - emacs-version) - (match-string 0 emacs-version)) - ((string-match "[0-9.]*\\( +([ a-z]+[0-9]+)\\)?" - emacs-version) - (match-string 0 emacs-version)) - (t (format "%s.%s" emacs-major-version - emacs-minor-version)))))) + (format "MH-E %s; %s; Emacs %s" + mh-version mh-variant-in-use emacs-version))) ;; Insert X-Mailer, but only if it doesn't already exist. (save-excursion (when (and mh-insert-x-mailer-flag @@ -1247,7 +1221,7 @@ discarded." (cond ((and overwrite-flag (mh-goto-header-field (concat field ":"))) (insert " " value) - (delete-region (point) (mh-line-end-position))) + (delete-region (point) (line-end-position))) ((and (not overwrite-flag) (mh-regexp-in-field-p (concat "\\b" (regexp-quote value) "\\b") field)) ;; Already there, do nothing. @@ -1290,11 +1264,8 @@ discarded." (set-syntax-table old-syntax-table)))) (defun mh-ascii-buffer-p () - "Check if current buffer is entirely composed of ASCII. -The function doesn't work for XEmacs since `find-charset-region' -doesn't exist there." - (cl-loop for charset in (mh-funcall-if-exists - find-charset-region (point-min) (point-max)) + "Check if current buffer is entirely composed of ASCII." + (cl-loop for charset in (find-charset-region (point-min) (point-max)) unless (eq charset 'ascii) return nil finally return t)) diff --git a/lisp/mh-e/mh-compat.el b/lisp/mh-e/mh-compat.el index ade80e8b95e..23dc48a574c 100644 --- a/lisp/mh-e/mh-compat.el +++ b/lisp/mh-e/mh-compat.el @@ -34,53 +34,21 @@ ;; Please use mh-gnus.el when providing compatibility with different ;; versions of Gnus. -;; Items are listed alphabetically (except for mh-require which is -;; needed sooner it would normally appear). +;; Items are listed alphabetically. (eval-when-compile (require 'mh-acros)) -(mh-do-in-gnu-emacs - (defalias 'mh-require #'require)) - -(mh-do-in-xemacs - (defun mh-require (feature &optional filename noerror) - "If feature FEATURE is not loaded, load it from FILENAME. -If FEATURE is not a member of the list `features', then the feature -is not loaded; so load the file FILENAME. -If FILENAME is omitted, the printname of FEATURE is used as the file name. -If the optional third argument NOERROR is non-nil, -then return nil if the file is not found instead of signaling an error. - -Simulate NOERROR argument in XEmacs which lacks it." - (if (not (featurep feature)) - (if filename - (load filename noerror t) - (load (format "%s" feature) noerror t))))) - -(defun-mh mh-assoc-string assoc-string (key list case-fold) - "Like `assoc' but specifically for strings. -Case is ignored if CASE-FOLD is non-nil. -This function is used by Emacs versions that lack `assoc-string', -introduced in Emacs 22." - ;; Test for fboundp is solely to silence compiler for Emacs >= 22.1. - (if (and case-fold (fboundp 'assoc-ignore-case)) - (assoc-ignore-case key list) - (assoc key list))) - -;; For XEmacs. -(defalias 'mh-cancel-timer - (if (fboundp 'cancel-timer) - 'cancel-timer - 'delete-itimer)) +(define-obsolete-function-alias 'mh-require #'require "29.1") +(define-obsolete-function-alias 'mh-assoc-string #'assoc-string "29.1") +(define-obsolete-function-alias 'mh-cancel-timer #'cancel-timer "29.1") ;; Emacs 24 made flet obsolete and suggested either cl-flet or ;; cl-letf. This macro is based upon gmm-flet from Gnus. (defmacro mh-flet (bindings &rest body) "Make temporary overriding function definitions. -This is an analogue of a dynamically scoped `let' that operates on -the function cell of FUNCs rather than their value cell. - -\(fn ((FUNC ARGLIST BODY...) ...) FORM...)" +That is, temporarily rebind the functions listed in BINDINGS and then +execute BODY. BINDINGS is a list containing one or more lists of the +form (FUNCNAME ARGLIST BODY...), similar to defun." (declare (indent 1) (debug ((&rest (sexp sexp &rest form)) &rest form))) (if (fboundp 'cl-letf) `(cl-letf ,(mapcar (lambda (binding) @@ -90,17 +58,8 @@ the function cell of FUNCs rather than their value cell. ,@body) `(flet ,bindings ,@body))) -(defun mh-display-color-cells (&optional display) - "Return the number of color cells supported by DISPLAY. -This function is used by XEmacs to return 2 when `device-color-cells' -or `display-color-cells' returns nil. This happens when compiling or -running on a tty and causes errors since `display-color-cells' is -expected to return an integer." - (cond ((fboundp 'display-color-cells) ; GNU Emacs, XEmacs 21.5b28 - (or (display-color-cells display) 2)) - ((fboundp 'device-color-cells) ; XEmacs 21.4 - (or (device-color-cells display) 2)) - (t 2))) +(define-obsolete-function-alias 'mh-display-color-cells + #'display-color-cells "29.1") (defmacro mh-display-completion-list (completions &optional common-substring) "Display the list of COMPLETIONS. @@ -110,209 +69,54 @@ The optional argument COMMON-SUBSTRING, if non-nil, should be a string specifying a common substring for adding the faces `completions-first-difference' and `completions-common-part' to the completions." - (cond ((< emacs-major-version 22) `(display-completion-list ,completions)) - ((fboundp 'completion-hilit-commonality) ; Emacs 23.1 and later - `(display-completion-list - (completion-hilit-commonality ,completions - ,(length common-substring) nil))) - (t ; Emacs 22 - `(display-completion-list ,completions ,common-substring)))) - -(defmacro mh-face-foreground (face &optional frame inherit) - "Return the foreground color name of FACE, or nil if unspecified. -See documentation for `face-foreground' for a description of the -arguments FACE, FRAME, and perhaps INHERIT. -This macro is used by Emacs versions that lack an INHERIT argument, -introduced in Emacs 22." - (if (< emacs-major-version 22) - `(face-foreground ,face ,frame) - `(face-foreground ,face ,frame ,inherit))) - -(defmacro mh-face-background (face &optional frame inherit) - "Return the background color name of face, or nil if unspecified. -See documentation for `face-background' for a description of the -arguments FACE, FRAME, and INHERIT. -This macro is used by Emacs versions that lack an INHERIT argument, -introduced in Emacs 22." - (if (< emacs-major-version 22) - `(face-background ,face ,frame) - `(face-background ,face ,frame ,inherit))) - -(defun-mh mh-font-lock-add-keywords font-lock-add-keywords - (_mode _keywords &optional _how) - "XEmacs does not have `font-lock-add-keywords'. -This function returns nil on that system.") - -(defun-mh mh-image-load-path-for-library - image-load-path-for-library (library image &optional path no-error) - "Return a suitable search path for images used by LIBRARY. - -It searches for IMAGE in `image-load-path' (excluding -\"`data-directory'/images\") and `load-path', followed by a path -suitable for LIBRARY, which includes \"../../etc/images\" and -\"../etc/images\" relative to the library file itself, and then -in \"`data-directory'/images\". - -Then this function returns a list of directories which contains -first the directory in which IMAGE was found, followed by the -value of `load-path'. If PATH is given, it is used instead of -`load-path'. - -If NO-ERROR is non-nil and a suitable path can't be found, don't -signal an error. Instead, return a list of directories as before, -except that nil appears in place of the image directory. - -Here is an example that uses a common idiom to provide -compatibility with versions of Emacs that lack the variable -`image-load-path': - - ;; Shush compiler. - (defvar image-load-path) - - (let* ((load-path (image-load-path-for-library \"mh-e\" \"mh-logo.xpm\")) - (image-load-path (cons (car load-path) - (when (boundp \\='image-load-path) - image-load-path)))) - (mh-tool-bar-folder-buttons-init))" - (unless library (error "No library specified")) - (unless image (error "No image specified")) - (let (image-directory image-directory-load-path) - ;; Check for images in image-load-path or load-path. - (let ((img image) - (dir (or - ;; Images in image-load-path. - (mh-image-search-load-path image) - ;; Images in load-path. - (locate-library image))) - parent) - ;; Since the image might be in a nested directory (for - ;; example, mail/attach.pbm), adjust `image-directory' - ;; accordingly. - (when dir - (setq dir (file-name-directory dir)) - (while (setq parent (file-name-directory img)) - (setq img (directory-file-name parent) - dir (expand-file-name "../" dir)))) - (setq image-directory-load-path dir)) - - ;; If `image-directory-load-path' isn't Emacs's image directory, - ;; it's probably a user preference, so use it. Then use a - ;; relative setting if possible; otherwise, use - ;; `image-directory-load-path'. - (cond - ;; User-modified image-load-path? - ((and image-directory-load-path - (not (equal image-directory-load-path - (file-name-as-directory - (expand-file-name "images" data-directory))))) - (setq image-directory image-directory-load-path)) - ;; Try relative setting. - ((let (library-name d1ei d2ei) - ;; First, find library in the load-path. - (setq library-name (locate-library library)) - (if (not library-name) - (error "Cannot find library %s in load-path" library)) - ;; And then set image-directory relative to that. - (setq - ;; Go down 2 levels. - d2ei (file-name-as-directory - (expand-file-name - (concat (file-name-directory library-name) "../../etc/images"))) - ;; Go down 1 level. - d1ei (file-name-as-directory - (expand-file-name - (concat (file-name-directory library-name) "../etc/images")))) - (setq image-directory - ;; Set it to nil if image is not found. - (cond ((file-exists-p (expand-file-name image d2ei)) d2ei) - ((file-exists-p (expand-file-name image d1ei)) d1ei))))) - ;; Use Emacs's image directory. - (image-directory-load-path - (setq image-directory image-directory-load-path)) - (no-error - (message "Could not find image %s for library %s" image library)) - (t - (error "Could not find image %s for library %s" image library))) - - ;; Return an augmented `path' or `load-path'. - (nconc (list image-directory) - (delete image-directory (copy-sequence (or path load-path)))))) - -(defun-mh mh-image-search-load-path - image-search-load-path (_file &optional _path) - "Emacs 21 and XEmacs don't have `image-search-load-path'. -This function returns nil on those systems." - nil) - -;; For XEmacs. -(defalias 'mh-line-beginning-position - (if (fboundp 'line-beginning-position) - 'line-beginning-position - 'point-at-bol)) - -;; For XEmacs. -(defalias 'mh-line-end-position - (if (fboundp 'line-end-position) - 'line-end-position - 'point-at-eol)) - -(mh-require 'mailabbrev nil t) -(defun-mh mh-mail-abbrev-make-syntax-table - mail-abbrev-make-syntax-table () - "Emacs 21 and XEmacs don't have `mail-abbrev-make-syntax-table'. -This function returns nil on those systems." - nil) - -(defmacro mh-define-obsolete-variable-alias - (obsolete-name current-name &optional when docstring) - "Make OBSOLETE-NAME a variable alias for CURRENT-NAME and mark it obsolete. -See documentation for `define-obsolete-variable-alias' for a description -of the arguments OBSOLETE-NAME, CURRENT-NAME, and perhaps WHEN -and DOCSTRING. This macro is used by XEmacs that lacks WHEN and -DOCSTRING arguments." - (if (featurep 'xemacs) - `(define-obsolete-variable-alias ,obsolete-name ,current-name) - `(define-obsolete-variable-alias ,obsolete-name ,current-name ,when ,docstring))) - -(defmacro mh-make-obsolete-variable (obsolete-name current-name &optional when access-type) - "Make the byte-compiler warn that OBSOLETE-NAME is obsolete. -See documentation for `make-obsolete-variable' for a description -of the arguments OBSOLETE-NAME, CURRENT-NAME, and perhaps WHEN -and ACCESS-TYPE. This macro is used by XEmacs that lacks WHEN and -ACCESS-TYPE arguments and by Emacs versions that lack ACCESS-TYPE, -introduced in Emacs 24." - (if (featurep 'xemacs) - `(make-obsolete-variable ,obsolete-name ,current-name) - (if (< emacs-major-version 24) - `(make-obsolete-variable ,obsolete-name ,current-name ,when) - `(make-obsolete-variable ,obsolete-name ,current-name ,when ,access-type)))) - -(defun-mh mh-match-string-no-properties - match-string-no-properties (num &optional _string) - "Return string of text matched by last search, without text properties. -This function is used by XEmacs that lacks `match-string-no-properties'. -The function `buffer-substring-no-properties' is used instead. -The argument STRING is ignored." - (buffer-substring-no-properties - (match-beginning num) (match-end num))) - -(defun-mh mh-replace-regexp-in-string replace-regexp-in-string - (regexp rep string &optional _fixedcase literal _subexp _start) - "Replace REGEXP with REP everywhere in STRING and return result. -This function is used by XEmacs that lacks `replace-regexp-in-string'. -The function `replace-in-string' is used instead. -The arguments FIXEDCASE, SUBEXP, and START, used by -`replace-in-string' are ignored." - (if (featurep 'xemacs) ; silence Emacs compiler - (replace-in-string string regexp rep literal))) - -(defun-mh mh-test-completion - test-completion (_string _collection &optional _predicate) - "Return non-nil if STRING is a valid completion. -XEmacs does not have `test-completion'. This function returns nil -on that system." nil) - -;; Copy of constant from url-util.el in Emacs 22; needed by Emacs 21. + `(display-completion-list + (completion-hilit-commonality ,completions + ,(length common-substring) nil))) + +(define-obsolete-function-alias 'mh-face-foreground + #'face-foreground "29.1") + +(define-obsolete-function-alias 'mh-face-background + #'face-background "29.1") + +(define-obsolete-function-alias 'mh-font-lock-add-keywords + #'font-lock-add-keywords "29.1") + +;; Not preloaded in without-x builds. +(declare-function image-load-path-for-library "image") +(define-obsolete-function-alias 'mh-image-load-path-for-library + #'image-load-path-for-library "29.1") + +;; Not preloaded in without-x builds. +(declare-function image-search-load-path "image") +(define-obsolete-function-alias 'mh-image-search-load-path + #'image-search-load-path "29.1") + +(define-obsolete-function-alias 'mh-line-beginning-position + #'line-beginning-position "29.1") + +(define-obsolete-function-alias 'mh-line-end-position + #'line-end-position "29.1") + +(require 'mailabbrev nil t) +(define-obsolete-function-alias 'mh-mail-abbrev-make-syntax-table + #'mail-abbrev-make-syntax-table "29.1") + +(define-obsolete-function-alias 'mh-define-obsolete-variable-alias + #'define-obsolete-variable-alias "29.1") + +(define-obsolete-function-alias 'mh-make-obsolete-variable + #'make-obsolete-variable "29.1") + +(define-obsolete-function-alias 'mh-match-string-no-properties + #'match-string-no-properties "29.1") + +(define-obsolete-function-alias 'mh-replace-regexp-in-string + #'replace-regexp-in-string "29.1") + +(define-obsolete-function-alias 'mh-test-completion + #'test-completion "29.1") + (defconst mh-url-unreserved-chars '( ?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 @@ -321,51 +125,21 @@ on that system." nil) ?- ?_ ?. ?! ?~ ?* ?' ?\( ?\)) "A list of characters that are _NOT_ reserved in the URL spec. This is taken from RFC 2396.") +(make-obsolete-variable 'mh-url-unreserved-chars 'url-unreserved-chars "29.1") + +(define-obsolete-function-alias 'mh-url-hexify-string + #'url-hexify-string "29.1") + +(define-obsolete-function-alias 'mh-view-mode-enter + #'view-mode-enter "29.1") -(defun-mh mh-url-hexify-string url-hexify-string (str) - "Escape characters in a string. -This is a copy of `url-hexify-string' from url-util.el in Emacs -22; needed by Emacs 21." - (mapconcat - (lambda (char) - ;; Fixme: use a char table instead. - (if (not (memq char mh-url-unreserved-chars)) - (if (> char 255) - (error "Hexifying multibyte character %s" str) - (format "%%%02X" char)) - (char-to-string char))) - str "")) - -(defun-mh mh-view-mode-enter - view-mode-enter (&optional return-to exit-action) - "Enter View mode. -This function is used by XEmacs that lacks `view-mode-enter'. -The function `view-mode' is used instead. -The arguments RETURN-TO and EXIT-ACTION are ignored." - ;; Shush compiler. - (if return-to nil) - (if exit-action nil) - (view-mode 1)) - -(defun-mh mh-window-full-height-p - window-full-height-p (&optional _window) - "Return non-nil if WINDOW is not the result of a vertical split. -This function is defined in XEmacs as it lacks -`window-full-height-p'. The values of the functions -`window-height' and `frame-height' are compared instead. The -argument WINDOW is ignored." - (= (1+ (window-height)) - (frame-height))) +(define-obsolete-function-alias 'mh-window-full-height-p + #'window-full-height-p "29.1") (defmacro mh-write-file-functions () - "Return `write-file-functions' if it exists. -Otherwise return `local-write-file-hooks'. -This macro exists purely for compatibility. The former symbol is used -in Emacs 22 onward while the latter is used in previous versions and -XEmacs." - (if (boundp 'write-file-functions) - ''write-file-functions ;Emacs 22 on - ''local-write-file-hooks)) ;XEmacs + "Return `write-file-functions'." + (declare (obsolete nil "29.1")) + ''write-file-functions) (provide 'mh-compat) diff --git a/lisp/mh-e/mh-e.el b/lisp/mh-e/mh-e.el index 9cbc8cfb737..17faff0716c 100644 --- a/lisp/mh-e/mh-e.el +++ b/lisp/mh-e/mh-e.el @@ -88,29 +88,6 @@ (require 'mh-buffers) (require 'mh-compat) -(mh-do-in-xemacs - (require 'mh-xemacs)) - -(mh-font-lock-add-keywords - 'emacs-lisp-mode - (eval-when-compile - `((,(concat "(\\(" - ;; Function declarations (use font-lock-function-name-face). - "\\(def\\(un\\|macro\\)-mh\\)\\|" - ;; Variable declarations (use font-lock-variable-name-face). - "\\(def\\(custom\\|face\\)-mh\\)\\|" - ;; Group declarations (use font-lock-type-face). - "\\(defgroup-mh\\)" - "\\)\\>" - ;; Any whitespace and defined object. - "[ \t'(]*" - "\\(setf[ \t]+\\sw+)\\|\\sw+\\)?") - (1 font-lock-keyword-face) - (7 (cond ((match-beginning 2) font-lock-function-name-face) - ((match-beginning 4) font-lock-variable-name-face) - (t font-lock-type-face)) - nil t))))) - ;;; Global Variables @@ -368,15 +345,13 @@ when searching for a separator.") "This regular expression matches the signature separator. See `mh-signature-separator'.") -(defvar mh-thread-scan-line-map nil +(defvar-local mh-thread-scan-line-map nil "Map of message index to various parts of the scan line.") -(make-variable-buffer-local 'mh-thread-scan-line-map) -(defvar mh-thread-scan-line-map-stack nil +(defvar-local mh-thread-scan-line-map-stack nil "Old map of message index to various parts of the scan line. This is the original map that is stored when the folder is narrowed.") -(make-variable-buffer-local 'mh-thread-scan-line-map-stack) (defcustom mh-x-mailer-string nil "String containing the contents of the X-Mailer header field. @@ -486,7 +461,7 @@ all the strings have been used." (count 0)) (while (and (not (eobp)) (< count mh-index-max-cmdline-args)) (push (buffer-substring-no-properties (point) - (mh-line-end-position)) + (line-end-position)) arg-list) (cl-incf count) (forward-line)) @@ -619,23 +594,18 @@ Output is expected to be shown to user, not parsed by MH-E." ;; The bug wasn't seen in emacs21 but still occurred in XEmacs21.4. (mh-exchange-point-and-mark-preserving-active-mark)) -;; Shush compiler. -(mh-do-in-xemacs - (defvar mark-active)) - (defun mh-exchange-point-and-mark-preserving-active-mark () "Put the mark where point is now, and point where the mark is now. This command works even when the mark is not active, and preserves whether the mark is active or not." (interactive nil) - (let ((is-active (and (boundp 'mark-active) mark-active))) + (let ((is-active mark-active)) (let ((omark (mark t))) (if (null omark) (error "No mark set in this buffer")) (set-mark (point)) (goto-char omark) - (if (boundp 'mark-active) - (setq mark-active is-active)) + (setq mark-active is-active) nil))) (defun mh-exec-lib-cmd-output (command &rest args) @@ -663,56 +633,39 @@ Set mark after inserted text." ;;; MH-E Customization Support Routines -;; Shush compiler (Emacs 21 and XEmacs). -(defvar customize-package-emacs-version-alist) - ;; Temporary function and data structure used customization. ;; These will be unbound after the options are defined. (defmacro mh-strip-package-version (args) - "Strip :package-version keyword and its value from ARGS. -In Emacs versions that support the :package-version keyword, -ARGS is returned unchanged." - `(if (boundp 'customize-package-emacs-version-alist) - ,args - (let (seen) - (cl-loop for keyword in ,args - if (cond ((eq keyword ':package-version) (setq seen t) nil) - (seen (setq seen nil) nil) - (t t)) - collect keyword)))) + "ARGS is returned unchanged." + (declare (obsolete identity "29.1")) + args) (defmacro defgroup-mh (symbol members doc &rest args) "Declare SYMBOL as a customization group containing MEMBERS. See documentation for `defgroup' for a description of the arguments -SYMBOL, MEMBERS, DOC and ARGS. -This macro is used by Emacs versions that lack the :package-version -keyword, introduced in Emacs 22." - (declare (doc-string 3) (indent defun)) - `(defgroup ,symbol ,members ,doc ,@(mh-strip-package-version args))) +SYMBOL, MEMBERS, DOC and ARGS." + (declare (obsolete defgroup "29.1") (doc-string 3) (indent defun)) + `(defgroup ,symbol ,members ,doc ,args)) (defmacro defcustom-mh (symbol value doc &rest args) "Declare SYMBOL as a customizable variable that defaults to VALUE. See documentation for `defcustom' for a description of the arguments -SYMBOL, VALUE, DOC and ARGS. -This macro is used by Emacs versions that lack the :package-version -keyword, introduced in Emacs 22." - (declare (doc-string 3) (indent defun)) - `(defcustom ,symbol ,value ,doc ,@(mh-strip-package-version args))) +SYMBOL, VALUE, DOC and ARGS." + (declare (obsolete defcustom "29.1") (doc-string 3) (indent defun)) + `(defcustom ,symbol ,value ,doc ,args)) (defmacro defface-mh (face spec doc &rest args) "Declare FACE as a customizable face that defaults to SPEC. See documentation for `defface' for a description of the arguments -FACE, SPEC, DOC and ARGS. -This macro is used by Emacs versions that lack the :package-version -keyword, introduced in Emacs 22." - (declare (doc-string 3) (indent defun)) - `(defface ,face ,spec ,doc ,@(mh-strip-package-version args))) +FACE, SPEC, DOC and ARGS." + (declare (obsolete defface "29.1") (doc-string 3) (indent defun)) + `(defface ,face ,spec ,doc ,args)) ;;; Variant Support -(defcustom-mh mh-path nil +(defcustom mh-path nil "Additional list of directories to search for MH. See `mh-variant'." :group 'mh-e @@ -947,7 +900,7 @@ finally GNU mailutils MH." (mapconcat (lambda (x) (format "%s" (car x))) (mh-variants) " or ")))))) -(defcustom-mh mh-variant 'autodetect +(defcustom mh-variant 'autodetect "Specifies the variant used by MH-E. The default setting of this option is \"Auto-detect\" which means @@ -1023,19 +976,18 @@ windows in the frame are removed." (when delete-other-windows-flag (delete-other-windows))) -(if (boundp 'customize-package-emacs-version-alist) - (add-to-list 'customize-package-emacs-version-alist - '(MH-E ("6.0" . "22.1") ("6.1" . "22.1") ("7.0" . "22.1") - ("7.1" . "22.1") ("7.2" . "22.1") ("7.3" . "22.1") - ("7.4" . "22.1") ("8.0" . "22.1") ("8.1" . "23.1") - ("8.2" . "23.1") ("8.3" . "24.1") ("8.4" . "24.4") - ("8.5" . "24.4") ("8.6" . "24.4")))) +(add-to-list 'customize-package-emacs-version-alist + '(MH-E ("6.0" . "22.1") ("6.1" . "22.1") ("7.0" . "22.1") + ("7.1" . "22.1") ("7.2" . "22.1") ("7.3" . "22.1") + ("7.4" . "22.1") ("8.0" . "22.1") ("8.1" . "23.1") + ("8.2" . "23.1") ("8.3" . "24.1") ("8.4" . "24.4") + ("8.5" . "24.4") ("8.6" . "24.4"))) ;;; MH-E Customization Groups -(defgroup-mh mh-e nil +(defgroup mh-e nil "Emacs interface to the MH mail system. MH is the Rand Mail Handler. Other implementations include nmh and GNU mailutils." @@ -1043,126 +995,126 @@ and GNU mailutils." :group 'mail :package-version '(MH-E . "8.0")) -(defgroup-mh mh-alias nil +(defgroup mh-alias nil "Aliases." :link '(custom-manual "(mh-e)Aliases") :prefix "mh-alias-" :group 'mh-e :package-version '(MH-E . "7.1")) -(defgroup-mh mh-folder nil +(defgroup mh-folder nil "Organizing your mail with folders." :prefix "mh-" :link '(custom-manual "(mh-e)Folders") :group 'mh-e :package-version '(MH-E . "7.1")) -(defgroup-mh mh-folder-selection nil +(defgroup mh-folder-selection nil "Folder selection." :prefix "mh-" :link '(custom-manual "(mh-e)Folder Selection") :group 'mh-e :package-version '(MH-E . "8.0")) -(defgroup-mh mh-identity nil +(defgroup mh-identity nil "Identities." :link '(custom-manual "(mh-e)Identities") :prefix "mh-identity-" :group 'mh-e :package-version '(MH-E . "7.1")) -(defgroup-mh mh-inc nil +(defgroup mh-inc nil "Incorporating your mail." :prefix "mh-inc-" :link '(custom-manual "(mh-e)Incorporating Mail") :group 'mh-e :package-version '(MH-E . "8.0")) -(defgroup-mh mh-junk nil +(defgroup mh-junk nil "Dealing with junk mail." :link '(custom-manual "(mh-e)Junk") :prefix "mh-junk-" :group 'mh-e :package-version '(MH-E . "7.3")) -(defgroup-mh mh-letter nil +(defgroup mh-letter nil "Editing a draft." :prefix "mh-" :link '(custom-manual "(mh-e)Editing Drafts") :group 'mh-e :package-version '(MH-E . "7.1")) -(defgroup-mh mh-ranges nil +(defgroup mh-ranges nil "Ranges." :prefix "mh-" :link '(custom-manual "(mh-e)Ranges") :group 'mh-e :package-version '(MH-E . "8.0")) -(defgroup-mh mh-scan-line-formats nil +(defgroup mh-scan-line-formats nil "Scan line formats." :link '(custom-manual "(mh-e)Scan Line Formats") :prefix "mh-" :group 'mh-e :package-version '(MH-E . "8.0")) -(defgroup-mh mh-search nil +(defgroup mh-search nil "Searching." :link '(custom-manual "(mh-e)Searching") :prefix "mh-search-" :group 'mh-e :package-version '(MH-E . "8.0")) -(defgroup-mh mh-sending-mail nil +(defgroup mh-sending-mail nil "Sending mail." :prefix "mh-" :link '(custom-manual "(mh-e)Sending Mail") :group 'mh-e :package-version '(MH-E . "8.0")) -(defgroup-mh mh-sequences nil +(defgroup mh-sequences nil "Sequences." :prefix "mh-" :link '(custom-manual "(mh-e)Sequences") :group 'mh-e :package-version '(MH-E . "8.0")) -(defgroup-mh mh-show nil +(defgroup mh-show nil "Reading your mail." :prefix "mh-" :link '(custom-manual "(mh-e)Reading Mail") :group 'mh-e :package-version '(MH-E . "7.1")) -(defgroup-mh mh-speedbar nil +(defgroup mh-speedbar nil "The speedbar." :prefix "mh-speed-" :link '(custom-manual "(mh-e)Speedbar") :group 'mh-e :package-version '(MH-E . "8.0")) -(defgroup-mh mh-thread nil +(defgroup mh-thread nil "Threading." :prefix "mh-thread-" :link '(custom-manual "(mh-e)Threading") :group 'mh-e :package-version '(MH-E . "8.0")) -(defgroup-mh mh-tool-bar nil +(defgroup mh-tool-bar nil "The tool bar" :link '(custom-manual "(mh-e)Tool Bar") :prefix "mh-" :group 'mh-e :package-version '(MH-E . "8.0")) -(defgroup-mh mh-hooks nil +(defgroup mh-hooks nil "MH-E hooks." :link '(custom-manual "(mh-e)Top") :prefix "mh-" :group 'mh-e :package-version '(MH-E . "7.1")) -(defgroup-mh mh-faces nil +(defgroup mh-faces nil "Faces used in MH-E." :link '(custom-manual "(mh-e)Top") :prefix "mh-" @@ -1178,7 +1130,7 @@ and GNU mailutils." ;;; Aliases (:group 'mh-alias) -(defcustom-mh mh-alias-completion-ignore-case-flag t +(defcustom mh-alias-completion-ignore-case-flag t "Non-nil means don't consider case significant in MH alias completion. As MH ignores case in the aliases, so too does MH-E. However, you @@ -1189,7 +1141,7 @@ lowercase for mailing lists and uppercase for people." :group 'mh-alias :package-version '(MH-E . "7.1")) -(defcustom-mh mh-alias-expand-aliases-flag nil +(defcustom mh-alias-expand-aliases-flag nil "Non-nil means to expand aliases entered in the minibuffer. In other words, aliases entered in the minibuffer will be @@ -1199,7 +1151,7 @@ this expansion is not performed." :group 'mh-alias :package-version '(MH-E . "7.1")) -(defcustom-mh mh-alias-flash-on-comma t +(defcustom mh-alias-flash-on-comma t "Specify whether to flash address or warn on translation. This option controls the behavior when a [comma] is pressed while @@ -1212,7 +1164,7 @@ does not display a warning if the alias is not found." :group 'mh-alias :package-version '(MH-E . "7.1")) -(defcustom-mh mh-alias-insert-file nil +(defcustom mh-alias-insert-file nil "Filename used to store a new MH-E alias. The default setting of this option is \"Use Aliasfile Profile @@ -1226,7 +1178,7 @@ name, MH-E will prompt for one of them when MH-E adds an alias." :group 'mh-alias :package-version '(MH-E . "7.1")) -(defcustom-mh mh-alias-insertion-location 'sorted +(defcustom mh-alias-insertion-location 'sorted "Specifies where new aliases are entered in alias files. This option is set to \"Alphabetical\" by default. If you organize @@ -1238,7 +1190,7 @@ or \"Bottom\" of your alias file might be more appropriate." :group 'mh-alias :package-version '(MH-E . "7.1")) -(defcustom-mh mh-alias-local-users t +(defcustom mh-alias-local-users t "Non-nil means local users are added to alias completion. Aliases are created from \"/etc/passwd\" entries with a user ID @@ -1259,7 +1211,7 @@ NIS password file." :group 'mh-alias :package-version '(MH-E . "7.1")) -(defcustom-mh mh-alias-local-users-prefix "local." +(defcustom mh-alias-local-users-prefix "local." "String prefixed to the real names of users from the password file. This option can also be set to \"Use Login\". @@ -1281,7 +1233,7 @@ turned off." :group 'mh-alias :package-version '(MH-E . "7.4")) -(defcustom-mh mh-alias-passwd-gecos-comma-separator-flag t +(defcustom mh-alias-passwd-gecos-comma-separator-flag t "Non-nil means the gecos field in the password file uses a comma separator. In the example in `mh-alias-local-users-prefix', commas are used @@ -1295,7 +1247,7 @@ whose contents may contain commas, you can turn this option off." ;;; Organizing Your Mail with Folders (:group 'mh-folder) -(defcustom-mh mh-new-messages-folders t +(defcustom mh-new-messages-folders t "Folders searched for the \"unseen\" sequence. Set this option to \"Inbox\" to search the \"+inbox\" folder or @@ -1310,7 +1262,7 @@ See also `mh-recursive-folders-flag'." :group 'mh-folder :package-version '(MH-E . "8.0")) -(defcustom-mh mh-ticked-messages-folders t +(defcustom mh-ticked-messages-folders t "Folders searched for `mh-tick-seq'. Set this option to \"Inbox\" to search the \"+inbox\" folder or @@ -1325,7 +1277,7 @@ See also `mh-recursive-folders-flag'." :group 'mh-folder :package-version '(MH-E . "8.0")) -(defcustom-mh mh-large-folder 200 +(defcustom mh-large-folder 200 "The number of messages that indicates a large folder. If a folder is deemed to be large, that is the number of messages @@ -1337,7 +1289,7 @@ folders are treated as if they are small." :group 'mh-folder :package-version '(MH-E . "7.0")) -(defcustom-mh mh-recenter-summary-flag nil +(defcustom mh-recenter-summary-flag nil "Non-nil means to recenter the summary window. If this option is turned on, recenter the summary window when the @@ -1346,13 +1298,13 @@ show window is toggled off." :group 'mh-folder :package-version '(MH-E . "7.0")) -(defcustom-mh mh-recursive-folders-flag nil +(defcustom mh-recursive-folders-flag nil "Non-nil means that commands which operate on folders do so recursively." :type 'boolean :group 'mh-folder :package-version '(MH-E . "7.0")) -(defcustom-mh mh-sortm-args nil +(defcustom mh-sortm-args nil "Additional arguments for \"sortm\"\\<mh-folder-mode-map>. This option is consulted when a prefix argument is used with @@ -1366,7 +1318,7 @@ an alternate view. For example, (\"-nolimit\" \"-textfield\" ;;; Folder Selection (:group 'mh-folder-selection) -(defcustom-mh mh-default-folder-for-message-function nil +(defcustom mh-default-folder-for-message-function nil "Function to select a default folder for refiling or \"Fcc:\". When this function is called, the current buffer contains the message @@ -1378,7 +1330,7 @@ the default, or an empty string to suppress the default entirely." :group 'mh-folder-selection :package-version '(MH-E . "8.0")) -(defcustom-mh mh-default-folder-list nil +(defcustom mh-default-folder-list nil "List of addresses and folders. The folder name associated with the first address found in this @@ -1396,7 +1348,7 @@ for more information." :group 'mh-folder-selection :package-version '(MH-E . "7.2")) -(defcustom-mh mh-default-folder-must-exist-flag t +(defcustom mh-default-folder-must-exist-flag t "Non-nil means guessed folder name must exist to be used. If the derived folder does not exist, and this option is on, then @@ -1410,7 +1362,7 @@ for more information." :group 'mh-folder-selection :package-version '(MH-E . "7.2")) -(defcustom-mh mh-default-folder-prefix "" +(defcustom mh-default-folder-prefix "" "Prefix used for folder names generated from aliases. The prefix is used to prevent clutter in your mail directory. @@ -1429,7 +1381,7 @@ for more information." Real definition will take effect when mh-identity is loaded." nil))) -(defcustom-mh mh-identity-list nil +(defcustom mh-identity-list nil "List of identities. To customize this option, click on the \"INS\" button and enter a label @@ -1498,7 +1450,7 @@ fashion." :group 'mh-identity :package-version '(MH-E . "7.1")) -(defcustom-mh mh-auto-fields-list nil +(defcustom mh-auto-fields-list nil "List of recipients for which header lines are automatically inserted. This option can be used to set the identity depending on the @@ -1559,14 +1511,14 @@ as the result is undefined." :group 'mh-identity :package-version '(MH-E . "7.3")) -(defcustom-mh mh-auto-fields-prompt-flag t +(defcustom mh-auto-fields-prompt-flag t "Non-nil means to prompt before sending if fields inserted. See `mh-auto-fields-list'." :type 'boolean :group 'mh-identity :package-version '(MH-E . "8.0")) -(defcustom-mh mh-identity-default nil +(defcustom mh-identity-default nil "Default identity to use when `mh-letter-mode' is called. See `mh-identity-list'." :type (append @@ -1577,7 +1529,7 @@ See `mh-identity-list'." :group 'mh-identity :package-version '(MH-E . "7.1")) -(defcustom-mh mh-identity-handlers +(defcustom mh-identity-handlers '(("From" . mh-identity-handler-top) (":default" . mh-identity-handler-bottom) (":attribution-verb" . mh-identity-handler-attribution-verb) @@ -1613,7 +1565,7 @@ containing the VALUE for the field is given." ;;; Incorporating Your Mail (:group 'mh-inc) -(defcustom-mh mh-inc-prog "inc" +(defcustom mh-inc-prog "inc" "Program to incorporate new mail into a folder. This program generates a one-line summary for each of the new @@ -1632,7 +1584,7 @@ several scan line format variables appropriately." Real definition will take effect when mh-inc is loaded." nil))) -(defcustom-mh mh-inc-spool-list nil +(defcustom mh-inc-spool-list nil "Alternate spool files. You can use the `mh-inc-spool-list' variable to direct MH-E to @@ -1655,17 +1607,14 @@ on the \"INS\" button. Enter a \"Spool File\" of \"~/mail/mh-e\", a \"Folder\" of \"mh-e\", and a \"Key Binding\" of \"m\". You can use \"xbuffy\" to automate the incorporation of this mail -using the Emacs 22 command \"emacsclient\" as follows: +using \"emacsclient\" as follows: box ~/mail/mh-e title mh-e origMode polltime 10 headertime 0 - command emacsclient --eval \\='(mh-inc-spool-mh-e)\\=' - -In XEmacs, the command \"gnuclient\" is used in a similar -fashion." + command emacsclient --eval \\='(mh-inc-spool-mh-e)\\='" :type '(repeat (list (file :tag "Spool File") (string :tag "Folder") (character :tag "Key Binding"))) @@ -1705,7 +1654,7 @@ The function is always called with SYMBOL bound to until (executable-find (symbol-name (car element))) finally return (car element))))) -(defcustom-mh mh-junk-background nil +(defcustom mh-junk-background nil "If on, spam programs are run in background. By default, the programs are run in the foreground, but this can @@ -1723,14 +1672,14 @@ may be useful for debugging." :group 'mh-junk :package-version '(MH-E . "8.0")) -(defcustom-mh mh-junk-disposition nil +(defcustom mh-junk-disposition nil "Disposition of junk mail." :type '(choice (const :tag "Delete Spam" nil) (string :tag "Spam Folder")) :group 'mh-junk :package-version '(MH-E . "8.0")) -(defcustom-mh mh-junk-program nil +(defcustom mh-junk-program nil "Spam program that MH-E should use. The default setting of this option is \"Auto-detect\" which means @@ -1748,7 +1697,7 @@ bogofilter, then you can set this option to \"Bogofilter\"." ;;; Editing a Draft (:group 'mh-letter) -(defcustom-mh mh-compose-insertion (if (locate-library "mml") 'mml 'mh) +(defcustom mh-compose-insertion (if (locate-library "mml") 'mml 'mh) "Type of tags used when composing MIME messages. In addition to MH-style directives, MH-E also supports MML (MIME @@ -1762,7 +1711,7 @@ MH-style directives are preferred." :group 'mh-letter :package-version '(MH-E . "7.0")) -(defcustom-mh mh-compose-skipped-header-fields +(defcustom mh-compose-skipped-header-fields '("From" "Organization" "References" "In-Reply-To" "X-Face" "Face" "X-Image-URL" "X-Mailer") "List of header fields to skip over when navigating in draft." @@ -1770,13 +1719,13 @@ MH-style directives are preferred." :group 'mh-letter :package-version '(MH-E . "7.4")) -(defcustom-mh mh-compose-space-does-completion-flag nil +(defcustom mh-compose-space-does-completion-flag nil "Non-nil means \\<mh-letter-mode-map>\\[mh-letter-complete-or-space] does completion in message header." :type 'boolean :group 'mh-letter :package-version '(MH-E . "7.4")) -(defcustom-mh mh-delete-yanked-msg-window-flag nil +(defcustom mh-delete-yanked-msg-window-flag nil "Non-nil means delete any window displaying the message. This deletes the window containing the original message after @@ -1786,7 +1735,7 @@ more room on your screen for your reply." :group 'mh-letter :package-version '(MH-E . "7.0")) -(defcustom-mh mh-extract-from-attribution-verb "wrote:" +(defcustom mh-extract-from-attribution-verb "wrote:" "Verb to use for attribution when a message is yanked by \\<mh-letter-mode-map>\\[mh-yank-cur-msg]. The attribution consists of the sender's name and email address @@ -1800,7 +1749,7 @@ followed by the content of this option. This option can be set to :group 'mh-letter :package-version '(MH-E . "7.0")) -(defcustom-mh mh-ins-buf-prefix "> " +(defcustom mh-ins-buf-prefix "> " "String to put before each line of a yanked or inserted message. The prefix \"> \" is the default setting of this option. I @@ -1816,17 +1765,17 @@ flavors of `mh-yank-behavior' or you have added a :group 'mh-letter :package-version '(MH-E . "6.0")) -(defcustom-mh mh-letter-complete-function 'ispell-complete-word +(defcustom mh-letter-complete-function 'ispell-complete-word "Function to call when completing outside of address or folder fields. In the body of the message, -\\<mh-letter-mode-map>\\[mh-letter-complete] runs this function, +\\<mh-letter-mode-map>\\[completion-at-point] runs this function, which is set to \"ispell-complete-word\" by default." :type '(choice function (const nil)) :group 'mh-letter :package-version '(MH-E . "7.1")) -(defcustom-mh mh-letter-fill-column 72 +(defcustom mh-letter-fill-column 72 "Fill column to use in MH Letter mode. By default, this option is 72 to allow others to quote your @@ -1835,7 +1784,7 @@ message without line wrapping." :group 'mh-letter :package-version '(MH-E . "6.0")) -(defcustom-mh mh-mml-method-default (if mh-pgp-support-flag "pgpmime" "none") +(defcustom mh-mml-method-default (if mh-pgp-support-flag "pgpmime" "none") "Default method to use in security tags. This option is used to select between a variety of mail security @@ -1858,7 +1807,7 @@ you write!" :group 'mh-letter :package-version '(MH-E . "8.0")) -(defcustom-mh mh-signature-file-name "~/.signature" +(defcustom mh-signature-file-name "~/.signature" "Source of user's signature. By default, the text of your signature is taken from the file @@ -1881,7 +1830,7 @@ The signature is inserted into your message with the command :group 'mh-letter :package-version '(MH-E . "6.0")) -(defcustom-mh mh-signature-separator-flag t +(defcustom mh-signature-separator-flag t "Non-nil means a signature separator should be inserted. It is not recommended that you change this option since various @@ -1892,7 +1841,7 @@ replying or yanking a letter into a draft." :group 'mh-letter :package-version '(MH-E . "8.0")) -(defcustom-mh mh-x-face-file "~/.face" +(defcustom mh-x-face-file "~/.face" "File containing face header field to insert in outgoing mail. If the file starts with either of the strings \"X-Face:\", \"Face:\" @@ -1921,7 +1870,7 @@ this option doesn't exist." :group 'mh-letter :package-version '(MH-E . "7.0")) -(defcustom-mh mh-yank-behavior 'attribution +(defcustom mh-yank-behavior 'attribution "Controls which part of a message is yanked by \\<mh-letter-mode-map>\\[mh-yank-cur-msg]. To include the entire message, including the entire header, use @@ -1968,7 +1917,7 @@ inserted." ;;; Ranges (:group 'mh-ranges) -(defcustom-mh mh-interpret-number-as-range-flag t +(defcustom mh-interpret-number-as-range-flag t "Non-nil means interpret a number as a range. Since one of the most frequent ranges used is \"last:N\", MH-E @@ -1988,7 +1937,7 @@ message 200, then use the range \"200:200\"." Real definition, below, uses variables that aren't defined yet." (set-default symbol value)))) -(defcustom-mh mh-adaptive-cmd-note-flag t +(defcustom mh-adaptive-cmd-note-flag t "Non-nil means that the message number width is determined dynamically. If you've created your own format to handle long message numbers, @@ -2017,7 +1966,7 @@ set SYMBOL to VALUE." "unless you use \"Use MH-E scan Format\"") (set-default symbol value))) -(defcustom-mh mh-scan-format-file t +(defcustom mh-scan-format-file t "Specifies the format file to pass to the scan program. The default setting for this option is \"Use MH-E scan Format\". This @@ -2056,7 +2005,7 @@ Otherwise, set SYMBOL to VALUE." "is set to \"Use MH-E scan Format\"") (set-default symbol value))) -(defcustom-mh mh-scan-prog "scan" +(defcustom mh-scan-prog "scan" "Program used to scan messages. The name of the program that generates a listing of one line per @@ -2071,7 +2020,7 @@ directory. You may link another program to `scan' (see ;;; Searching (:group 'mh-search) -(defcustom-mh mh-search-program nil +(defcustom mh-search-program nil "Search program that MH-E shall use. The default setting of this option is \"Auto-detect\" which means @@ -2094,7 +2043,7 @@ MH-E can be found in the documentation of `mh-search'." ;;; Sending Mail (:group 'mh-sending-mail) -(defcustom-mh mh-compose-forward-as-mime-flag t +(defcustom mh-compose-forward-as-mime-flag t "Non-nil means that messages are forwarded as attachments. By default, this option is on which means that the forwarded @@ -2110,7 +2059,7 @@ regardless of the settings of this option." :group 'mh-sending-mail :package-version '(MH-E . "8.0")) -(defcustom-mh mh-compose-letter-function nil +(defcustom mh-compose-letter-function nil "Invoked when starting a new draft. However, it is the last function called before you edit your @@ -2122,13 +2071,13 @@ fields." :group 'mh-sending-mail :package-version '(MH-E . "6.0")) -(defcustom-mh mh-compose-prompt-flag nil +(defcustom mh-compose-prompt-flag nil "Non-nil means prompt for header fields when composing a new draft." :type 'boolean :group 'mh-sending-mail :package-version '(MH-E . "7.4")) -(defcustom-mh mh-forward-subject-format "%s: %s" +(defcustom mh-forward-subject-format "%s: %s" "Format string for forwarded message subject. This option is a string which includes two escapes (\"%s\"). The @@ -2138,7 +2087,7 @@ and the second one is replaced with the original \"Subject:\"." :group 'mh-sending-mail :package-version '(MH-E . "6.0")) -(defcustom-mh mh-insert-x-mailer-flag t +(defcustom mh-insert-x-mailer-flag t "Non-nil means append an \"X-Mailer:\" header field to the header. This header field includes the version of MH-E and Emacs that you @@ -2148,7 +2097,7 @@ can turn this option off." :group 'mh-sending-mail :package-version '(MH-E . "7.0")) -(defcustom-mh mh-redist-full-contents-flag nil +(defcustom mh-redist-full-contents-flag nil "Non-nil means the \"dist\" command needs entire letter for redistribution. This option must be turned on if \"dist\" requires the whole @@ -2160,7 +2109,7 @@ has been redistributed before, turn off this option." :group 'mh-sending-mail :package-version '(MH-E . "8.0")) -(defcustom-mh mh-reply-default-reply-to nil +(defcustom mh-reply-default-reply-to nil "Sets the person or persons to whom a reply will be sent. This option is set to \"Prompt\" by default so that you are @@ -2176,7 +2125,7 @@ this option to \"cc\". Other choices include \"from\", \"to\", or :group 'mh-sending-mail :package-version '(MH-E . "6.0")) -(defcustom-mh mh-reply-show-message-flag t +(defcustom mh-reply-show-message-flag t "Non-nil means the MH-Show buffer is displayed when replying. If you include the message automatically, you can hide the @@ -2193,7 +2142,7 @@ See also `mh-reply'." ;; the docstring: "Additional sequences that should not to be preserved can be ;; specified by setting `mh-unpropagated-sequences' appropriately." XXX -(defcustom-mh mh-refile-preserves-sequences-flag t +(defcustom mh-refile-preserves-sequences-flag t "Non-nil means that sequences are preserved when messages are refiled. If a message is in any sequence (except \"Previous-Sequence:\" @@ -2204,7 +2153,7 @@ desired, then turn off this option." :group 'mh-sequences :package-version '(MH-E . "7.4")) -(defcustom-mh mh-tick-seq 'tick +(defcustom mh-tick-seq 'tick "The name of the MH sequence for ticked messages. You can customize this option if you already use the \"tick\" @@ -2216,7 +2165,7 @@ there isn't much advantage to that." :group 'mh-sequences :package-version '(MH-E . "7.3")) -(defcustom-mh mh-update-sequences-after-mh-show-flag t +(defcustom mh-update-sequences-after-mh-show-flag t "Non-nil means flush MH sequences to disk after message is shown\\<mh-folder-mode-map>. Three sequences are maintained internally by MH-E and pushed out @@ -2231,7 +2180,7 @@ commands." :group 'mh-sequences :package-version '(MH-E . "7.0")) -(defcustom-mh mh-allowlist-preserves-sequences-flag t +(defcustom mh-allowlist-preserves-sequences-flag t "Non-nil means that sequences are preserved when messages are allowlisted. If a message is in any sequence (except \"Previous-Sequence:\" @@ -2244,7 +2193,7 @@ not desired, then turn off this option." ;;; Reading Your Mail (:group 'mh-show) -(defcustom-mh mh-bury-show-buffer-flag t +(defcustom mh-bury-show-buffer-flag t "Non-nil means show buffer is buried. One advantage of not burying the show buffer is that one can @@ -2255,7 +2204,7 @@ running \\[electric-buffer-list] to see what I mean." :group 'mh-show :package-version '(MH-E . "7.0")) -(defcustom-mh mh-clean-message-header-flag t +(defcustom mh-clean-message-header-flag t "Non-nil means remove extraneous header fields. See also `mh-invisible-header-fields-default' and @@ -2264,7 +2213,7 @@ See also `mh-invisible-header-fields-default' and :group 'mh-show :package-version '(MH-E . "7.0")) -(defcustom-mh mh-decode-mime-flag (not (not (locate-library "mm-decode"))) +(defcustom mh-decode-mime-flag (not (not (locate-library "mm-decode"))) "Non-nil means attachments are handled\\<mh-folder-mode-map>. MH-E can handle attachments as well if the Gnus `mm-decode' @@ -2282,7 +2231,7 @@ messages and other graphical widgets. See the options :group 'mh-show :package-version '(MH-E . "7.0")) -(defcustom-mh mh-display-buttons-for-alternatives-flag nil +(defcustom mh-display-buttons-for-alternatives-flag nil "Non-nil means display buttons for all alternative attachments. Sometimes, a mail program will produce multiple alternatives of @@ -2294,7 +2243,7 @@ inline and buttons are shown for each of the other alternatives." :group 'mh-show :package-version '(MH-E . "7.4")) -(defcustom-mh mh-display-buttons-for-inline-parts-flag nil +(defcustom mh-display-buttons-for-inline-parts-flag nil "Non-nil means display buttons for all inline attachments\\<mh-folder-mode-map>. The sender can request that attachments should be viewed inline so @@ -2317,7 +2266,7 @@ text (including HTML) and images." :group 'mh-show :package-version '(MH-E . "7.0")) -(defcustom-mh mh-do-not-confirm-flag nil +(defcustom mh-do-not-confirm-flag nil "Non-nil means non-reversible commands do not prompt for confirmation. Commands such as `mh-pack-folder' prompt to confirm whether to @@ -2329,7 +2278,7 @@ retracted--without question." :group 'mh-show :package-version '(MH-E . "7.0")) -(defcustom-mh mh-fetch-x-image-url nil +(defcustom mh-fetch-x-image-url nil "Control fetching of \"X-Image-URL:\" header field image. This option controls the fetching of the \"X-Image-URL:\" header @@ -2365,7 +2314,7 @@ turned on." :group 'mh-show :package-version '(MH-E . "7.3")) -(defcustom-mh mh-graphical-smileys-flag t +(defcustom mh-graphical-smileys-flag t "Non-nil means graphical smileys are displayed. It is a long standing custom to inject body language using a @@ -2380,7 +2329,7 @@ turned off." :group 'mh-show :package-version '(MH-E . "7.0")) -(defcustom-mh mh-graphical-emphasis-flag t +(defcustom mh-graphical-emphasis-flag t "Non-nil means graphical emphasis is displayed. A few typesetting features are indicated in ASCII text with @@ -2397,7 +2346,7 @@ turned off." :group 'mh-show :package-version '(MH-E . "7.0")) -(defcustom-mh mh-highlight-citation-style 'gnus +(defcustom mh-highlight-citation-style 'gnus "Style for highlighting citations. If the sender of the message has cited other messages in his @@ -2819,7 +2768,7 @@ Because the function `mh-invisible-headers' uses both `mh-invisible-header-fields' and `mh-invisible-header-fields', it cannot be run until both variables have been initialized.") -(defcustom-mh mh-invisible-header-fields nil +(defcustom mh-invisible-header-fields nil "Additional header fields to hide. Header fields that you would like to hide that aren't listed in @@ -2842,7 +2791,7 @@ See also `mh-clean-message-header-flag'." :group 'mh-show :package-version '(MH-E . "7.1")) -(defcustom-mh mh-invisible-header-fields-default nil +(defcustom mh-invisible-header-fields-default nil "List of hidden header fields. The header fields listed in this option are hidden, although you @@ -2899,7 +2848,7 @@ removed and entries from `mh-invisible-header-fields' are added." ;; Compile invisible header fields. (mh-invisible-headers) -(defcustom-mh mh-lpr-command-format "lpr -J '%s'" +(defcustom mh-lpr-command-format "lpr -J '%s'" "Command used to print\\<mh-folder-mode-map>. This option contains the Unix command line which performs the @@ -2916,7 +2865,7 @@ This option is not used by the commands \\[mh-ps-print-msg] or :group 'mh-show :package-version '(MH-E . "6.0")) -(defcustom-mh mh-max-inline-image-height nil +(defcustom mh-max-inline-image-height nil "Maximum inline image height if \"Content-Disposition:\" is not present. Some older mail programs do not insert this needed plumbing to @@ -2932,7 +2881,7 @@ these numbers." :group 'mh-show :package-version '(MH-E . "7.0")) -(defcustom-mh mh-max-inline-image-width nil +(defcustom mh-max-inline-image-width nil "Maximum inline image width if \"Content-Disposition:\" is not present. Some older mail programs do not insert this needed plumbing to @@ -2948,7 +2897,7 @@ these numbers." :group 'mh-show :package-version '(MH-E . "7.0")) -(defcustom-mh mh-mhl-format-file nil +(defcustom mh-mhl-format-file nil "Specifies the format file to pass to the \"mhl\" program. Normally MH-E takes care of displaying messages itself (rather than @@ -2972,7 +2921,7 @@ file." :group 'mh-show :package-version '(MH-E . "8.0")) -(defcustom-mh mh-mime-save-parts-default-directory t +(defcustom mh-mime-save-parts-default-directory t "Default directory to use for \\<mh-folder-mode-map>\\[mh-mime-save-parts]. The default value for this option is \"Prompt Always\" so that @@ -2988,7 +2937,7 @@ directory's name." :group 'mh-show :package-version '(MH-E . "7.0")) -(defcustom-mh mh-print-background-flag nil +(defcustom mh-print-background-flag nil "Non-nil means messages should be printed in the background\\<mh-folder-mode-map>. Normally messages are printed in the foreground. If this is slow on @@ -3004,7 +2953,7 @@ This option is not used by the commands \\[mh-ps-print-msg] or :group 'mh-show :package-version '(MH-E . "7.0")) -(defcustom-mh mh-show-maximum-size 0 +(defcustom mh-show-maximum-size 0 "Maximum size of message (in bytes) to display automatically. This option provides an opportunity to skip over large messages @@ -3014,7 +2963,7 @@ message are shown regardless of size." :group 'mh-show :package-version '(MH-E . "8.0")) -(defcustom-mh mh-show-use-xface-flag (>= emacs-major-version 21) +(defcustom mh-show-use-xface-flag (>= emacs-major-version 21) "Non-nil means display face images in MH-show buffers. MH-E can display the content of \"Face:\", \"X-Face:\", and @@ -3029,15 +2978,12 @@ and off. This feature will be turned on by default if your system supports it. The first header field used, if present, is the Gnus-specific -\"Face:\" field. The \"Face:\" field appeared in GNU Emacs 21 and -XEmacs. For more information, see URL +\"Face:\" field. The \"Face:\" field appeared in Emacs 21. +For more information, see URL `https://quimby.gnus.org/circus/face/'. Next is the traditional \"X-Face:\" header field. The display of this field requires the \"uncompface\" program (see URL -`ftp://ftp.cs.indiana.edu/pub/faces/compface/compface.tar.z'). Recent -versions of XEmacs have internal support for \"X-Face:\" images. If -your version of XEmacs does not, then you'll need both \"uncompface\" -and the x-face package (see URL `https://www.jpl.org/ftp/pub/elisp/'). +`ftp://ftp.cs.indiana.edu/pub/faces/compface/compface.tar.z'). Finally, MH-E will display images referenced by the \"X-Image-URL:\" header field if neither the \"Face:\" nor the \"X-Face:\" fields are @@ -3054,7 +3000,7 @@ The option `mh-fetch-x-image-url' controls the fetching of the :group 'mh-show :package-version '(MH-E . "7.0")) -(defcustom-mh mh-store-default-directory nil +(defcustom mh-store-default-directory nil "Default directory for \\<mh-folder-mode-map>\\[mh-store-msg]. If you would like to change the initial default directory, @@ -3066,7 +3012,7 @@ the content of these messages." :group 'mh-show :package-version '(MH-E . "6.0")) -(defcustom-mh mh-summary-height nil +(defcustom mh-summary-height nil "Number of lines in MH-Folder buffer (including the mode line). The default value of this option is \"Automatic\" which means @@ -3081,7 +3027,7 @@ lines you'd like to see." ;;; The Speedbar (:group 'mh-speedbar) -(defcustom-mh mh-speed-update-interval 60 +(defcustom mh-speed-update-interval 60 "Time between speedbar updates in seconds. Set to 0 to disable automatic update." :type 'integer @@ -3090,7 +3036,7 @@ Set to 0 to disable automatic update." ;;; Threading (:group 'mh-thread) -(defcustom-mh mh-show-threads-flag nil +(defcustom mh-show-threads-flag nil "Non-nil means new folders start in threaded mode. Threading large number of messages can be time consuming so this @@ -3106,7 +3052,7 @@ threaded is less than `mh-large-folder'." ;; mh-tool-bar-folder-buttons and mh-tool-bar-letter-buttons defined ;; dynamically in mh-tool-bar.el. -(defcustom-mh mh-tool-bar-search-function 'mh-search +(defcustom mh-tool-bar-search-function 'mh-search "Function called by the tool bar search button. By default, this is set to `mh-search'. You can also choose @@ -3117,47 +3063,11 @@ of your own choosing." :group 'mh-tool-bar :package-version '(MH-E . "7.0")) -;; XEmacs has a couple of extra customizations... -(mh-do-in-xemacs - (defcustom-mh mh-xemacs-use-tool-bar-flag mh-xemacs-has-tool-bar-flag - "If non-nil, use tool bar. - -This option controls whether to show the MH-E icons at all. By -default, this option is turned on if the window system supports -tool bars. If your system doesn't support tool bars, then you -won't be able to turn on this option." - :type 'boolean - :group 'mh-tool-bar - :set (lambda (symbol value) - (if (and (eq value t) - (not mh-xemacs-has-tool-bar-flag)) - (error "Tool bar not supported")) - (set-default symbol value)) - :package-version '(MH-E . "7.3")) - - (defcustom-mh mh-xemacs-tool-bar-position nil - "Tool bar location. - -This option controls the placement of the tool bar along the four -edges of the frame. You can choose from one of \"Same As Default -Tool Bar\", \"Top\", \"Bottom\", \"Left\", or \"Right\". If this -variable is set to anything other than \"Same As Default Tool -Bar\" and the default tool bar is in a different location, then -two tool bars will be displayed: the MH-E tool bar and the -default tool bar." - :type '(radio (const :tag "Same As Default Tool Bar" :value nil) - (const :tag "Top" :value top) - (const :tag "Bottom" :value bottom) - (const :tag "Left" :value left) - (const :tag "Right" :value right)) - :group 'mh-tool-bar - :package-version '(MH-E . "7.3"))) - ;;; Hooks (:group 'mh-hooks + group where hook described) -(defcustom-mh mh-after-commands-processed-hook nil +(defcustom mh-after-commands-processed-hook nil "Hook run by \\<mh-folder-mode-map>\\[mh-execute-commands] after performing outstanding refile and delete requests. Variables that are useful in this hook include @@ -3169,14 +3079,14 @@ folder, which is also available in `mh-current-folder'." :group 'mh-folder :package-version '(MH-E . "8.0")) -(defcustom-mh mh-alias-reloaded-hook nil +(defcustom mh-alias-reloaded-hook nil "Hook run by `mh-alias-reload' after loading aliases." :type 'hook :group 'mh-hooks :group 'mh-alias :package-version '(MH-E . "8.0")) -(defcustom-mh mh-annotate-msg-hook nil +(defcustom mh-annotate-msg-hook nil "Hook run when a message is sent and after annotating the scan lines and message. Hook functions can access the current folder name with `mh-current-folder' and obtain the message numbers of the @@ -3186,7 +3096,7 @@ annotated messages with `mh-annotate-list'." :group 'mh-sending-mail :package-version '(MH-E . "8.1")) -(defcustom-mh mh-before-commands-processed-hook nil +(defcustom mh-before-commands-processed-hook nil "Hook run by \\<mh-folder-mode-map>\\[mh-execute-commands] before performing outstanding refile and delete requests. Variables that are useful in this hook include `mh-delete-list', @@ -3198,7 +3108,7 @@ used to see which changes will be made to the current folder, :group 'mh-folder :package-version '(MH-E . "8.0")) -(defcustom-mh mh-before-quit-hook nil +(defcustom mh-before-quit-hook nil "Hook run by \\<mh-folder-mode-map>\\[mh-quit] before quitting MH-E. This hook is called before the quit occurs, so you might use it @@ -3211,7 +3121,7 @@ See also `mh-quit-hook'." :group 'mh-folder :package-version '(MH-E . "6.0")) -(defcustom-mh mh-before-send-letter-hook nil +(defcustom mh-before-send-letter-hook nil "Hook run at the beginning of the \\<mh-letter-mode-map>\\[mh-send-letter] command. For example, if you want to check your spelling in your message @@ -3222,14 +3132,14 @@ before sending, add the `ispell-message' function." :group 'mh-letter :package-version '(MH-E . "6.0")) -(defcustom-mh mh-blocklist-msg-hook nil +(defcustom mh-blocklist-msg-hook nil "Hook run by \\<mh-letter-mode-map>\\[mh-junk-blocklist] after marking each message for blocklisting." :type 'hook :group 'mh-hooks :group 'mh-show :package-version '(MH-E . "8.4")) -(defcustom-mh mh-delete-msg-hook nil +(defcustom mh-delete-msg-hook nil "Hook run by \\<mh-letter-mode-map>\\[mh-delete-msg] after marking each message for deletion. For example, a past maintainer of MH-E used this once when he @@ -3239,7 +3149,7 @@ kept statistics on his mail usage." :group 'mh-show :package-version '(MH-E . "6.0")) -(defcustom-mh mh-find-path-hook nil +(defcustom mh-find-path-hook nil "Hook run by `mh-find-path' after reading the user's MH profile. This hook can be used the change the value of the variables that @@ -3250,28 +3160,28 @@ between MH and MH-E." :group 'mh-e :package-version '(MH-E . "7.0")) -(defcustom-mh mh-folder-mode-hook nil +(defcustom mh-folder-mode-hook nil "Hook run by `mh-folder-mode' when visiting a new folder." :type 'hook :group 'mh-hooks :group 'mh-folder :package-version '(MH-E . "6.0")) -(defcustom-mh mh-forward-hook nil +(defcustom mh-forward-hook nil "Hook run by `mh-forward' on a forwarded letter." :type 'hook :group 'mh-hooks :group 'mh-sending-mail :package-version '(MH-E . "8.0")) -(defcustom-mh mh-inc-folder-hook nil +(defcustom mh-inc-folder-hook nil "Hook run by \\<mh-folder-mode-map>\\[mh-inc-folder] after incorporating mail into a folder." :type 'hook :group 'mh-hooks :group 'mh-inc :package-version '(MH-E . "6.0")) -(defcustom-mh mh-insert-signature-hook nil +(defcustom mh-insert-signature-hook nil "Hook run by \\<mh-letter-mode-map>\\[mh-insert-signature] after signature has been inserted. Hook functions may access the actual name of the file or the @@ -3282,9 +3192,9 @@ function used to insert the signature with :group 'mh-letter :package-version '(MH-E . "8.0")) -(mh-define-obsolete-variable-alias 'mh-kill-folder-suppress-prompt-hooks +(define-obsolete-variable-alias 'mh-kill-folder-suppress-prompt-hooks 'mh-kill-folder-suppress-prompt-functions "24.3") -(defcustom-mh mh-kill-folder-suppress-prompt-functions '(mh-search-p) +(defcustom mh-kill-folder-suppress-prompt-functions '(mh-search-p) "Abnormal hook run at the beginning of \\<mh-folder-mode-map>\\[mh-kill-folder]. The hook functions are called with no arguments and should return @@ -3302,7 +3212,7 @@ accident in the \"+inbox\" folder, you will not be happy." :group 'mh-folder :package-version '(MH-E . "7.4")) -(defcustom-mh mh-letter-mode-hook nil +(defcustom mh-letter-mode-hook nil "Hook run by `mh-letter-mode' on a new letter. This hook allows you to do some processing before editing a @@ -3315,14 +3225,14 @@ go." :group 'mh-sending-mail :package-version '(MH-E . "6.0")) -(defcustom-mh mh-mh-to-mime-hook nil +(defcustom mh-mh-to-mime-hook nil "Hook run on the formatted letter by \\<mh-letter-mode-map>\\[mh-mh-to-mime]." :type 'hook :group 'mh-hooks :group 'mh-letter :package-version '(MH-E . "8.0")) -(defcustom-mh mh-search-mode-hook nil +(defcustom mh-search-mode-hook nil "Hook run upon entry to `mh-search-mode'\\<mh-folder-mode-map>. If you find that you do the same thing over and over when editing @@ -3334,7 +3244,7 @@ This can be done with this hook which is called when :group 'mh-search :package-version '(MH-E . "8.0")) -(defcustom-mh mh-pack-folder-hook nil +(defcustom mh-pack-folder-hook nil "Hook run by \\<mh-folder-mode-map>\\[mh-pack-folder] after renumbering the messages. Hook functions can access the current folder name with `mh-current-folder'." :type 'hook @@ -3342,7 +3252,7 @@ Hook functions can access the current folder name with `mh-current-folder'." :group 'mh-folder :package-version '(MH-E . "8.2")) -(defcustom-mh mh-quit-hook nil +(defcustom mh-quit-hook nil "Hook run by \\<mh-folder-mode-map>\\[mh-quit] after quitting MH-E. This hook is not run in an MH-E context, so you might use it to @@ -3354,14 +3264,14 @@ See also `mh-before-quit-hook'." :group 'mh-folder :package-version '(MH-E . "6.0")) -(defcustom-mh mh-refile-msg-hook nil +(defcustom mh-refile-msg-hook nil "Hook run by \\<mh-folder-mode-map>\\[mh-refile-msg] after marking each message for refiling." :type 'hook :group 'mh-hooks :group 'mh-folder :package-version '(MH-E . "6.0")) -(defcustom-mh mh-show-hook nil +(defcustom mh-show-hook nil "Hook run after \\<mh-folder-mode-map>\\[mh-show] shows a message. It is the last thing called after messages are displayed. It's @@ -3372,7 +3282,7 @@ used to affect the behavior of MH-E in general or when :group 'mh-show :package-version '(MH-E . "6.0")) -(defcustom-mh mh-show-mode-hook nil +(defcustom mh-show-mode-hook nil "Hook run upon entry to `mh-show-mode'. This hook is called early on in the process of the message display, @@ -3384,7 +3294,7 @@ buffer itself. See also `mh-show-hook'." :group 'mh-show :package-version '(MH-E . "8.7")) -(defcustom-mh mh-unseen-updated-hook nil +(defcustom mh-unseen-updated-hook nil "Hook run after the unseen sequence has been updated. The variable `mh-seen-list' can be used by this hook to obtain @@ -3395,7 +3305,7 @@ sequence." :group 'mh-sequences :package-version '(MH-E . "6.0")) -(defcustom-mh mh-allowlist-msg-hook nil +(defcustom mh-allowlist-msg-hook nil "Hook run by \\<mh-letter-mode-map>\\[mh-junk-allowlist] after marking each message for allowlisting." :type 'hook :group 'mh-hooks @@ -3406,15 +3316,10 @@ sequence." ;;; Faces (:group 'mh-faces + group where faces described) -(if (boundp 'facemenu-unlisted-faces) - ;; This variable was removed in Emacs 22.1. - (add-to-list 'facemenu-unlisted-faces "^mh-")) - ;; To add a new face: ;; 1. Add entry to variable mh-face-data. -;; 2. Create face using defface-mh (which removes min-color spec and -;; :package-version keyword where these are not supported), -;; accessing face data with function mh-face-data. +;; 2. Create face using defface, accessing face data with function +;; mh-face-data. ;; 3. Add inherit argument to function mh-face-data if applicable. (defvar mh-face-data '((mh-folder-followup @@ -3561,18 +3466,17 @@ sequence." (:underline t))))) "MH-E face data. Used by function `mh-face-data' which returns spec that is -consumed by `defface-mh'.") +consumed by `defface'.") (require 'cus-face) -(defvar mh-inherit-face-flag (assq :inherit custom-face-attributes) - "Non-nil means that the `defface' :inherit keyword is available. -The :inherit keyword is available on all supported versions of -GNU Emacs and XEmacs from at least 21.5.23 on.") +(defvar mh-inherit-face-flag t + "Non-nil means that the `defface' :inherit keyword is available.") +(make-obsolete-variable 'mh-inherit-face-flag nil "29.1") -(defvar mh-min-colors-defined-flag (and (not (featurep 'xemacs)) - (>= emacs-major-version 22)) +(defvar mh-min-colors-defined-flag t "Non-nil means `defface' supports min-colors display requirement.") +(make-obsolete-variable 'mh-min-colors-defined-flag nil "29.1") (defun mh-face-data (face &optional inherit) "Return spec for FACE. @@ -3583,53 +3487,26 @@ keyword, return INHERIT literally; otherwise, return spec for FACE from the variable `mh-face-data'. This isn't a perfect implementation. In the case that the :inherit keyword is not supported, any additional attributes in the inherit parameter are -not added to the returned spec. - -Furthermore, when `mh-min-colors-defined-flag' is nil, this -function finds display entries with \"min-colors\" requirements -and either removes the \"min-colors\" requirement or strips the -display entirely if the display does not support the number of -specified colors." - (let ((spec - (if (and inherit mh-inherit-face-flag) - inherit - (or (cadr (assq face mh-face-data)) - (error "Could not find %s in mh-face-data" face))))) - - (if mh-min-colors-defined-flag - spec - (let ((cells (mh-display-color-cells)) - new-spec) - ;; Remove entries with min-colors, or delete them if we have - ;; fewer colors than they specify. - (cl-loop - for entry in (reverse spec) do - (let ((requirement (if (eq (car entry) t) - nil - (assq 'min-colors (car entry))))) - (if requirement - (when (>= cells (nth 1 requirement)) - (setq new-spec (cons (cons (delq requirement (car entry)) - (cdr entry)) - new-spec))) - (setq new-spec (cons entry new-spec))))) - new-spec)))) - -(defface-mh mh-folder-address +not added to the returned spec." + (or inherit + (cadr (assq face mh-face-data)) + (error "Could not find %s in mh-face-data" face))) + +(defface mh-folder-address (mh-face-data 'mh-folder-subject '((t (:inherit mh-folder-subject)))) "Recipient face." :group 'mh-faces :group 'mh-folder :package-version '(MH-E . "8.0")) -(defface-mh mh-folder-blocklisted +(defface mh-folder-blocklisted (mh-face-data 'mh-folder-msg-number '((t (:inherit mh-folder-msg-number)))) "Blocklisted message face." :group 'mh-faces :group 'mh-folder :package-version '(MH-E . "8.4")) -(defface-mh mh-folder-body +(defface mh-folder-body (mh-face-data 'mh-folder-msg-number '((((class color)) (:inherit mh-folder-msg-number)) @@ -3640,7 +3517,7 @@ specified colors." :group 'mh-folder :package-version '(MH-E . "8.0")) -(defface-mh mh-folder-cur-msg-number +(defface mh-folder-cur-msg-number (mh-face-data 'mh-folder-msg-number '((t (:inherit mh-folder-msg-number :bold t)))) "Current message number face." @@ -3648,39 +3525,39 @@ specified colors." :group 'mh-folder :package-version '(MH-E . "8.0")) -(defface-mh mh-folder-date +(defface mh-folder-date (mh-face-data 'mh-folder-msg-number '((t (:inherit mh-folder-msg-number)))) "Date face." :group 'mh-faces :group 'mh-folder :package-version '(MH-E . "8.0")) -(defface-mh mh-folder-deleted +(defface mh-folder-deleted (mh-face-data 'mh-folder-msg-number '((t (:inherit mh-folder-msg-number)))) "Deleted message face." :group 'mh-faces :group 'mh-folder :package-version '(MH-E . "8.0")) -(defface-mh mh-folder-followup (mh-face-data 'mh-folder-followup) +(defface mh-folder-followup (mh-face-data 'mh-folder-followup) "\"Re:\" face." :group 'mh-faces :group 'mh-folder :package-version '(MH-E . "8.0")) -(defface-mh mh-folder-msg-number (mh-face-data 'mh-folder-msg-number) +(defface mh-folder-msg-number (mh-face-data 'mh-folder-msg-number) "Message number face." :group 'mh-faces :group 'mh-folder :package-version '(MH-E . "8.0")) -(defface-mh mh-folder-refiled (mh-face-data 'mh-folder-refiled) +(defface mh-folder-refiled (mh-face-data 'mh-folder-refiled) "Refiled message face." :group 'mh-faces :group 'mh-folder :package-version '(MH-E . "8.0")) -(defface-mh mh-folder-sent-to-me-hint +(defface mh-folder-sent-to-me-hint (mh-face-data 'mh-folder-msg-number '((t (:inherit mh-folder-date)))) "Fontification hint face in messages sent directly to us. The detection of messages sent to us is governed by the scan @@ -3690,7 +3567,7 @@ format `mh-scan-format-nmh' and the regular expression :group 'mh-folder :package-version '(MH-E . "8.0")) -(defface-mh mh-folder-sent-to-me-sender +(defface mh-folder-sent-to-me-sender (mh-face-data 'mh-folder-followup '((t (:inherit mh-folder-followup)))) "Sender face in messages sent directly to us. The detection of messages sent to us is governed by the scan @@ -3700,105 +3577,105 @@ format `mh-scan-format-nmh' and the regular expression :group 'mh-folder :package-version '(MH-E . "8.0")) -(defface-mh mh-folder-subject (mh-face-data 'mh-folder-subject) +(defface mh-folder-subject (mh-face-data 'mh-folder-subject) "Subject face." :group 'mh-faces :group 'mh-folder :package-version '(MH-E . "8.0")) -(defface-mh mh-folder-tick (mh-face-data 'mh-folder-tick) +(defface mh-folder-tick (mh-face-data 'mh-folder-tick) "Ticked message face." :group 'mh-faces :group 'mh-folder :package-version '(MH-E . "8.0")) -(defface-mh mh-folder-to (mh-face-data 'mh-folder-to) +(defface mh-folder-to (mh-face-data 'mh-folder-to) "\"To:\" face." :group 'mh-faces :group 'mh-folder :package-version '(MH-E . "8.0")) -(defface-mh mh-folder-allowlisted +(defface mh-folder-allowlisted (mh-face-data 'mh-folder-refiled '((t (:inherit mh-folder-refiled)))) "Allowlisted message face." :group 'mh-faces :group 'mh-folder :package-version '(MH-E . "8.4")) -(defface-mh mh-letter-header-field (mh-face-data 'mh-letter-header-field) +(defface mh-letter-header-field (mh-face-data 'mh-letter-header-field) "Editable header field value face in draft buffers." :group 'mh-faces :group 'mh-letter :package-version '(MH-E . "8.0")) -(defface-mh mh-search-folder (mh-face-data 'mh-search-folder) +(defface mh-search-folder (mh-face-data 'mh-search-folder) "Folder heading face in MH-Folder buffers created by searches." :group 'mh-faces :group 'mh-search :package-version '(MH-E . "8.0")) -(defface-mh mh-show-cc (mh-face-data 'mh-show-cc) +(defface mh-show-cc (mh-face-data 'mh-show-cc) "Face used to highlight \"cc:\" header fields." :group 'mh-faces :group 'mh-show :package-version '(MH-E . "8.0")) -(defface-mh mh-show-date (mh-face-data 'mh-show-date) +(defface mh-show-date (mh-face-data 'mh-show-date) "Face used to highlight \"Date:\" header fields." :group 'mh-faces :group 'mh-show :package-version '(MH-E . "8.0")) -(defface-mh mh-show-from (mh-face-data 'mh-show-from) +(defface mh-show-from (mh-face-data 'mh-show-from) "Face used to highlight \"From:\" header fields." :group 'mh-faces :group 'mh-show :package-version '(MH-E . "8.0")) -(defface-mh mh-show-header (mh-face-data 'mh-show-header) +(defface mh-show-header (mh-face-data 'mh-show-header) "Face used to deemphasize less interesting header fields." :group 'mh-faces :group 'mh-show :package-version '(MH-E . "8.0")) -(defface-mh mh-show-pgg-bad (mh-face-data 'mh-show-pgg-bad) +(defface mh-show-pgg-bad (mh-face-data 'mh-show-pgg-bad) "Bad PGG signature face." :group 'mh-faces :group 'mh-show :package-version '(MH-E . "8.0")) -(defface-mh mh-show-pgg-good (mh-face-data 'mh-show-pgg-good) +(defface mh-show-pgg-good (mh-face-data 'mh-show-pgg-good) "Good PGG signature face." :group 'mh-faces :group 'mh-show :package-version '(MH-E . "8.0")) -(defface-mh mh-show-pgg-unknown (mh-face-data 'mh-show-pgg-unknown) +(defface mh-show-pgg-unknown (mh-face-data 'mh-show-pgg-unknown) "Unknown or untrusted PGG signature face." :group 'mh-faces :group 'mh-show :package-version '(MH-E . "8.0")) -(defface-mh mh-show-signature (mh-face-data 'mh-show-signature) +(defface mh-show-signature (mh-face-data 'mh-show-signature) "Signature face." :group 'mh-faces :group 'mh-show :package-version '(MH-E . "8.0")) -(defface-mh mh-show-subject +(defface mh-show-subject (mh-face-data 'mh-folder-subject '((t (:inherit mh-folder-subject)))) "Face used to highlight \"Subject:\" header fields." :group 'mh-faces :group 'mh-show :package-version '(MH-E . "8.0")) -(defface-mh mh-show-to (mh-face-data 'mh-show-to) +(defface mh-show-to (mh-face-data 'mh-show-to) "Face used to highlight \"To:\" header fields." :group 'mh-faces :group 'mh-show :package-version '(MH-E . "8.0")) -(defface-mh mh-show-xface +(defface mh-show-xface (mh-face-data 'mh-show-from '((t (:inherit (mh-show-from highlight))))) "X-Face image face. The background and foreground are used in the image." @@ -3806,13 +3683,13 @@ The background and foreground are used in the image." :group 'mh-show :package-version '(MH-E . "8.0")) -(defface-mh mh-speedbar-folder (mh-face-data 'mh-speedbar-folder) +(defface mh-speedbar-folder (mh-face-data 'mh-speedbar-folder) "Basic folder face." :group 'mh-faces :group 'mh-speedbar :package-version '(MH-E . "8.0")) -(defface-mh mh-speedbar-folder-with-unseen-messages +(defface mh-speedbar-folder-with-unseen-messages (mh-face-data 'mh-speedbar-folder '((t (:inherit mh-speedbar-folder :bold t)))) "Folder face when folder contains unread messages." @@ -3820,14 +3697,14 @@ The background and foreground are used in the image." :group 'mh-speedbar :package-version '(MH-E . "8.0")) -(defface-mh mh-speedbar-selected-folder +(defface mh-speedbar-selected-folder (mh-face-data 'mh-speedbar-selected-folder) "Selected folder face." :group 'mh-faces :group 'mh-speedbar :package-version '(MH-E . "8.0")) -(defface-mh mh-speedbar-selected-folder-with-unseen-messages +(defface mh-speedbar-selected-folder-with-unseen-messages (mh-face-data 'mh-speedbar-selected-folder '((t (:inherit mh-speedbar-selected-folder :bold t)))) "Selected folder face when folder contains unread messages." diff --git a/lisp/mh-e/mh-folder.el b/lisp/mh-e/mh-folder.el index 35277ae46a1..132ac33d269 100644 --- a/lisp/mh-e/mh-folder.el +++ b/lisp/mh-e/mh-folder.el @@ -72,10 +72,8 @@ the MH mail system." ;;; Desktop Integration -;; desktop-buffer-mode-handlers appeared in Emacs 22. -(if (boundp 'desktop-buffer-mode-handlers) - (add-to-list 'desktop-buffer-mode-handlers - '(mh-folder-mode . mh-restore-desktop-buffer))) +(add-to-list 'desktop-buffer-mode-handlers + '(mh-folder-mode . mh-restore-desktop-buffer)) (defun mh-restore-desktop-buffer (_file-name name _misc) "Restore an MH folder buffer specified in a desktop file. @@ -213,141 +211,137 @@ annotation.") (defalias 'mh-alt-visit-folder #'mh-visit-folder) ;; Save the "b" binding for a future `back'. Maybe? -(gnus-define-keys mh-folder-mode-map - " " mh-page-msg - "!" mh-refile-or-write-again - "'" mh-toggle-tick - "," mh-header-display - "." mh-alt-show - ":" mh-show-preferred-alternative - ";" mh-toggle-mh-decode-mime-flag - ">" mh-write-msg-to-file - "?" mh-help - "E" mh-extract-rejected-mail - "M" mh-modify - "\177" mh-previous-page - "\C-d" mh-delete-msg-no-motion - "\t" mh-index-next-folder - [backtab] mh-index-previous-folder - "\M-\t" mh-index-previous-folder - "\e<" mh-first-msg - "\e>" mh-last-msg - "\ed" mh-redistribute - "\r" mh-show - "^" mh-alt-refile-msg - "c" mh-copy-msg - "d" mh-delete-msg - "e" mh-edit-again - "f" mh-forward - "g" mh-goto-msg - "i" mh-inc-folder - "k" mh-delete-subject-or-thread - "m" mh-alt-send - "n" mh-next-undeleted-msg - "\M-n" mh-next-unread-msg - "o" mh-refile-msg - "p" mh-previous-undeleted-msg - "\M-p" mh-previous-unread-msg - "q" mh-quit - "r" mh-reply - "s" mh-send - "t" mh-toggle-showing - "u" mh-undo - "v" mh-index-visit-folder - "x" mh-execute-commands - "|" mh-pipe-msg) - -(gnus-define-keys (mh-folder-map "F" mh-folder-mode-map) - "?" mh-prefix-help - "'" mh-index-ticked-messages - "S" mh-sort-folder - "c" mh-catchup - "f" mh-alt-visit-folder - "k" mh-kill-folder - "l" mh-list-folders - "n" mh-index-new-messages - "o" mh-alt-visit-folder - "p" mh-pack-folder - "q" mh-index-sequenced-messages - "r" mh-rescan-folder - "s" mh-search - "u" mh-undo-folder - "v" mh-visit-folder) - -(define-key mh-folder-mode-map "I" mh-inc-spool-map) - -(gnus-define-keys (mh-junk-map "J" mh-folder-mode-map) - "?" mh-prefix-help - "a" mh-junk-allowlist - "b" mh-junk-blocklist - "w" mh-junk-whitelist) - -(gnus-define-keys (mh-ps-print-map "P" mh-folder-mode-map) - "?" mh-prefix-help - "C" mh-ps-print-toggle-color - "F" mh-ps-print-toggle-faces - "f" mh-ps-print-msg-file - "l" mh-print-msg - "p" mh-ps-print-msg) - -(gnus-define-keys (mh-sequence-map "S" mh-folder-mode-map) - "'" mh-narrow-to-tick - "?" mh-prefix-help - "d" mh-delete-msg-from-seq - "k" mh-delete-seq - "l" mh-list-sequences - "n" mh-narrow-to-seq - "p" mh-put-msg-in-seq - "s" mh-msg-is-in-seq - "w" mh-widen) - -(gnus-define-keys (mh-thread-map "T" mh-folder-mode-map) - "?" mh-prefix-help - "u" mh-thread-ancestor - "p" mh-thread-previous-sibling - "n" mh-thread-next-sibling - "t" mh-toggle-threads - "d" mh-thread-delete - "o" mh-thread-refile) - -(gnus-define-keys (mh-limit-map "/" mh-folder-mode-map) - "'" mh-narrow-to-tick - "?" mh-prefix-help - "c" mh-narrow-to-cc - "g" mh-narrow-to-range - "m" mh-narrow-to-from - "s" mh-narrow-to-subject - "t" mh-narrow-to-to - "w" mh-widen) - -(gnus-define-keys (mh-extract-map "X" mh-folder-mode-map) - "?" mh-prefix-help - "s" mh-store-msg ;shar - "u" mh-store-msg) ;uuencode - -(gnus-define-keys (mh-digest-map "D" mh-folder-mode-map) - " " mh-page-digest - "?" mh-prefix-help - "\177" mh-page-digest-backwards - "b" mh-burst-digest) - -(gnus-define-keys (mh-mime-map "K" mh-folder-mode-map) - "?" mh-prefix-help - "a" mh-mime-save-parts - "e" mh-display-with-external-viewer - "i" mh-folder-inline-mime-part - "o" mh-folder-save-mime-part - "t" mh-toggle-mime-buttons - "v" mh-folder-toggle-mime-part - "\t" mh-next-button - [backtab] mh-prev-button - "\M-\t" mh-prev-button) - -(cond - ((featurep 'xemacs) - (define-key mh-folder-mode-map [button2] 'mh-show-mouse)) - (t - (define-key mh-folder-mode-map [mouse-2] 'mh-show-mouse))) +(define-keymap :keymap mh-folder-mode-map + "SPC" #'mh-page-msg + "!" #'mh-refile-or-write-again + "'" #'mh-toggle-tick + "," #'mh-header-display + "." #'mh-alt-show + ":" #'mh-show-preferred-alternative + ";" #'mh-toggle-mh-decode-mime-flag + ">" #'mh-write-msg-to-file + "?" #'mh-help + "E" #'mh-extract-rejected-mail + "M" #'mh-modify + "DEL" #'mh-previous-page + "C-d" #'mh-delete-msg-no-motion + "TAB" #'mh-index-next-folder + "<backtab>" #'mh-index-previous-folder + "C-M-i" #'mh-index-previous-folder + "ESC <" #'mh-first-msg + "ESC >" #'mh-last-msg + "ESC d" #'mh-redistribute + "RET" #'mh-show + "^" #'mh-alt-refile-msg + "c" #'mh-copy-msg + "d" #'mh-delete-msg + "e" #'mh-edit-again + "f" #'mh-forward + "g" #'mh-goto-msg + "i" #'mh-inc-folder + "k" #'mh-delete-subject-or-thread + "m" #'mh-alt-send + "n" #'mh-next-undeleted-msg + "M-n" #'mh-next-unread-msg + "o" #'mh-refile-msg + "p" #'mh-previous-undeleted-msg + "M-p" #'mh-previous-unread-msg + "q" #'mh-quit + "r" #'mh-reply + "s" #'mh-send + "t" #'mh-toggle-showing + "u" #'mh-undo + "v" #'mh-index-visit-folder + "x" #'mh-execute-commands + "|" #'mh-pipe-msg + + "F" (define-keymap :prefix 'mh-folder-map + "?" #'mh-prefix-help + "'" #'mh-index-ticked-messages + "S" #'mh-sort-folder + "c" #'mh-catchup + "f" #'mh-alt-visit-folder + "k" #'mh-kill-folder + "l" #'mh-list-folders + "n" #'mh-index-new-messages + "o" #'mh-alt-visit-folder + "p" #'mh-pack-folder + "q" #'mh-index-sequenced-messages + "r" #'mh-rescan-folder + "s" #'mh-search + "u" #'mh-undo-folder + "v" #'mh-visit-folder) + + "I" mh-inc-spool-map + + "J" (define-keymap :prefix 'mh-junk-map + "?" #'mh-prefix-help + "a" #'mh-junk-allowlist + "b" #'mh-junk-blocklist + "w" #'mh-junk-whitelist) + + "P" (define-keymap :prefix 'mh-ps-print-map + "?" #'mh-prefix-help + "C" #'mh-ps-print-toggle-color + "F" #'mh-ps-print-toggle-faces + "f" #'mh-ps-print-msg-file + "l" #'mh-print-msg + "p" #'mh-ps-print-msg) + + "S" (define-keymap :prefix 'mh-sequence-map + "'" #'mh-narrow-to-tick + "?" #'mh-prefix-help + "d" #'mh-delete-msg-from-seq + "k" #'mh-delete-seq + "l" #'mh-list-sequences + "n" #'mh-narrow-to-seq + "p" #'mh-put-msg-in-seq + "s" #'mh-msg-is-in-seq + "w" #'mh-widen) + + "T" (define-keymap :prefix 'mh-thread-map + "?" #'mh-prefix-help + "u" #'mh-thread-ancestor + "p" #'mh-thread-previous-sibling + "n" #'mh-thread-next-sibling + "t" #'mh-toggle-threads + "d" #'mh-thread-delete + "o" #'mh-thread-refile) + + "/" (define-keymap :prefix 'mh-limit-map + "'" #'mh-narrow-to-tick + "?" #'mh-prefix-help + "c" #'mh-narrow-to-cc + "g" #'mh-narrow-to-range + "m" #'mh-narrow-to-from + "s" #'mh-narrow-to-subject + "t" #'mh-narrow-to-to + "w" #'mh-widen) + + "X" (define-keymap :prefix 'mh-extract-map + "?" #'mh-prefix-help + "s" #'mh-store-msg ;shar + "u" #'mh-store-msg) ;uuencode + + "D" (define-keymap :prefix 'mh-digest-map + "SPC" #'mh-page-digest + "?" #'mh-prefix-help + "DEL" #'mh-page-digest-backwards + "b" #'mh-burst-digest) + + "K" (define-keymap :prefix 'mh-mime-map + "?" #'mh-prefix-help + "a" #'mh-mime-save-parts + "e" #'mh-display-with-external-viewer + "i" #'mh-folder-inline-mime-part + "o" #'mh-folder-save-mime-part + "t" #'mh-toggle-mime-buttons + "v" #'mh-folder-toggle-mime-part + "TAB" #'mh-next-button + "<backtab>" #'mh-prev-button + "C-M-i" #'mh-prev-button) + + "<mouse-2>" #'mh-show-mouse) ;; "C-c /" prefix is used in mh-folder-mode by pgp.el and mailcrypt @@ -512,24 +506,14 @@ font-lock is done highlighting.") ;;; MH-Folder Mode (defmacro mh-remove-xemacs-horizontal-scrollbar () - "Get rid of the horizontal scrollbar that XEmacs insists on putting in." - (when (featurep 'xemacs) - '(if (and (featurep 'scrollbar) - (fboundp 'set-specifier)) - (set-specifier horizontal-scrollbar-visible-p nil - (cons (current-buffer) nil))))) + (declare (obsolete nil "29.1")) + nil) ;; Register mh-folder-mode as supporting which-function-mode... -(eval-and-compile (mh-require 'which-func nil t)) +(eval-and-compile (require 'which-func nil t)) (when (and (boundp 'which-func-modes) (listp which-func-modes)) (add-to-list 'which-func-modes 'mh-folder-mode)) -;; Shush compiler. -(defvar desktop-save-buffer) -(defvar font-lock-auto-fontify) -(mh-do-in-xemacs - (defvar font-lock-defaults)) - ;; Ensure new buffers won't get this mode if default major-mode is nil. (put 'mh-folder-mode 'mode-class 'special) @@ -590,80 +574,68 @@ region in the MH-Folder buffer, then the MH-E command will perform the operation on all messages in that region. \\{mh-folder-mode-map}" - (mh-do-in-gnu-emacs - (unless mh-folder-tool-bar-map - (mh-tool-bar-folder-buttons-init)) - (if (boundp 'tool-bar-map) - (set (make-local-variable 'tool-bar-map) mh-folder-tool-bar-map))) - (mh-do-in-xemacs - (mh-tool-bar-init :folder)) + (unless mh-folder-tool-bar-map + (mh-tool-bar-folder-buttons-init)) + (if (boundp 'tool-bar-map) + (setq-local tool-bar-map mh-folder-tool-bar-map)) (make-local-variable 'font-lock-defaults) (setq font-lock-defaults '(mh-folder-font-lock-keywords t)) (make-local-variable 'desktop-save-buffer) (setq desktop-save-buffer t) - (mh-make-local-vars - 'mh-colors-available-flag (mh-colors-available-p) + (setq-local + mh-colors-available-flag (mh-colors-available-p) ; Do we have colors available - 'mh-current-folder (buffer-name) ; Name of folder, a string - 'mh-show-buffer (format "show-%s" (buffer-name)) ; Buffer that displays msgs - 'mh-folder-filename ; e.g. "/usr/foobar/Mail/inbox/" + mh-current-folder (buffer-name) ; Name of folder, a string + mh-show-buffer (format "show-%s" (buffer-name)) ; Buffer that displays msgs + mh-folder-filename ; e.g. "/usr/foobar/Mail/inbox/" (file-name-as-directory (mh-expand-file-name (buffer-name))) - 'mh-display-buttons-for-inline-parts-flag + mh-display-buttons-for-inline-parts-flag mh-display-buttons-for-inline-parts-flag ; Allow for display of buttons to ; be toggled. - 'mh-arrow-marker (make-marker) ; Marker where arrow is displayed - 'overlay-arrow-position nil ; Allow for simultaneous display in - 'overlay-arrow-string ">" ; different MH-E buffers. - 'mh-showing-mode nil ; Show message also? - 'mh-refile-list nil ; List of folder names in mh-seq-list - 'mh-delete-list nil ; List of msgs nums to delete - 'mh-blocklist nil ; List of messages to process as spam - 'mh-allowlist nil ; List of messages to process as ham - 'mh-seq-list nil ; Alist of (seq . msgs) nums - 'mh-seen-list nil ; List of displayed messages - 'mh-next-direction 'forward ; Direction to move to next message - 'mh-view-ops () ; Stack that keeps track of the order + mh-arrow-marker (make-marker) ; Marker where arrow is displayed + overlay-arrow-position nil ; Allow for simultaneous display in + overlay-arrow-string ">" ; different MH-E buffers. + mh-showing-mode nil ; Show message also? + mh-refile-list nil ; List of folder names in mh-seq-list + mh-delete-list nil ; List of msgs nums to delete + mh-blocklist nil ; List of messages to process as spam + mh-allowlist nil ; List of messages to process as ham + mh-seq-list nil ; Alist of (seq . msgs) nums + mh-seen-list nil ; List of displayed messages + mh-next-direction 'forward ; Direction to move to next message + mh-view-ops () ; Stack that keeps track of the order ; in which narrowing/threading has been ; carried out. - 'mh-folder-view-stack () ; Stack of previous views of the + mh-folder-view-stack () ; Stack of previous views of the ; folder. - 'mh-index-data nil ; If the folder was created by a call + mh-index-data nil ; If the folder was created by a call ; to mh-search, this contains info ; about the search results. - 'mh-index-previous-search nil ; folder, indexer, search-regexp - 'mh-index-msg-checksum-map nil ; msg -> checksum map - 'mh-index-checksum-origin-map nil ; checksum -> ( orig-folder, orig-msg ) - 'mh-index-sequence-search-flag nil ; folder resulted from sequence search - 'mh-first-msg-num nil ; Number of first msg in buffer - 'mh-last-msg-num nil ; Number of last msg in buffer - 'mh-msg-count nil ; Number of msgs in buffer - 'mh-mode-line-annotation nil ; Indicates message range - 'mh-sequence-notation-history (make-hash-table) + mh-index-previous-search nil ; folder, indexer, search-regexp + mh-index-msg-checksum-map nil ; msg -> checksum map + mh-index-checksum-origin-map nil ; checksum -> ( orig-folder, orig-msg ) + mh-index-sequence-search-flag nil ; folder resulted from sequence search + mh-first-msg-num nil ; Number of first msg in buffer + mh-last-msg-num nil ; Number of last msg in buffer + mh-msg-count nil ; Number of msgs in buffer + mh-mode-line-annotation nil ; Indicates message range + mh-sequence-notation-history (make-hash-table) ; Remember what is overwritten by ; mh-note-seq. - 'imenu-create-index-function 'mh-index-create-imenu-index + imenu-create-index-function 'mh-index-create-imenu-index ; Setup imenu support - 'mh-previous-window-config nil) ; Previous window configuration - (mh-remove-xemacs-horizontal-scrollbar) + mh-previous-window-config nil) ; Previous window configuration (setq truncate-lines t) (auto-save-mode -1) (setq buffer-offer-save t) - (mh-make-local-hook (mh-write-file-functions)) - (add-hook (mh-write-file-functions) #'mh-execute-commands nil t) + (add-hook 'write-file-functions #'mh-execute-commands nil t) (make-local-variable 'revert-buffer-function) (make-local-variable 'hl-line-mode) ; avoid pollution - (mh-funcall-if-exists hl-line-mode 1) + (hl-line-mode 1) (setq revert-buffer-function #'mh-undo-folder) (add-to-list 'minor-mode-alist '(mh-showing-mode " Show")) - (mh-do-in-xemacs - (easy-menu-add mh-folder-sequence-menu) - (easy-menu-add mh-folder-message-menu) - (easy-menu-add mh-folder-folder-menu)) (mh-inc-spool-make) - (mh-set-help mh-folder-mode-help-messages) - (if (and (featurep 'xemacs) - font-lock-auto-fontify) - (turn-on-font-lock))) ; Force font-lock in XEmacs. + (mh-set-help mh-folder-mode-help-messages)) @@ -1571,35 +1543,35 @@ after the commands are processed." (append folders-changed (mh-index-execute-commands)))) ;; Then refile messages - (mh-mapc #'(lambda (folder-msg-list) - (let* ((dest-folder (symbol-name (car folder-msg-list))) - (last (car (mh-translate-range dest-folder "last"))) - (msgs (cdr folder-msg-list))) - (push dest-folder folders-changed) - (setq redraw-needed-flag t) - (apply #'mh-exec-cmd - "refile" "-src" folder dest-folder - (mh-coalesce-msg-list msgs)) - (mh-delete-scan-msgs msgs) - ;; Preserve sequences in destination folder... - (when mh-refile-preserves-sequences-flag - (clrhash dest-map) - (cl-loop - for i from (1+ (or last 0)) - for msg in (sort (copy-sequence msgs) #'<) - do (cl-loop for seq-name in (gethash msg seq-map) - do (push i (gethash seq-name dest-map)))) - (maphash - #'(lambda (seq msgs) - ;; Can't be run in the background, since the - ;; current folder is changed by mark this could - ;; lead to a race condition with the next refile. - (apply #'mh-exec-cmd "mark" - "-sequence" (symbol-name seq) dest-folder - "-add" (mapcar #'(lambda (x) (format "%s" x)) - (mh-coalesce-msg-list msgs)))) - dest-map)))) - mh-refile-list) + (mapc (lambda (folder-msg-list) + (let* ((dest-folder (symbol-name (car folder-msg-list))) + (last (car (mh-translate-range dest-folder "last"))) + (msgs (cdr folder-msg-list))) + (push dest-folder folders-changed) + (setq redraw-needed-flag t) + (apply #'mh-exec-cmd + "refile" "-src" folder dest-folder + (mh-coalesce-msg-list msgs)) + (mh-delete-scan-msgs msgs) + ;; Preserve sequences in destination folder... + (when mh-refile-preserves-sequences-flag + (clrhash dest-map) + (cl-loop + for i from (1+ (or last 0)) + for msg in (sort (copy-sequence msgs) #'<) + do (cl-loop for seq-name in (gethash msg seq-map) + do (push i (gethash seq-name dest-map)))) + (maphash + #'(lambda (seq msgs) + ;; Can't be run in the background, since the + ;; current folder is changed by mark this could + ;; lead to a race condition with the next refile. + (apply #'mh-exec-cmd "mark" + "-sequence" (symbol-name seq) dest-folder + "-add" (mapcar #'(lambda (x) (format "%s" x)) + (mh-coalesce-msg-list msgs)))) + dest-map)))) + mh-refile-list) (setq mh-refile-list ()) ;; Now delete messages @@ -1642,14 +1614,14 @@ after the commands are processed." do (cl-loop for seq-name in (gethash msg seq-map) do (push i (gethash seq-name allow-map)))) (maphash - #'(lambda (seq msgs) - ;; Can't be run in background, since the current - ;; folder is changed by mark this could lead to a - ;; race condition with the next refile/allowlist. - (apply #'mh-exec-cmd "mark" - "-sequence" (symbol-name seq) mh-inbox - "-add" (mapcar #'(lambda(x) (format "%s" x)) - (mh-coalesce-msg-list msgs)))) + (lambda (seq msgs) + ;; Can't be run in background, since the current + ;; folder is changed by mark this could lead to a + ;; race condition with the next refile/allowlist. + (apply #'mh-exec-cmd "mark" + "-sequence" (symbol-name seq) mh-inbox + "-add" (mapcar #'(lambda(x) (format "%s" x)) + (mh-coalesce-msg-list msgs)))) allow-map)) (setq mh-allowlist nil))) diff --git a/lisp/mh-e/mh-funcs.el b/lisp/mh-e/mh-funcs.el index 4a5e670c1ef..0c73aae0d79 100644 --- a/lisp/mh-e/mh-funcs.el +++ b/lisp/mh-e/mh-funcs.el @@ -147,7 +147,7 @@ Display the results only if something went wrong." "-recurse" "-norecurse")) (goto-char (point-min)) - (mh-view-mode-enter) + (view-mode-enter) (setq view-exit-action 'kill-buffer) (message "Listing folders...done"))))) diff --git a/lisp/mh-e/mh-gnus.el b/lisp/mh-e/mh-gnus.el index cc60f7b6640..0e1bde71f20 100644 --- a/lisp/mh-e/mh-gnus.el +++ b/lisp/mh-e/mh-gnus.el @@ -29,110 +29,49 @@ (require 'mh-e) (eval-and-compile - (mh-require 'gnus-util nil t) - (mh-require 'mm-bodies nil t) - (mh-require 'mm-decode nil t) - (mh-require 'mm-view nil t) - (mh-require 'mml nil t)) - -;; Copy of function from gnus-util.el. -;; TODO This is not in Gnus 5.11. -(defun-mh mh-gnus-local-map-property gnus-local-map-property (map) + (require 'gnus-util nil t) + (require 'mm-bodies nil t) + (require 'mm-decode nil t) + (require 'mm-view nil t) + (require 'mml nil t)) + +(defun mh-gnus-local-map-property (map) "Return a list suitable for a text property list specifying keymap MAP." - (cond ((featurep 'xemacs) (list 'keymap map)) - ((>= emacs-major-version 21) (list 'keymap map)) - (t (list 'local-map map)))) - -;; Copy of function from mm-decode.el. -(defun-mh mh-mm-merge-handles mm-merge-handles (handles1 handles2) - (append - (if (listp (car handles1)) - handles1 - (list handles1)) - (if (listp (car handles2)) - handles2 - (list handles2)))) - -;; Copy of function from mm-decode.el. -(defun-mh mh-mm-set-handle-multipart-parameter - mm-set-handle-multipart-parameter (handle parameter value) - ;; HANDLE could be a CTL. - (when handle - (put-text-property 0 (length (car handle)) parameter value - (car handle)))) - -;; Copy of function from mm-view.el. -(defun-mh mh-mm-inline-text-vcard mm-inline-text-vcard (handle) - (let ((inhibit-read-only t)) - (mm-insert-inline - handle - (concat "\n-- \n" - (ignore-errors - (if (fboundp 'vcard-pretty-print) - (vcard-pretty-print (mm-get-part handle)) - (vcard-format-string - (vcard-parse-string (mm-get-part handle) - 'vcard-standard-filter)))))))) - -;; Function from mm-decode.el used in PGP messages. Just define it with older -;; Gnus to avoid compiler warning. -(defun-mh mh-mm-possibly-verify-or-decrypt - mm-possibly-verify-or-decrypt (_parts _ctl) - nil) - -;; Copy of macro in mm-decode.el. -(defmacro-mh mh-mm-handle-multipart-ctl-parameter - mm-handle-multipart-ctl-parameter (handle parameter) - `(get-text-property 0 ,parameter (car ,handle))) - -;; Copy of function in mm-decode.el. -(defun-mh mh-mm-readable-p mm-readable-p (handle) - "Say whether the content of HANDLE is readable." - (and (< (with-current-buffer (mm-handle-buffer handle) - (buffer-size)) 10000) - (mm-with-unibyte-buffer - (mm-insert-part handle) - (and (eq (mm-body-7-or-8) '7bit) - (not (mh-mm-long-lines-p 76)))))) - -;; Copy of function in mm-bodies.el. -(defun-mh mh-mm-long-lines-p mm-long-lines-p (length) - "Say whether any of the lines in the buffer is longer than LENGTH." - (save-excursion - (goto-char (point-min)) - (end-of-line) - (while (and (not (eobp)) - (not (> (current-column) length))) - (forward-line 1) - (end-of-line)) - (and (> (current-column) length) - (current-column)))) - -(defun-mh mh-mm-keep-viewer-alive-p mm-keep-viewer-alive-p (_handle) - ;; Released Gnus doesn't keep handles associated with externally displayed - ;; MIME parts. So this will always return nil. - nil) - -(defun-mh mh-mm-destroy-parts mm-destroy-parts (_list) - "Older versions of Emacs don't have this function." - nil) - -(defun-mh mh-mm-uu-dissect-text-parts mm-uu-dissect-text-parts (_handles) - "Emacs 21 and XEmacs don't have this function." - nil) - -;; Copy of function in mml.el. -(defun-mh mh-mml-minibuffer-read-disposition - mml-minibuffer-read-disposition (type &optional default filename) - (unless default - (setq default (mml-content-disposition type filename))) - (let ((disposition (completing-read - (format-prompt "Disposition" default) - '(("attachment") ("inline") ("")) - nil t nil nil default))) - (if (not (equal disposition "")) - disposition - default))) + (declare (obsolete nil "29.1")) + (list 'keymap map)) + +(define-obsolete-function-alias 'mh-mm-merge-handles + #'mm-merge-handles "29.1") + +(define-obsolete-function-alias 'mh-mm-set-handle-multipart-parameter + #'mm-set-handle-multipart-parameter "29.1") + +(define-obsolete-function-alias 'mh-mm-inline-text-vcard + #'mm-inline-text-vcard "29.1") + +(define-obsolete-function-alias 'mh-mm-possibly-verify-or-decrypt + #'mm-possibly-verify-or-decrypt "29.1") + +(define-obsolete-function-alias 'mh-mm-handle-multipart-ctl-parameter + #'mm-handle-multipart-ctl-parameter "29.1") + +(define-obsolete-function-alias 'mh-mm-readable-p + #'mm-readable-p "29.1") + +(define-obsolete-function-alias 'mh-mm-long-lines-p + #'mm-long-lines-p "29.1") + +(define-obsolete-function-alias 'mh-mm-keep-viewer-alive-p + #'mm-keep-viewer-alive-p "29.1") + +(define-obsolete-function-alias 'mh-mm-destroy-parts + #'mm-destroy-parts "29.1") + +(define-obsolete-function-alias 'mh-mm-uu-dissect-text-parts + #'mm-uu-dissect-text-parts "29.1") + +(define-obsolete-function-alias 'mh-mml-minibuffer-read-disposition + #'mml-minibuffer-read-disposition "29.1") ;; This is mm-save-part from Gnus 5.11 since that function in Emacs ;; 21.2 is buggy (the args to read-file-name are incorrect) and the @@ -163,8 +102,8 @@ PROMPT overrides the default one used to ask user for a file name." (defun mh-mm-text-html-renderer () "Find the renderer Gnus is using to display text/html MIME parts." - (or (and (boundp 'mm-inline-text-html-renderer) mm-inline-text-html-renderer) - (and (boundp 'mm-text-html-renderer) mm-text-html-renderer))) + (declare (obsolete mm-text-html-renderer "29.1")) + mm-text-html-renderer) (provide 'mh-gnus) diff --git a/lisp/mh-e/mh-identity.el b/lisp/mh-e/mh-identity.el index ceede0d07cb..994ab713915 100644 --- a/lisp/mh-e/mh-identity.el +++ b/lisp/mh-e/mh-identity.el @@ -39,11 +39,10 @@ (autoload 'mml-insert-tag "mml") -(defvar mh-identity-pgg-default-user-id nil +(defvar-local mh-identity-pgg-default-user-id nil "Holds the GPG key ID to be used by pgg.el. This is normally set as part of an Identity in `mh-identity-list'.") -(make-variable-buffer-local 'mh-identity-pgg-default-user-id) (defvar mh-identity-menu nil "The Identity menu.") @@ -54,8 +53,7 @@ This is normally set as part of an Identity in (defun mh-identity-make-menu () "Build the Identity menu. This should be called any time `mh-identity-list' or -`mh-auto-fields-list' change. -See `mh-identity-add-menu'." +`mh-auto-fields-list' change." (easy-menu-define mh-identity-menu mh-letter-mode-map "MH-E identity menu" (append @@ -88,12 +86,11 @@ See `mh-identity-add-menu'." (defun mh-identity-add-menu () "Add the current Identity menu. See `mh-identity-make-menu'." - (if mh-identity-menu - (mh-do-in-xemacs (easy-menu-add mh-identity-menu)))) + (declare (obsolete nil "29.1")) + nil) -(defvar mh-identity-local nil +(defvar-local mh-identity-local nil "Buffer-local variable that holds the identity currently in use.") -(make-variable-buffer-local 'mh-identity-local) (defun mh-header-field-delete (field value-only) "Delete header FIELD, or only its value if VALUE-ONLY is t. @@ -122,7 +119,7 @@ The field name is downcased. If the FIELD begins with the character \":\", then it must have a special handler defined in `mh-identity-handlers', else return an error since it is not a valid header field." - (or (cdr (mh-assoc-string field mh-identity-handlers t)) + (or (cdr (assoc-string field mh-identity-handlers t)) (and (eq (aref field 0) ?:) (error "Field %s not found in `mh-identity-handlers'" field)) (cdr (assoc ":default" mh-identity-handlers)) @@ -235,11 +232,9 @@ added." (if (null value) (mh-insert-signature) (mh-insert-signature value)) - (set (make-local-variable 'mh-identity-signature-start) - (point-min-marker)) + (setq-local mh-identity-signature-start (point-min-marker)) (set-marker-insertion-type mh-identity-signature-start t) - (set (make-local-variable 'mh-identity-signature-end) - (point-max-marker))))))) + (setq-local mh-identity-signature-end (point-max-marker))))))) (defvar mh-identity-attribution-verb-start nil "Marker for the beginning of the attribution verb.") @@ -271,11 +266,9 @@ If VALUE is nil, use `mh-extract-from-attribution-verb'." (if (null value) (insert mh-extract-from-attribution-verb) (insert value)) - (set (make-local-variable 'mh-identity-attribution-verb-start) - (point-min-marker)) + (setq-local mh-identity-attribution-verb-start (point-min-marker)) (set-marker-insertion-type mh-identity-attribution-verb-start t) - (set (make-local-variable 'mh-identity-attribution-verb-end) - (point-max-marker)))) + (setq-local mh-identity-attribution-verb-end (point-max-marker)))) (defun mh-identity-handler-default (field action top &optional value) "Process header FIELD. diff --git a/lisp/mh-e/mh-letter.el b/lisp/mh-e/mh-letter.el index ae5b80d5807..ebe94a7af83 100644 --- a/lisp/mh-e/mh-letter.el +++ b/lisp/mh-e/mh-letter.el @@ -114,68 +114,68 @@ ;;; MH-Letter Keys ;; If this changes, modify mh-letter-mode-help-messages accordingly, above. -(gnus-define-keys mh-letter-mode-map - " " mh-letter-complete-or-space - "," mh-letter-confirm-address - "\C-c?" mh-help - "\C-c\C-\\" mh-fully-kill-draft ;if no C-q - "\C-c\C-^" mh-insert-signature ;if no C-s - "\C-c\C-c" mh-send-letter - "\C-c\C-d" mh-insert-identity - "\C-c\C-e" mh-mh-to-mime - "\C-c\C-f\C-a" mh-to-field - "\C-c\C-f\C-b" mh-to-field - "\C-c\C-f\C-c" mh-to-field - "\C-c\C-f\C-d" mh-to-field - "\C-c\C-f\C-f" mh-to-fcc - "\C-c\C-f\C-l" mh-to-field - "\C-c\C-f\C-m" mh-to-field - "\C-c\C-f\C-r" mh-to-field - "\C-c\C-f\C-s" mh-to-field - "\C-c\C-f\C-t" mh-to-field - "\C-c\C-fa" mh-to-field - "\C-c\C-fb" mh-to-field - "\C-c\C-fc" mh-to-field - "\C-c\C-fd" mh-to-field - "\C-c\C-ff" mh-to-fcc - "\C-c\C-fl" mh-to-field - "\C-c\C-fm" mh-to-field - "\C-c\C-fr" mh-to-field - "\C-c\C-fs" mh-to-field - "\C-c\C-ft" mh-to-field - "\C-c\C-i" mh-insert-letter - "\C-c\C-m\C-e" mh-mml-secure-message-encrypt - "\C-c\C-m\C-f" mh-compose-forward - "\C-c\C-m\C-g" mh-mh-compose-anon-ftp - "\C-c\C-m\C-i" mh-compose-insertion - "\C-c\C-m\C-m" mh-mml-to-mime - "\C-c\C-m\C-n" mh-mml-unsecure-message - "\C-c\C-m\C-s" mh-mml-secure-message-sign - "\C-c\C-m\C-t" mh-mh-compose-external-compressed-tar - "\C-c\C-m\C-u" mh-mh-to-mime-undo - "\C-c\C-m\C-x" mh-mh-compose-external-type - "\C-c\C-mee" mh-mml-secure-message-encrypt - "\C-c\C-mes" mh-mml-secure-message-signencrypt - "\C-c\C-mf" mh-compose-forward - "\C-c\C-mg" mh-mh-compose-anon-ftp - "\C-c\C-mi" mh-compose-insertion - "\C-c\C-mm" mh-mml-to-mime - "\C-c\C-mn" mh-mml-unsecure-message - "\C-c\C-mse" mh-mml-secure-message-signencrypt - "\C-c\C-mss" mh-mml-secure-message-sign - "\C-c\C-mt" mh-mh-compose-external-compressed-tar - "\C-c\C-mu" mh-mh-to-mime-undo - "\C-c\C-mx" mh-mh-compose-external-type - "\C-c\C-o" mh-open-line - "\C-c\C-q" mh-fully-kill-draft - "\C-c\C-s" mh-insert-signature - "\C-c\C-t" mh-letter-toggle-header-field-display - "\C-c\C-w" mh-check-whom - "\C-c\C-y" mh-yank-cur-msg - "\C-c\M-d" mh-insert-auto-fields - "\M-\t" mh-letter-complete - "\t" mh-letter-next-header-field-or-indent - [backtab] mh-letter-previous-header-field) +(define-keymap :keymap mh-letter-mode-map + "SPC" #'mh-letter-complete-or-space + "," #'mh-letter-confirm-address + "C-c ?" #'mh-help + "C-c C-\\" #'mh-fully-kill-draft ;if no C-q + "C-c C-^" #'mh-insert-signature ;if no C-s + "C-c C-c" #'mh-send-letter + "C-c C-d" #'mh-insert-identity + "C-c C-e" #'mh-mh-to-mime + "C-c C-f C-a" #'mh-to-field + "C-c C-f C-b" #'mh-to-field + "C-c C-f C-c" #'mh-to-field + "C-c C-f C-d" #'mh-to-field + "C-c C-f C-f" #'mh-to-fcc + "C-c C-f C-l" #'mh-to-field + "C-c C-f C-m" #'mh-to-field + "C-c C-f C-r" #'mh-to-field + "C-c C-f C-s" #'mh-to-field + "C-c C-f C-t" #'mh-to-field + "C-c C-f a" #'mh-to-field + "C-c C-f b" #'mh-to-field + "C-c C-f c" #'mh-to-field + "C-c C-f d" #'mh-to-field + "C-c C-f f" #'mh-to-fcc + "C-c C-f l" #'mh-to-field + "C-c C-f m" #'mh-to-field + "C-c C-f r" #'mh-to-field + "C-c C-f s" #'mh-to-field + "C-c C-f t" #'mh-to-field + "C-c C-i" #'mh-insert-letter + "C-c C-m C-e" #'mh-mml-secure-message-encrypt + "C-c C-m C-f" #'mh-compose-forward + "C-c C-m C-g" #'mh-mh-compose-anon-ftp + "C-c C-m TAB" #'mh-compose-insertion + "C-c C-m C-m" #'mh-mml-to-mime + "C-c C-m C-n" #'mh-mml-unsecure-message + "C-c C-m C-s" #'mh-mml-secure-message-sign + "C-c C-m C-t" #'mh-mh-compose-external-compressed-tar + "C-c C-m C-u" #'mh-mh-to-mime-undo + "C-c C-m C-x" #'mh-mh-compose-external-type + "C-c C-m e e" #'mh-mml-secure-message-encrypt + "C-c C-m e s" #'mh-mml-secure-message-signencrypt + "C-c C-m f" #'mh-compose-forward + "C-c C-m g" #'mh-mh-compose-anon-ftp + "C-c C-m i" #'mh-compose-insertion + "C-c C-m m" #'mh-mml-to-mime + "C-c C-m n" #'mh-mml-unsecure-message + "C-c C-m s e" #'mh-mml-secure-message-signencrypt + "C-c C-m s s" #'mh-mml-secure-message-sign + "C-c C-m t" #'mh-mh-compose-external-compressed-tar + "C-c C-m u" #'mh-mh-to-mime-undo + "C-c C-m x" #'mh-mh-compose-external-type + "C-c C-o" #'mh-open-line + "C-c C-q" #'mh-fully-kill-draft + "C-c C-s" #'mh-insert-signature + "C-c C-t" #'mh-letter-toggle-header-field-display + "C-c C-w" #'mh-check-whom + "C-c C-y" #'mh-yank-cur-msg + "C-c M-d" #'mh-insert-auto-fields + "C-M-i" #'completion-at-point + "TAB" #'mh-letter-next-header-field-or-indent + "<backtab>" #'mh-letter-previous-header-field) ;; "C-c /" prefix is used in mh-letter-mode by pgp.el and mailcrypt.el. @@ -253,17 +253,13 @@ searching for `mh-mail-header-separator' in the buffer." (goto-char (point-min)) (cond ((equal mh-mail-header-separator "") (point-min)) ((search-forward (format "\n%s\n" mh-mail-header-separator) nil t) - (mh-line-beginning-position 0)) + (line-beginning-position 0)) (t (point-min))))) ;;; MH-Letter Mode -;; Shush compiler. -(mh-do-in-xemacs - (defvar font-lock-defaults)) - ;; Ensure new buffers won't get this mode if default major-mode is nil. (put 'mh-letter-mode 'mode-class 'special) @@ -295,24 +291,21 @@ order). (make-local-variable 'mh-previous-window-config) (make-local-variable 'mh-sent-from-folder) (make-local-variable 'mh-sent-from-msg) - (mh-do-in-gnu-emacs - (unless mh-letter-tool-bar-map - (mh-tool-bar-letter-buttons-init)) - (if (boundp 'tool-bar-map) - (set (make-local-variable 'tool-bar-map) mh-letter-tool-bar-map))) - (mh-do-in-xemacs - (mh-tool-bar-init :letter)) + (unless mh-letter-tool-bar-map + (mh-tool-bar-letter-buttons-init)) + (if (boundp 'tool-bar-map) + (setq-local tool-bar-map mh-letter-tool-bar-map)) ;; Set the local value of mh-mail-header-separator according to what is ;; present in the buffer... - (set (make-local-variable 'mh-mail-header-separator) - (save-excursion - (goto-char (mh-mail-header-end)) - (buffer-substring-no-properties (point) (mh-line-end-position)))) + (setq-local mh-mail-header-separator + (save-excursion + (goto-char (mh-mail-header-end)) + (buffer-substring-no-properties (point) (line-end-position)))) (make-local-variable 'mail-header-separator) (setq mail-header-separator mh-mail-header-separator) ;override sendmail.el (mh-set-help mh-letter-mode-help-messages) (setq buffer-invisibility-spec '((vanish . t) t)) - (set (make-local-variable 'line-move-ignore-invisible) t) + (setq-local line-move-ignore-invisible t) ;; Enable undo since a show-mode buffer might have been reused. (buffer-enable-undo) @@ -328,12 +321,10 @@ order). (t ;; ...or the header only (setq font-lock-defaults '((mh-show-font-lock-keywords) t)))) - (mh-do-in-xemacs (easy-menu-add mh-letter-menu)) ;; Maybe we want to use the existing Mail menu from mail-mode in ;; 9.0; in the mean time, let's remove it since the redundancy will ;; only produce confusion. (define-key mh-letter-mode-map [menu-bar mail] #'undefined) - (mh-do-in-xemacs (easy-menu-remove mail-menubar-menu)) (setq fill-column mh-letter-fill-column) (add-hook 'completion-at-point-functions #'mh-letter-completion-at-point nil 'local) @@ -488,29 +479,8 @@ This provides alias and folder completion in header fields according to (or (funcall func) #'ignore) mh-letter-complete-function))) -;; TODO Now that completion-at-point performs the task of -;; mh-letter-complete, perhaps mh-letter-complete along with -;; mh-complete-word should be rewritten as a more general function for -;; XEmacs, renamed to mh-completion-at-point, and moved to -;; mh-compat.el. -(defun-mh mh-letter-complete completion-at-point () - "Perform completion on header field or word preceding point. - -If the field contains addresses (for example, \"To:\" or \"Cc:\") -or folders (for example, \"Fcc:\") then this command will provide -alias completion. In the body of the message, this command runs -`mh-letter-complete-function' instead, which is set to -`ispell-complete-word' by default." - (interactive) - (let ((data (mh-letter-completion-at-point))) - (cond - ((functionp data) (funcall data)) - ((consp data) - (let ((start (nth 0 data)) - (end (nth 1 data)) - (table (nth 2 data))) - (mh-complete-word (buffer-substring-no-properties start end) - table start end)))))) +(define-obsolete-function-alias 'mh-letter-complete + #'completion-at-point "29.1") (defun mh-letter-complete-or-space (arg) "Perform completion or insert space. @@ -530,7 +500,7 @@ one space." ((> (point) end-of-prev) (self-insert-command arg)) ((let ((mh-letter-complete-function nil)) (mh-letter-completion-at-point)) - (mh-letter-complete)) + (completion-at-point)) (t (self-insert-command arg))))) (defun mh-letter-confirm-address () @@ -722,7 +692,7 @@ and `mh-ins-buf-prefix' is not inserted." ;; Find displayed message (with-current-buffer show-buffer (let* ((from-attr (mh-extract-from-attribution)) - (yank-region (mh-mark-active-p nil)) + (yank-region mark-active) (mh-ins-str (cond ((and yank-region (or (eq 'supercite mh-yank-behavior) @@ -834,7 +804,7 @@ body." ((< (point) (progn (beginning-of-line) (re-search-forward mh-letter-header-field-regexp - (mh-line-end-position) t) + (line-end-position) t) (point))) (beginning-of-line)) (t (end-of-line))) diff --git a/lisp/mh-e/mh-limit.el b/lisp/mh-e/mh-limit.el index 39cf7c5d271..a00252284af 100644 --- a/lisp/mh-e/mh-limit.el +++ b/lisp/mh-e/mh-limit.el @@ -124,7 +124,7 @@ Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command." (setq pick-expr (let ((case-fold-search t)) (cl-loop for s in pick-expr - collect (mh-replace-regexp-in-string "re: *" "" s)))) + collect (replace-regexp-in-string "re: *" "" s)))) (mh-narrow-to-header-field 'subject pick-expr)) ;;;###mh-autoload @@ -214,7 +214,7 @@ Return number of messages put in the sequence: (string-equal "" (match-string 3))) (progn (message "No subject line") nil) - (let ((subject (mh-match-string-no-properties 3)) + (let ((subject (match-string-no-properties 3)) (list)) (if (> (length subject) mh-limit-max-subject-size) (setq subject (substring subject 0 mh-limit-max-subject-size))) @@ -222,7 +222,7 @@ Return number of messages put in the sequence: (if all (goto-char (point-min))) (while (re-search-forward mh-scan-subject-regexp nil t) - (let ((this-subject (mh-match-string-no-properties 3))) + (let ((this-subject (match-string-no-properties 3))) (if (> (length this-subject) mh-limit-max-subject-size) (setq this-subject (substring this-subject 0 mh-limit-max-subject-size))) @@ -313,7 +313,7 @@ The MH command pick is used to do the match." (while (not (eobp)) (let ((num (ignore-errors (string-to-number - (buffer-substring (point) (mh-line-end-position)))))) + (buffer-substring (point) (line-end-position)))))) (when num (push num msg-list)) (forward-line)))) (if (null msg-list) diff --git a/lisp/mh-e/mh-mime.el b/lisp/mh-e/mh-mime.el index ad594aef906..714bf029bb7 100644 --- a/lisp/mh-e/mh-mime.el +++ b/lisp/mh-e/mh-mime.el @@ -39,6 +39,7 @@ ;;; Code: (require 'mh-e) +(require 'mh-acros) (require 'mh-gnus) ;needed because mh-gnus.el not compiled (require 'font-lock) @@ -135,13 +136,11 @@ ("application/emacs-lisp" mm-display-elisp-inline identity) ("application/x-emacs-lisp" mm-display-elisp-inline identity) ("text/html" - ,(if (fboundp 'mm-inline-text-html) 'mm-inline-text-html 'mm-inline-text) + mm-inline-text-html (lambda (handle) - (or (and (boundp 'mm-inline-text-html-renderer) - mm-inline-text-html-renderer) - (and (boundp 'mm-text-html-renderer) mm-text-html-renderer)))) + mm-text-html-renderer)) ("text/x-vcard" - mh-mm-inline-text-vcard + mm-inline-text-vcard (lambda (handle) (or (featurep 'vcard) (locate-library "vcard")))) @@ -171,7 +170,7 @@ ("audio/.*" ignore ignore) ("image/.*" ignore ignore) ;; Default to displaying as text - (".*" mm-inline-text mh-mm-readable-p)) + (".*" mm-inline-text mm-readable-p)) "Alist of media types/tests saying whether types can be displayed inline.") (defvar mh-mime-save-parts-directory nil @@ -184,13 +183,7 @@ Set from last use.") '((mh-press-button "\r" "Toggle Display"))) (defvar mh-mime-button-map (let ((map (make-sparse-keymap))) - (unless (>= (string-to-number emacs-version) 21) - ;; XEmacs doesn't care. - (set-keymap-parent map mh-show-mode-map)) - (mh-do-in-gnu-emacs - (define-key map [mouse-2] #'mh-push-button)) - (mh-do-in-xemacs - (define-key map '(button2) #'mh-push-button)) + (define-key map [mouse-2] #'mh-push-button) (dolist (c mh-mime-button-commands) (define-key map (cadr c) (car c))) map)) @@ -210,13 +203,8 @@ Set from last use.") (?D pressed-details ?s))) (defvar mh-mime-security-button-map (let ((map (make-sparse-keymap))) - (unless (>= (string-to-number emacs-version) 21) - (set-keymap-parent map mh-show-mode-map)) (define-key map "\r" #'mh-press-button) - (mh-do-in-gnu-emacs - (define-key map [mouse-2] #'mh-push-button)) - (mh-do-in-xemacs - (define-key map '(button2) #'mh-push-button)) + (define-key map [mouse-2] #'mh-push-button) map)) @@ -251,24 +239,24 @@ usually reads the file \"/etc/mailcap\"." (when (consp part-index) (setq part-index (car part-index))) (mh-folder-mime-action part-index - #'(lambda () - (let* ((part (get-text-property (point) 'mh-data)) - (type (mm-handle-media-type part)) - (methods (mapcar (lambda (x) (list (cdr (assoc 'viewer x)))) - (mailcap-mime-info type 'all))) - (def (caar methods)) - (prompt (format-prompt "Viewer" def)) - (method (completing-read prompt methods nil nil nil nil def)) - (folder mh-show-folder-buffer) - (buffer-read-only nil)) - (when (string-match "^[^% \t]+$" method) - (setq method (concat method " %s"))) - (mh-flet - ((mm-handle-set-external-undisplayer - (handle function) - (mh-handle-set-external-undisplayer folder handle function))) - (unwind-protect (mm-display-external part method) - (set-buffer-modified-p nil))))) + (lambda () + (let* ((part (get-text-property (point) 'mh-data)) + (type (mm-handle-media-type part)) + (methods (mapcar (lambda (x) (list (cdr (assoc 'viewer x)))) + (mailcap-mime-info type 'all))) + (def (caar methods)) + (prompt (format-prompt "Viewer" def)) + (method (completing-read prompt methods nil nil nil nil def)) + (folder mh-show-folder-buffer) + (buffer-read-only nil)) + (when (string-match "^[^% \t]+$" method) + (setq method (concat method " %s"))) + (mh-flet + ((mm-handle-set-external-undisplayer + (handle function) + (mh-handle-set-external-undisplayer folder handle function))) + (unwind-protect (mm-display-external part method) + (set-buffer-modified-p nil))))) nil)) ;;;###mh-autoload @@ -299,14 +287,14 @@ the attachment labeled with that number." start end) (cond ((and data (not inserted-flag) (not displayed-flag)) (let ((contents (mm-get-part data))) - (add-text-properties (mh-line-beginning-position) - (mh-line-end-position) '(mh-mime-inserted t)) + (add-text-properties (line-beginning-position) + (line-end-position) '(mh-mime-inserted t)) (setq start (point-marker)) (forward-line 1) (mm-insert-inline data contents) (setq end (point-marker)) (add-text-properties - start (progn (goto-char start) (mh-line-end-position)) + start (progn (goto-char start) (line-end-position)) `(mh-region (,start . ,end))))) ((and data (or inserted-flag displayed-flag)) (mh-press-button) @@ -458,10 +446,10 @@ decoding the same message multiple times." (setf (gethash handle (mh-mime-handles-cache (mh-buffer-data))) (let ((handles (mm-dissect-buffer nil))) (if handles - (mh-mm-uu-dissect-text-parts handles) + (mm-uu-dissect-text-parts handles) (setq handles (mm-uu-dissect))) (setf (mh-mime-handles (mh-buffer-data)) - (mh-mm-merge-handles + (mm-merge-handles handles (mh-mime-handles (mh-buffer-data)))) handles)))) @@ -532,10 +520,10 @@ parsed and then displayed." (if pre-dissected-handles (setq handles pre-dissected-handles) (if (setq handles (mm-dissect-buffer nil)) - (mh-mm-uu-dissect-text-parts handles) + (mm-uu-dissect-text-parts handles) (setq handles (mm-uu-dissect))) (setf (mh-mime-handles (mh-buffer-data)) - (mh-mm-merge-handles handles + (mm-merge-handles handles (mh-mime-handles (mh-buffer-data)))) (unless handles (mh-decode-message-body))) @@ -641,7 +629,7 @@ buttons for alternative parts that are usually suppressed." (let ((mh-mime-security-button-line-format mh-mime-security-button-end-line-format)) (mh-insert-mime-security-button handle)) - (mh-mm-set-handle-multipart-parameter + (mm-set-handle-multipart-parameter handle 'mh-region (cons (point-min-marker) (point-max-marker))))) (defun mh-mime-display-single (handle) @@ -713,8 +701,7 @@ buttons for alternative parts that are usually suppressed." ;; Delete the button and displayed part (if any) (let ((region (get-text-property point 'mh-region))) (when region - (mh-funcall-if-exists - remove-images (car region) (cdr region))) + (remove-images (car region) (cdr region))) (mm-display-part handle) (when region (delete-region (car region) (cdr region)))) @@ -752,8 +739,8 @@ buttons for alternative parts that are usually suppressed." (mh-insert-mime-button handle id (mm-handle-displayed-p handle)) (goto-char point) (when region - (add-text-properties (mh-line-beginning-position) - (mh-line-end-position) + (add-text-properties (line-beginning-position) + (line-end-position) `(mh-region ,region))))))) (defun mh-mime-part-index (handle) @@ -777,20 +764,12 @@ This is only useful if a Content-Disposition header is not present." ; this only tells us if the image is ; something that emacs can display (let ((image (mm-get-image handle))) - (or (mh-do-in-xemacs - (and (mh-funcall-if-exists glyphp image) - (< (glyph-width image) - (or mh-max-inline-image-width (window-pixel-width))) - (< (glyph-height image) - (or mh-max-inline-image-height - (window-pixel-height))))) - (mh-do-in-gnu-emacs - (let ((size (and (fboundp 'image-size) (image-size image)))) - (and size - (< (cdr size) (or mh-max-inline-image-height - (1- (window-height)))) - (< (car size) (or mh-max-inline-image-width - (window-width))))))))))) + (let ((size (and (fboundp 'image-size) (image-size image)))) + (and size + (< (cdr size) (or mh-max-inline-image-height + (1- (window-height)))) + (< (car size) (or mh-max-inline-image-width + (window-width))))))))) (defun mh-inline-vcard-p (handle) "Decide if HANDLE is a vcard that must be displayed inline." @@ -813,27 +792,19 @@ being used to highlight the signature in a MIME part." ((not (and (equal (mm-handle-media-supertype handle) "text") (equal (mm-handle-media-subtype handle) "html"))) "^-- $") - ((eq (mh-mm-text-html-renderer) 'lynx) "^ --$") + ((eq mm-text-html-renderer 'lynx) "^ --$") (t "^--$")))) (save-excursion (goto-char (point-max)) (when (re-search-backward regexp nil t) - (mh-do-in-gnu-emacs - (let ((ov (make-overlay (point) (point-max)))) - (overlay-put ov 'face 'mh-show-signature) - (overlay-put ov 'evaporate t))) - (mh-do-in-xemacs - (set-extent-property (make-extent (point) (point-max)) - 'face 'mh-show-signature)))))) + (let ((ov (make-overlay (point) (point-max)))) + (overlay-put ov 'face 'mh-show-signature) + (overlay-put ov 'evaporate t)))))) ;;; Button Display -;; Shush compiler. -(mh-do-in-xemacs - (defvar ov)) - (defun mh-insert-mime-button (handle index displayed) "Insert MIME button for HANDLE. INDEX is the part number that will be DISPLAYED. It is also used @@ -865,10 +836,10 @@ by commands like \"K v\" which operate on individual MIME parts." (setq begin (point)) (gnus-eval-format mh-mime-button-line-format mh-mime-button-line-format-alist - `(,@(mh-gnus-local-map-property mh-mime-button-map) - mh-callback mh-mm-display-part - mh-part ,index - mh-data ,handle))) + `(keymap ,mh-mime-button-map + mh-callback mh-mm-display-part + mh-part ,index + mh-data ,handle))) (setq end (point)) (widget-convert-button 'link begin end @@ -877,16 +848,12 @@ by commands like \"K v\" which operate on individual MIME parts." :button-keymap mh-mime-button-map :help-echo "Mouse-2 click or press RET (in show buffer) to toggle display") - (dolist (ov (mh-funcall-if-exists overlays-in begin end)) - (mh-funcall-if-exists overlay-put ov 'evaporate t)))) - -;; Shush compiler. -(defvar mm-verify-function-alist) ; < Emacs 22 -(defvar mm-decrypt-function-alist) ; < Emacs 22 + (dolist (ov (overlays-in begin end)) + (overlay-put ov 'evaporate t)))) (defun mh-insert-mime-security-button (handle) "Display buttons for PGP message, HANDLE." - (let* ((protocol (mh-mm-handle-multipart-ctl-parameter handle 'protocol)) + (let* ((protocol (mm-handle-multipart-ctl-parameter handle 'protocol)) (crypto-type (or (nth 2 (assoc protocol mm-verify-function-alist)) (nth 2 (assoc protocol mm-decrypt-function-alist)) "Unknown")) @@ -897,10 +864,10 @@ by commands like \"K v\" which operate on individual MIME parts." (if (equal (car handle) "multipart/signed") " Signed" " Encrypted") " Part")) - (info (or (mh-mm-handle-multipart-ctl-parameter + (info (or (mm-handle-multipart-ctl-parameter handle 'gnus-info) "Undecided")) - (details (mh-mm-handle-multipart-ctl-parameter + (details (mm-handle-multipart-ctl-parameter handle 'gnus-details)) pressed-details) (setq details (if details (concat "\n" details) "")) @@ -911,11 +878,11 @@ by commands like \"K v\" which operate on individual MIME parts." (gnus-eval-format mh-mime-security-button-line-format mh-mime-security-button-line-format-alist - `(,@(mh-gnus-local-map-property mh-mime-security-button-map) - mh-button-pressed ,mh-mime-security-button-pressed - mh-callback mh-mime-security-press-button - mh-line-format ,mh-mime-security-button-line-format - mh-data ,handle)) + `(keymap ,mh-mime-security-button-map + mh-button-pressed ,mh-mime-security-button-pressed + mh-callback mh-mime-security-press-button + mh-line-format ,mh-mime-security-button-line-format + mh-data ,handle)) (setq end (point)) (widget-convert-button 'link begin end :mime-handle handle @@ -923,8 +890,8 @@ by commands like \"K v\" which operate on individual MIME parts." :button-keymap mh-mime-security-button-map :button-face face :help-echo "Mouse-2 click or press RET (in show buffer) to see security details.") - (dolist (ov (mh-funcall-if-exists overlays-in begin end)) - (mh-funcall-if-exists overlay-put ov 'evaporate t)) + (dolist (ov (overlays-in begin end)) + (overlay-put ov 'evaporate t)) (when (equal info "Failed") (let* ((type (if (equal (car handle) "multipart/signed") "verification" "decryption")) @@ -1081,7 +1048,7 @@ This is only called in recent versions of Gnus. The MIME handles are stored in data structures corresponding to MH-E folder buffer FOLDER instead of in Gnus (as in the original). The MIME part, HANDLE is associated with the undisplayer FUNCTION." - (if (mh-mm-keep-viewer-alive-p handle) + (if (mm-keep-viewer-alive-p handle) (let ((new-handle (copy-sequence handle))) (mm-handle-set-undisplayer new-handle function) (mm-handle-set-undisplayer handle nil) @@ -1091,19 +1058,19 @@ HANDLE is associated with the undisplayer FUNCTION." (defun mh-mime-security-press-button (handle) "Callback from security button for part HANDLE." - (if (mh-mm-handle-multipart-ctl-parameter handle 'gnus-info) + (if (mm-handle-multipart-ctl-parameter handle 'gnus-info) (mh-mime-security-show-details handle) - (let ((region (mh-mm-handle-multipart-ctl-parameter handle 'mh-region)) + (let ((region (mm-handle-multipart-ctl-parameter handle 'mh-region)) point) (setq point (point)) (goto-char (car region)) (delete-region (car region) (cdr region)) - (with-current-buffer (mh-mm-handle-multipart-ctl-parameter handle 'buffer) + (with-current-buffer (mm-handle-multipart-ctl-parameter handle 'buffer) (let* ((mm-verify-option 'known) (mm-decrypt-option 'known) - (new (mh-mm-possibly-verify-or-decrypt (cdr handle) handle))) + (new (mm-possibly-verify-or-decrypt (cdr handle) handle))) (unless (eq new (cdr handle)) - (mh-mm-destroy-parts (cdr handle)) + (mm-destroy-parts (cdr handle)) (setcdr handle new)))) (mh-mime-display-security handle) (goto-char point)))) @@ -1113,7 +1080,7 @@ HANDLE is associated with the undisplayer FUNCTION." ;; to be no way of getting rid of the inserted text. (defun mh-mime-security-show-details (handle) "Toggle display of detailed security info for HANDLE." - (let ((details (mh-mm-handle-multipart-ctl-parameter handle 'gnus-details))) + (let ((details (mm-handle-multipart-ctl-parameter handle 'gnus-details))) (when details (let ((mh-mime-security-button-pressed (not (get-text-property (point) 'mh-button-pressed))) @@ -1158,7 +1125,7 @@ this ;-)" (defun mh-display-smileys () "Display smileys." (when (and mh-graphical-smileys-flag (mh-small-show-buffer-p)) - (mh-funcall-if-exists smiley-region (point-min) (point-max)))) + (smiley-region (point-min) (point-max)))) ;;;###mh-autoload (defun mh-display-emphasis () @@ -1175,6 +1142,7 @@ this ;-)" This is used to decide if smileys and graphical emphasis should be displayed." (let ((max nil)) + ;; FIXME: font-lock-maximum-size is obsolete. (when (and (boundp 'font-lock-maximum-size) font-lock-maximum-size) (cond ((numberp font-lock-maximum-size) (setq max font-lock-maximum-size)) @@ -1303,7 +1271,7 @@ automatically." (type (mh-minibuffer-read-type file)) (description (mml-minibuffer-read-description)) (dispos (or disposition - (mh-mml-minibuffer-read-disposition type)))) + (mml-minibuffer-read-disposition type)))) (mml-insert-empty-tag 'part 'type type 'filename file 'disposition dispos 'description description))) @@ -1507,9 +1475,9 @@ This function will quote all such characters." (goto-char (point-min)) (while (re-search-forward "^#" nil t) (beginning-of-line) - (unless (mh-mh-directive-present-p (point) (mh-line-end-position)) + (unless (mh-mh-directive-present-p (point) (line-end-position)) (insert "#")) - (goto-char (mh-line-end-position))))) + (goto-char (line-end-position))))) ;;;###mh-autoload (defun mh-mh-to-mime-undo (noconfirm) @@ -1695,7 +1663,7 @@ buffer, while END defaults to the end of the buffer." (goto-char begin) (while (re-search-forward "^#" end t) (let ((s (buffer-substring-no-properties - (point) (mh-line-end-position)))) + (point) (line-end-position)))) (cond ((equal s "")) ((string-match "^forw[ \t\n]+" s) (cl-return-from search-for-mh-directive t)) @@ -1799,8 +1767,7 @@ initialized. Always use the command `mh-have-file-command'.") 'file -i' is used to get MIME type of composition insertion." (when (eq mh-have-file-command 'undefined) (setq mh-have-file-command - (and (fboundp 'executable-find) - (executable-find "file") ; file command exists + (and (executable-find "file") ; file command exists ; and accepts -i and -b args. (zerop (call-process "file" nil nil nil "-i" "-b" (expand-file-name "inc" mh-progs)))))) @@ -1814,10 +1781,9 @@ initialized. Always use the command `mh-have-file-command'.") (defun mh-mime-cleanup () "Free the decoded MIME parts." (let ((mime-data (gethash (current-buffer) mh-globals-hash))) - ;; This is for Emacs, what about XEmacs? - (mh-funcall-if-exists remove-images (point-min) (point-max)) + (remove-images (point-min) (point-max)) (when mime-data - (mh-mm-destroy-parts (mh-mime-handles mime-data)) + (mm-destroy-parts (mh-mime-handles mime-data)) (remhash (current-buffer) mh-globals-hash)))) ;;;###mh-autoload @@ -1825,7 +1791,7 @@ initialized. Always use the command `mh-have-file-command'.") "Free MIME data for externally displayed MIME parts." (let ((mime-data (mh-buffer-data))) (when mime-data - (mh-mm-destroy-parts (mh-mime-handles mime-data))) + (mm-destroy-parts (mh-mime-handles mime-data))) (remhash (current-buffer) mh-globals-hash))) (provide 'mh-mime) diff --git a/lisp/mh-e/mh-scan.el b/lisp/mh-e/mh-scan.el index 5aa599942e3..9ac251e8b71 100644 --- a/lisp/mh-e/mh-scan.el +++ b/lisp/mh-e/mh-scan.el @@ -315,7 +315,7 @@ produced by \"inc\".") ;;; Widths, Offsets and Columns -(defvar mh-cmd-note 4 +(defvar-local mh-cmd-note 4 "Column for notations. This variable should be set with the function `mh-set-cmd-note'. @@ -323,12 +323,15 @@ This variable may be updated dynamically if `mh-adaptive-cmd-note-flag' is on. Note that columns in Emacs start with 0.") -(make-variable-buffer-local 'mh-cmd-note) (defvar mh-scan-cmd-note-width 1 "Number of columns consumed by the cmd-note field in `mh-scan-format'. -This column will have one of the values: \" \", \"^\", \"D\", \"B\", \"A\", \"+\", where +This column will have one of the values: + + \" \", \"^\", \"D\", \"B\", \"A\", \"+\" + +where \" \" is the default value, \"^\" is the `mh-note-refiled' character, @@ -510,7 +513,7 @@ with `mh-scan-msg-format-string'." Note that columns in Emacs start with 0. If `mh-scan-format-file' is set to \"Use MH-E scan Format\" this -means that either `mh-scan-format-mh' or `mh-scan-format-nmh' are +means that either `mh-scan-format-mh' or `mh-scan-format-nmh' is in use. This function therefore assumes that the first column is empty (to provide room for the cursor), the following WIDTH columns contain the message number, and the column for notations diff --git a/lisp/mh-e/mh-search.el b/lisp/mh-e/mh-search.el index e03c9dc83f7..8012e624f16 100644 --- a/lisp/mh-e/mh-search.el +++ b/lisp/mh-e/mh-search.el @@ -42,6 +42,7 @@ ;;; Code: (require 'mh-e) +(require 'mh-letter) (require 'gnus-util) (require 'imenu) @@ -318,10 +319,6 @@ folder containing the index search results." (cl-loop for msg-hash being the hash-values of mh-index-data count (> (hash-table-count msg-hash) 0))))))) -;; Shush compiler. -(mh-do-in-xemacs - (defvar pick-folder)) ;FIXME: Why? - (defun mh-search-folder (folder window-config) "Search FOLDER for messages matching a pattern. @@ -336,8 +333,8 @@ configuration and is used when the search folder is dismissed." (not (y-or-n-p "Reuse pattern? "))) (mh-make-pick-template) (message "")) - (mh-make-local-vars 'mh-current-folder folder - 'mh-previous-window-config window-config) + (setq-local mh-current-folder folder + mh-previous-window-config window-config) (message "%s" (substitute-command-keys (concat "Type \\[mh-index-do-search] to search messages, " "\\[mh-pick-do-search] to use pick, " @@ -356,13 +353,13 @@ configuration and is used when the search folder is dismissed." (goto-char (point-min)) (dotimes (_ 5) (add-text-properties (point) (1+ (point)) '(front-sticky t)) - (add-text-properties (- (mh-line-end-position) 2) - (1- (mh-line-end-position)) + (add-text-properties (- (line-end-position) 2) + (1- (line-end-position)) '(rear-nonsticky t)) - (add-text-properties (point) (1- (mh-line-end-position)) '(read-only t)) + (add-text-properties (point) (1- (line-end-position)) '(read-only t)) (forward-line)) (add-text-properties (point) (1+ (point)) '(front-sticky t)) - (add-text-properties (point) (1- (mh-line-end-position)) '(read-only t)) + (add-text-properties (point) (1- (line-end-position)) '(read-only t)) (goto-char (point-max))) ;; Sequence Searches @@ -522,10 +519,10 @@ group of results." (cond ((and (bolp) (eolp)) (ignore-errors (forward-line -1)) (setq msg (mh-get-msg-num t))) - ((equal (char-after (mh-line-beginning-position)) ?+) + ((equal (char-after (line-beginning-position)) ?+) (setq folder (buffer-substring-no-properties - (mh-line-beginning-position) - (mh-line-end-position)))) + (line-beginning-position) + (line-end-position)))) (t (setq msg (mh-get-msg-num t))))) (when (not folder) (setq folder (car (gethash (gethash msg mh-index-msg-checksum-map) @@ -552,20 +549,20 @@ group of results." ;;; MH-Search Keys ;; If this changes, modify mh-search-mode-help-messages accordingly, below. -(gnus-define-keys mh-search-mode-map - "\C-c?" mh-help - "\C-c\C-c" mh-index-do-search - "\C-c\C-p" mh-pick-do-search - "\C-c\C-f\C-b" mh-to-field - "\C-c\C-f\C-c" mh-to-field - "\C-c\C-f\C-m" mh-to-field - "\C-c\C-f\C-s" mh-to-field - "\C-c\C-f\C-t" mh-to-field - "\C-c\C-fb" mh-to-field - "\C-c\C-fc" mh-to-field - "\C-c\C-fm" mh-to-field - "\C-c\C-fs" mh-to-field - "\C-c\C-ft" mh-to-field) +(define-keymap :keymap mh-search-mode-map + "C-c ?" #'mh-help + "C-c C-c" #'mh-index-do-search + "C-c C-p" #'mh-pick-do-search + "C-c C-f C-b" #'mh-to-field + "C-c C-f C-c" #'mh-to-field + "C-c C-f C-m" #'mh-to-field + "C-c C-f C-s" #'mh-to-field + "C-c C-f C-t" #'mh-to-field + "C-c C-f b" #'mh-to-field + "C-c C-f c" #'mh-to-field + "C-c C-f m" #'mh-to-field + "C-c C-f s" #'mh-to-field + "C-c C-f t" #'mh-to-field) @@ -616,7 +613,6 @@ The hook `mh-search-mode-hook' is called upon entry to this mode. \\{mh-search-mode-map}" - (mh-do-in-xemacs (easy-menu-add mh-pick-menu)) (mh-set-help mh-search-mode-help-messages)) @@ -653,13 +649,13 @@ The cdr of the element is the pattern to search." start begin) (goto-char (point-min)) (while (not (eobp)) - (if (search-forward "--------" (mh-line-end-position) t) + (if (search-forward "--------" (line-end-position) t) (setq in-body-flag t) (beginning-of-line) (setq begin (point)) (setq start (if in-body-flag (point) - (search-forward ":" (mh-line-end-position) t) + (search-forward ":" (line-end-position) t) (point))) (push (cons (and (not in-body-flag) (intern (downcase @@ -667,7 +663,7 @@ The cdr of the element is the pattern to search." begin (1- start))))) (mh-index-parse-search-regexp (buffer-substring-no-properties - start (mh-line-end-position)))) + start (line-end-position)))) pattern-list)) (forward-line)) pattern-list))) @@ -977,8 +973,8 @@ is used to search." (cl-return nil)) (when (equal (char-after (point)) ?#) (cl-return 'error)) - (let* ((start (search-forward " " (mh-line-end-position) t)) - (end (search-forward " " (mh-line-end-position) t))) + (let* ((start (search-forward " " (line-end-position) t)) + (end (search-forward " " (line-end-position) t))) (unless (and start end) (cl-return 'error)) (setq end (1- end)) @@ -1056,7 +1052,7 @@ SEARCH-REGEXP-LIST is used to search." (cl-return 'error)) (let ((start (point)) end msg-start) - (setq end (mh-line-end-position)) + (setq end (line-end-position)) (unless (search-forward mh-mairix-folder end t) (cl-return 'error)) (goto-char (match-beginning 0)) @@ -1197,7 +1193,7 @@ is used to search." (cl-block nil (when (eobp) (cl-return nil)) (let ((file-name (buffer-substring-no-properties - (point) (mh-line-end-position)))) + (point) (line-end-position)))) (unless (equal (string-match mh-namazu-folder file-name) 0) (cl-return 'error)) (unless (file-exists-p file-name) @@ -1245,17 +1241,17 @@ is used to search." (prog1 (cl-block nil (when (eobp) (cl-return nil)) - (when (search-forward-regexp "^\\+" (mh-line-end-position) t) + (when (search-forward-regexp "^\\+" (line-end-position) t) (setq mh-index-pick-folder - (buffer-substring-no-properties (mh-line-beginning-position) - (mh-line-end-position))) + (buffer-substring-no-properties (line-beginning-position) + (line-end-position))) (cl-return 'error)) - (unless (search-forward-regexp "^[1-9][0-9]*$" (mh-line-end-position) t) + (unless (search-forward-regexp "^[1-9][0-9]*$" (line-end-position) t) (cl-return 'error)) (list mh-index-pick-folder (string-to-number - (buffer-substring-no-properties (mh-line-beginning-position) - (mh-line-end-position))) + (buffer-substring-no-properties (line-beginning-position) + (line-end-position))) nil)) (forward-line))) @@ -1332,8 +1328,8 @@ record is invalid return `error'." (cl-block nil (when (eobp) (cl-return nil)) - (let ((eol-pos (mh-line-end-position)) - (bol-pos (mh-line-beginning-position)) + (let ((eol-pos (line-end-position)) + (bol-pos (line-beginning-position)) folder-start msg-end) (goto-char bol-pos) (unless (search-forward mh-user-path eol-pos t) @@ -1415,10 +1411,7 @@ being the list of messages originally from that folder." (when cur-msg (mh-goto-msg cur-msg t t)) (set-buffer-modified-p old-buffer-modified-flag))) -(eval-and-compile (mh-require 'which-func nil t)) - -;; Shush compiler. -(defvar which-func-mode) ; < Emacs 22, XEmacs +(eval-and-compile (require 'which-func nil t)) ;;;###mh-autoload (defun mh-index-create-imenu-index () @@ -1432,7 +1425,7 @@ being the list of messages originally from that folder." (save-excursion (beginning-of-line) (push (cons (buffer-substring-no-properties - (point) (mh-line-end-position)) + (point) (line-end-position)) (point-marker)) alist))) (setq imenu--index-alist (nreverse alist))))) @@ -1717,7 +1710,7 @@ folder, is removed from `mh-index-data'." "-format" "%{x-mhe-checksum}\n" folder msg) (goto-char (point-min)) (string-equal (buffer-substring-no-properties - (point) (mh-line-end-position)) + (point) (line-end-position)) checksum))) @@ -1826,8 +1819,8 @@ PROC is used to convert the value to actual data." (defun mh-md5sum-parser () "Parse md5sum output." - (let ((begin (mh-line-beginning-position)) - (end (mh-line-end-position)) + (let ((begin (line-beginning-position)) + (end (line-end-position)) first-space last-slash) (setq first-space (search-forward " " end t)) (goto-char end) @@ -1840,8 +1833,8 @@ PROC is used to convert the value to actual data." (defun mh-openssl-parser () "Parse openssl output." - (let ((begin (mh-line-beginning-position)) - (end (mh-line-end-position)) + (let ((begin (line-beginning-position)) + (end (line-end-position)) last-space last-slash) (goto-char end) (setq last-space (search-backward " " begin t)) @@ -1874,7 +1867,7 @@ origin-index) map is updated too." (let (msg checksum) (while (not (eobp)) (setq msg (buffer-substring-no-properties - (point) (mh-line-end-position))) + (point) (line-end-position))) (forward-line) (save-excursion (cond ((not (string-match "^[0-9]*$" msg))) @@ -1885,7 +1878,7 @@ origin-index) map is updated too." (t ;; update maps (setq checksum (buffer-substring-no-properties - (point) (mh-line-end-position))) + (point) (line-end-position))) (let ((msg (string-to-number msg))) (set-buffer folder) (mh-index-update-single-msg msg checksum origin-map))))) diff --git a/lisp/mh-e/mh-seq.el b/lisp/mh-e/mh-seq.el index a50319a455d..077e289c01d 100644 --- a/lisp/mh-e/mh-seq.el +++ b/lisp/mh-e/mh-seq.el @@ -38,9 +38,8 @@ (defvar mh-last-seq-used nil "Name of seq to which a msg was last added.") -(defvar mh-non-seq-mode-line-annotation nil +(defvar-local mh-non-seq-mode-line-annotation nil "Saved value of `mh-mode-line-annotation' when narrowed to a seq.") -(make-variable-buffer-local 'mh-non-seq-mode-line-annotation) (defvar mh-internal-seqs '(answered cur deleted forwarded printed)) @@ -167,7 +166,7 @@ The list appears in a buffer named \"*MH-E Sequences*\"." (insert "\n")) (setq seq-list (cdr seq-list))) (goto-char (point-min)) - (mh-view-mode-enter) + (view-mode-enter) (setq view-exit-action 'kill-buffer) (message "Listing sequences...done"))))) @@ -193,11 +192,6 @@ MESSAGE appears." (mh-list-to-string (mh-seq-containing-msg message t)) " ")))) -;; Shush compiler. -(mh-do-in-xemacs - (defvar tool-bar-mode)) -(defvar tool-bar-map) - ;;;###mh-autoload (defun mh-narrow-to-seq (sequence) "Restrict display to messages in SEQUENCE. @@ -229,12 +223,12 @@ When you want to widen the view to all your messages again, use (mh-make-folder-mode-line) (mh-recenter nil) (when (and (boundp 'tool-bar-mode) tool-bar-mode) - (set (make-local-variable 'tool-bar-map) - mh-folder-seq-tool-bar-map) + (setq-local tool-bar-map + mh-folder-seq-tool-bar-map) (when (buffer-live-p (get-buffer mh-show-buffer)) (with-current-buffer mh-show-buffer - (set (make-local-variable 'tool-bar-map) - mh-show-seq-tool-bar-map)))) + (setq-local tool-bar-map + mh-show-seq-tool-bar-map)))) (push 'widen mh-view-ops))) (t (error "No messages in sequence %s" (symbol-name sequence)))))) @@ -362,10 +356,10 @@ remove all limits and sequence restrictions." (mh-notate-cur) (mh-recenter nil))) (when (and (null mh-folder-view-stack) (boundp 'tool-bar-mode) tool-bar-mode) - (set (make-local-variable 'tool-bar-map) mh-folder-tool-bar-map) + (setq-local tool-bar-map mh-folder-tool-bar-map) (when (buffer-live-p (get-buffer mh-show-buffer)) (with-current-buffer mh-show-buffer - (set (make-local-variable 'tool-bar-map) mh-show-tool-bar-map))))) + (setq-local tool-bar-map mh-show-tool-bar-map))))) @@ -582,7 +576,7 @@ Otherwise, the message number at point is returned. This function is usually used with `mh-iterate-on-range' in order to provide a uniform interface to MH-E functions." - (cond ((mh-mark-active-p t) (cons (region-beginning) (region-end))) + (cond ((and transient-mark-mode mark-active) (cons (region-beginning) (region-end))) (current-prefix-arg (mh-read-range range-prompt nil nil t t)) (default default) (t (mh-get-msg-num t)))) @@ -736,7 +730,7 @@ completion is over." (cl-multiple-value-bind (folder unseen total) (cl-values-list (mh-parse-flist-output-line - (buffer-substring (point) (mh-line-end-position)))) + (buffer-substring (point) (line-end-position)))) (list total unseen folder)))) (defun mh-folder-size-folder (folder) @@ -764,7 +758,7 @@ folders whose names end with a `+' character." (when (search-backward " out of " (point-min) t) (setq total (string-to-number (buffer-substring-no-properties - (match-end 0) (mh-line-end-position)))) + (match-end 0) (line-end-position)))) (when (search-backward " in sequence " (point-min) t) (setq p (point)) (when (search-backward " has " (point-min) t) @@ -786,10 +780,10 @@ If SAVE-REFILES is non-nil, then keep the sequences that note messages to be refiled." (let ((seqs ())) (cond (save-refiles - (mh-mapc (lambda (seq) ; Save the refiling sequences - (if (mh-folder-name-p (mh-seq-name seq)) - (setq seqs (cons seq seqs)))) - mh-seq-list))) + (mapc (lambda (seq) ; Save the refiling sequences + (if (mh-folder-name-p (mh-seq-name seq)) + (setq seqs (cons seq seqs)))) + mh-seq-list))) (save-excursion (if (eq 0 (mh-exec-cmd-quiet nil "mark" folder "-list")) (progn @@ -942,7 +936,7 @@ font-lock is turned on." ;; the case of user sequences. (mh-notate nil nil mh-cmd-note) (when font-lock-mode - (font-lock-fontify-region (point) (mh-line-end-position)))) + (font-lock-fontify-region (point) (line-end-position)))) (forward-char (+ mh-cmd-note mh-scan-field-destination-offset)) (let ((stack (gethash msg mh-sequence-notation-history))) (setf (gethash msg mh-sequence-notation-history) diff --git a/lisp/mh-e/mh-show.el b/lisp/mh-e/mh-show.el index 803f07e02b2..16489bf0172 100644 --- a/lisp/mh-e/mh-show.el +++ b/lisp/mh-e/mh-show.el @@ -144,7 +144,7 @@ displayed." (if (not clean-message-header) (mh-start-of-uncleaned-message))) (mh-display-msg msg folder))) - (unless (mh-window-full-height-p) ; not vertically split + (unless (window-full-height-p) ; not vertically split (shrink-window (- (window-height) (or mh-summary-height (mh-summary-height))))) (mh-recenter nil) @@ -328,17 +328,15 @@ ignored if VISIBLE-HEADERS is non-nil." (defun mh-summary-height () "Return ideal value for the variable `mh-summary-height'. The current frame height is taken into consideration." - (or (and (fboundp 'frame-height) - (> (frame-height) 24) + (or (and (> (frame-height) 24) (min 10 (/ (frame-height) 6))) 4)) -;; Infrastructure to generate show-buffer functions from folder functions -;; XEmacs does not have deactivate-mark? What is the equivalent of -;; transient-mark-mode for XEmacs? Should we be restoring the mark in the -;; folder buffer after the operation has been carried out. +;; Infrastructure to generate show-buffer functions from folder functions. +;; Should we be restoring the mark in the folder buffer after the +;; operation has been carried out? (defmacro mh-defun-show-buffer (function original-function &optional dont-return) "Define FUNCTION to run ORIGINAL-FUNCTION in folder buffer. @@ -363,13 +361,14 @@ still visible.\n") folder-buffer) (delete-other-windows)) (mh-goto-cur-msg t) - (mh-funcall-if-exists deactivate-mark) + (deactivate-mark) (unwind-protect (prog1 (call-interactively (function ,original-function)) (setq normal-exit t)) - (mh-funcall-if-exists deactivate-mark) + (deactivate-mark) (when (eq major-mode 'mh-folder-mode) - (mh-funcall-if-exists hl-line-highlight)) + (when (fboundp 'hl-line-highlight) + (hl-line-highlight))) (cond ((not normal-exit) (set-window-configuration config)) ,(if dont-return @@ -464,8 +463,7 @@ still visible.\n") (mh-defun-show-buffer mh-show-toggle-tick mh-toggle-tick) (mh-defun-show-buffer mh-show-narrow-to-tick mh-narrow-to-tick) (mh-defun-show-buffer mh-show-junk-allowlist mh-junk-allowlist) -(mh-defun-show-buffer mh-show-junk-whitelist mh-junk-allowlist) -(make-obsolete 'mh-show-junk-whitelist 'mh-show-junk-allowlist "28.1") +(mh-defun-show-buffer mh-show-junk-whitelist mh-junk-whitelist) (mh-defun-show-buffer mh-show-junk-blocklist mh-junk-blocklist) (mh-defun-show-buffer mh-show-index-new-messages mh-index-new-messages) (mh-defun-show-buffer mh-show-index-ticked-messages mh-index-ticked-messages) @@ -562,132 +560,132 @@ still visible.\n") ;;; MH-Show Keys -(gnus-define-keys mh-show-mode-map - " " mh-show-page-msg - "!" mh-show-refile-or-write-again - "'" mh-show-toggle-tick - "," mh-show-header-display - "." mh-show-show - ":" mh-show-show-preferred-alternative - ">" mh-show-write-message-to-file - "?" mh-help - "E" mh-show-extract-rejected-mail - "M" mh-show-modify - "\177" mh-show-previous-page - "\C-d" mh-show-delete-msg-no-motion - "\t" mh-show-next-button - [backtab] mh-show-prev-button - "\M-\t" mh-show-prev-button - "\ed" mh-show-redistribute - "^" mh-show-refile-msg - "c" mh-show-copy-msg - "d" mh-show-delete-msg - "e" mh-show-edit-again - "f" mh-show-forward - "g" mh-show-goto-msg - "i" mh-show-inc-folder - "k" mh-show-delete-subject-or-thread - "m" mh-show-send - "n" mh-show-next-undeleted-msg - "\M-n" mh-show-next-unread-msg - "o" mh-show-refile-msg - "p" mh-show-previous-undeleted-msg - "\M-p" mh-show-previous-unread-msg - "q" mh-show-quit - "r" mh-show-reply - "s" mh-show-send - "t" mh-show-toggle-showing - "u" mh-show-undo - "x" mh-show-execute-commands - "v" mh-show-index-visit-folder - "|" mh-show-pipe-msg) - -(gnus-define-keys (mh-show-folder-map "F" mh-show-mode-map) - "?" mh-prefix-help - "'" mh-index-ticked-messages - "S" mh-show-sort-folder - "c" mh-show-catchup - "f" mh-show-visit-folder - "k" mh-show-kill-folder - "l" mh-show-list-folders - "n" mh-index-new-messages - "o" mh-show-visit-folder - "p" mh-show-pack-folder - "q" mh-show-index-sequenced-messages - "r" mh-show-rescan-folder - "s" mh-search - "t" mh-show-toggle-threads - "u" mh-show-undo-folder - "v" mh-show-visit-folder) - -(gnus-define-keys (mh-show-sequence-map "S" mh-show-mode-map) - "'" mh-show-narrow-to-tick - "?" mh-prefix-help - "d" mh-show-delete-msg-from-seq - "k" mh-show-delete-seq - "l" mh-show-list-sequences - "n" mh-show-narrow-to-seq - "p" mh-show-put-msg-in-seq - "s" mh-show-msg-is-in-seq - "w" mh-show-widen) - -(define-key mh-show-mode-map "I" mh-inc-spool-map) - -(gnus-define-keys (mh-show-junk-map "J" mh-show-mode-map) - "?" mh-prefix-help - "a" mh-show-junk-allowlist - "b" mh-show-junk-blocklist - "w" mh-show-junk-whitelist) - -(gnus-define-keys (mh-show-ps-print-map "P" mh-show-mode-map) - "?" mh-prefix-help - "C" mh-show-ps-print-toggle-color - "F" mh-show-ps-print-toggle-faces - "f" mh-show-ps-print-msg-file - "l" mh-show-print-msg - "p" mh-show-ps-print-msg) - -(gnus-define-keys (mh-show-thread-map "T" mh-show-mode-map) - "?" mh-prefix-help - "u" mh-show-thread-ancestor - "p" mh-show-thread-previous-sibling - "n" mh-show-thread-next-sibling - "t" mh-show-toggle-threads - "d" mh-show-thread-delete - "o" mh-show-thread-refile) - -(gnus-define-keys (mh-show-limit-map "/" mh-show-mode-map) - "'" mh-show-narrow-to-tick - "?" mh-prefix-help - "c" mh-show-narrow-to-cc - "g" mh-show-narrow-to-range - "m" mh-show-narrow-to-from - "s" mh-show-narrow-to-subject - "t" mh-show-narrow-to-to - "w" mh-show-widen) - -(gnus-define-keys (mh-show-extract-map "X" mh-show-mode-map) - "?" mh-prefix-help - "s" mh-show-store-msg - "u" mh-show-store-msg) - -(gnus-define-keys (mh-show-digest-map "D" mh-show-mode-map) - "?" mh-prefix-help - " " mh-show-page-digest - "\177" mh-show-page-digest-backwards - "b" mh-show-burst-digest) - -(gnus-define-keys (mh-show-mime-map "K" mh-show-mode-map) - "?" mh-prefix-help - "a" mh-mime-save-parts - "e" mh-show-display-with-external-viewer - "v" mh-show-toggle-mime-part - "o" mh-show-save-mime-part - "i" mh-show-inline-mime-part - "t" mh-show-toggle-mime-buttons - "\t" mh-show-next-button - [backtab] mh-show-prev-button - "\M-\t" mh-show-prev-button) +(define-keymap :keymap mh-show-mode-map + "SPC" #'mh-show-page-msg + "!" #'mh-show-refile-or-write-again + "'" #'mh-show-toggle-tick + "," #'mh-show-header-display + "." #'mh-show-show + ":" #'mh-show-show-preferred-alternative + ">" #'mh-show-write-message-to-file + "?" #'mh-help + "E" #'mh-show-extract-rejected-mail + "M" #'mh-show-modify + "DEL" #'mh-show-previous-page + "C-d" #'mh-show-delete-msg-no-motion + "TAB" #'mh-show-next-button + "<backtab>" #'mh-show-prev-button + "C-M-i" #'mh-show-prev-button + "ESC d" #'mh-show-redistribute + "^" #'mh-show-refile-msg + "c" #'mh-show-copy-msg + "d" #'mh-show-delete-msg + "e" #'mh-show-edit-again + "f" #'mh-show-forward + "g" #'mh-show-goto-msg + "i" #'mh-show-inc-folder + "k" #'mh-show-delete-subject-or-thread + "m" #'mh-show-send + "n" #'mh-show-next-undeleted-msg + "M-n" #'mh-show-next-unread-msg + "o" #'mh-show-refile-msg + "p" #'mh-show-previous-undeleted-msg + "M-p" #'mh-show-previous-unread-msg + "q" #'mh-show-quit + "r" #'mh-show-reply + "s" #'mh-show-send + "t" #'mh-show-toggle-showing + "u" #'mh-show-undo + "x" #'mh-show-execute-commands + "v" #'mh-show-index-visit-folder + "|" #'mh-show-pipe-msg + + "F" (define-keymap :prefix 'mh-show-folder-map + "?" #'mh-prefix-help + "'" #'mh-index-ticked-messages + "S" #'mh-show-sort-folder + "c" #'mh-show-catchup + "f" #'mh-show-visit-folder + "k" #'mh-show-kill-folder + "l" #'mh-show-list-folders + "n" #'mh-index-new-messages + "o" #'mh-show-visit-folder + "p" #'mh-show-pack-folder + "q" #'mh-show-index-sequenced-messages + "r" #'mh-show-rescan-folder + "s" #'mh-search + "t" #'mh-show-toggle-threads + "u" #'mh-show-undo-folder + "v" #'mh-show-visit-folder) + + "S" (define-keymap :prefix 'mh-show-sequence-map + "'" #'mh-show-narrow-to-tick + "?" #'mh-prefix-help + "d" #'mh-show-delete-msg-from-seq + "k" #'mh-show-delete-seq + "l" #'mh-show-list-sequences + "n" #'mh-show-narrow-to-seq + "p" #'mh-show-put-msg-in-seq + "s" #'mh-show-msg-is-in-seq + "w" #'mh-show-widen) + + "I" mh-inc-spool-map + + "J" (define-keymap :prefix 'mh-show-junk-map + "?" #'mh-prefix-help + "a" #'mh-show-junk-allowlist + "b" #'mh-show-junk-blocklist + "w" #'mh-show-junk-whitelist) + + "P" (define-keymap :prefix 'mh-show-ps-print-map + "?" #'mh-prefix-help + "C" #'mh-show-ps-print-toggle-color + "F" #'mh-show-ps-print-toggle-faces + "f" #'mh-show-ps-print-msg-file + "l" #'mh-show-print-msg + "p" #'mh-show-ps-print-msg) + + "T" (define-keymap :prefix 'mh-show-thread-map + "?" #'mh-prefix-help + "u" #'mh-show-thread-ancestor + "p" #'mh-show-thread-previous-sibling + "n" #'mh-show-thread-next-sibling + "t" #'mh-show-toggle-threads + "d" #'mh-show-thread-delete + "o" #'mh-show-thread-refile) + + "/" (define-keymap :prefix 'mh-show-limit-map + "'" #'mh-show-narrow-to-tick + "?" #'mh-prefix-help + "c" #'mh-show-narrow-to-cc + "g" #'mh-show-narrow-to-range + "m" #'mh-show-narrow-to-from + "s" #'mh-show-narrow-to-subject + "t" #'mh-show-narrow-to-to + "w" #'mh-show-widen) + + "X" (define-keymap :prefix 'mh-show-extract-map + "?" #'mh-prefix-help + "s" #'mh-show-store-msg + "u" #'mh-show-store-msg) + + "D" (define-keymap :prefix 'mh-show-digest-map + "?" #'mh-prefix-help + "SPC" #'mh-show-page-digest + "DEL" #'mh-show-page-digest-backwards + "b" #'mh-show-burst-digest) + + "K" (define-keymap :prefix 'mh-show-mime-map + "?" #'mh-prefix-help + "a" #'mh-mime-save-parts + "e" #'mh-show-display-with-external-viewer + "v" #'mh-show-toggle-mime-part + "o" #'mh-show-save-mime-part + "i" #'mh-show-inline-mime-part + "t" #'mh-show-toggle-mime-buttons + "TAB" #'mh-show-next-button + "<backtab>" #'mh-show-prev-button + "C-M-i" #'mh-show-prev-button)) @@ -817,9 +815,6 @@ operation." ;; Ensure new buffers won't get this mode if default major-mode is nil. (put 'mh-show-mode 'mode-class 'special) -;; Shush compiler. -(defvar font-lock-auto-fontify) - ;;;###mh-autoload (define-derived-mode mh-show-mode text-mode "MH-Show" "Major mode for showing messages in MH-E.\\<mh-show-mode-map> @@ -836,17 +831,14 @@ The hook `mh-show-mode-hook' is called upon entry to this mode. See also `mh-folder-mode'. \\{mh-show-mode-map}" - (mh-do-in-gnu-emacs - (if (boundp 'tool-bar-map) - (set (make-local-variable 'tool-bar-map) mh-show-tool-bar-map))) - (mh-do-in-xemacs - (mh-tool-bar-init :show)) - (set (make-local-variable 'mail-header-separator) mh-mail-header-separator) + (if (boundp 'tool-bar-map) + (setq-local tool-bar-map mh-show-tool-bar-map)) + (setq-local mail-header-separator mh-mail-header-separator) (setq paragraph-start (default-value 'paragraph-start)) (setq buffer-invisibility-spec '((vanish . t) t)) - (set (make-local-variable 'line-move-ignore-invisible) t) + (setq-local line-move-ignore-invisible t) (make-local-variable 'font-lock-defaults) - ;;(set (make-local-variable 'font-lock-support-mode) nil) + ;;(setq-local font-lock-support-mode nil) (cond ((equal mh-highlight-citation-style 'font-lock) (setq font-lock-defaults '(mh-show-font-lock-keywords-with-cite t))) @@ -858,16 +850,8 @@ See also `mh-folder-mode'. (mh-gnus-article-highlight-citation)) (t (setq font-lock-defaults '(mh-show-font-lock-keywords t)))) - (if (and (featurep 'xemacs) - font-lock-auto-fontify) - (turn-on-font-lock)) (when mh-decode-mime-flag - (mh-make-local-hook 'kill-buffer-hook) (add-hook 'kill-buffer-hook #'mh-mime-cleanup nil t)) - (mh-do-in-xemacs - (easy-menu-add mh-show-sequence-menu) - (easy-menu-add mh-show-message-menu) - (easy-menu-add mh-show-folder-menu)) (make-local-variable 'mh-show-folder-buffer) (buffer-disable-undo) (use-local-map mh-show-mode-map)) diff --git a/lisp/mh-e/mh-speed.el b/lisp/mh-e/mh-speed.el index 76ef990d825..d9909a034d9 100644 --- a/lisp/mh-e/mh-speed.el +++ b/lisp/mh-e/mh-speed.el @@ -63,13 +63,13 @@ '("--" ["Visit Folder" mh-speed-view (with-current-buffer speedbar-buffer - (get-text-property (mh-line-beginning-position) 'mh-folder))] + (get-text-property (line-beginning-position) 'mh-folder))] ["Expand Nested Folders" mh-speed-expand-folder - (and (get-text-property (mh-line-beginning-position) 'mh-children-p) - (not (get-text-property (mh-line-beginning-position) 'mh-expanded)))] + (and (get-text-property (line-beginning-position) 'mh-children-p) + (not (get-text-property (line-beginning-position) 'mh-expanded)))] ["Contract Nested Folders" mh-speed-contract-folder - (and (get-text-property (mh-line-beginning-position) 'mh-children-p) - (get-text-property (mh-line-beginning-position) 'mh-expanded))] + (and (get-text-property (line-beginning-position) 'mh-children-p) + (get-text-property (line-beginning-position) 'mh-expanded))] ["Refresh Speedbar" mh-speed-refresh t]) "Extra menu items for speedbar.") @@ -83,11 +83,11 @@ (defvar mh-folder-speedbar-key-map (speedbar-make-specialized-keymap) "Specialized speedbar keymap for MH-E buffers.") -(gnus-define-keys mh-folder-speedbar-key-map - "+" mh-speed-expand-folder - "-" mh-speed-contract-folder - "\r" mh-speed-view - "r" mh-speed-refresh) +(define-keymap :keymap mh-folder-speedbar-key-map + "+" #'mh-speed-expand-folder + "-" #'mh-speed-contract-folder + "RET" #'mh-speed-view + "r" #'mh-speed-refresh) (defvar mh-show-speedbar-key-map mh-folder-speedbar-key-map) (defvar mh-letter-speedbar-key-map mh-folder-speedbar-key-map) @@ -150,7 +150,7 @@ The optional arguments from speedbar are IGNORED." (forward-line -1) (speedbar-change-expand-button-char ?+) (add-text-properties - (mh-line-beginning-position) (1+ (line-beginning-position)) + (line-beginning-position) (1+ (line-beginning-position)) '(mh-expanded nil))) (t (forward-line) @@ -158,14 +158,14 @@ The optional arguments from speedbar are IGNORED." (goto-char point) (speedbar-change-expand-button-char ?-) (add-text-properties - (mh-line-beginning-position) (1+ (line-beginning-position)) + (line-beginning-position) (1+ (line-beginning-position)) '(mh-expanded t))))))) (defun mh-speed-view (&rest _ignored) "Visits the selected folder just as if you had used \\<mh-folder-mode-map>\\[mh-visit-folder]. The optional arguments from speedbar are IGNORED." (interactive) - (let* ((folder (get-text-property (mh-line-beginning-position) 'mh-folder)) + (let* ((folder (get-text-property (line-beginning-position) 'mh-folder)) (range (and (stringp folder) (mh-read-range "Scan" folder t nil nil mh-interpret-number-as-range-flag)))) @@ -191,9 +191,9 @@ created." (forward-line -1) (setf (gethash nil mh-speed-folder-map) (set-marker (or (gethash nil mh-speed-folder-map) (make-marker)) - (1+ (mh-line-beginning-position)))) + (1+ (line-beginning-position)))) (add-text-properties - (mh-line-beginning-position) (1+ (line-beginning-position)) + (line-beginning-position) (1+ (line-beginning-position)) '(mh-folder nil mh-expanded nil mh-children-p t mh-level 0)) (mh-speed-stealth-update t) (when (> mh-speed-update-interval 0) @@ -260,12 +260,12 @@ The update is always carried out if FORCE is non-nil." (speedbar-with-writable (goto-char (gethash folder mh-speed-folder-map (point))) (beginning-of-line) - (if (re-search-forward "([1-9][0-9]*/[0-9]+)" (mh-line-end-position) t) + (if (re-search-forward "([1-9][0-9]*/[0-9]+)" (line-end-position) t) (setq face (mh-speed-bold-face face)) (setq face (mh-speed-normal-face face))) (beginning-of-line) - (when (re-search-forward "\\[.\\] " (mh-line-end-position) t) - (put-text-property (point) (mh-line-end-position) 'face face))))) + (when (re-search-forward "\\[.\\] " (line-end-position) t) + (put-text-property (point) (line-end-position) 'face face))))) (defun mh-speed-normal-face (face) "Return normal face for given FACE." @@ -305,7 +305,7 @@ The function will expand out parent folders of FOLDER if needed." (while suffix-list ;; We always need at least one toggle. We need two if the directory list ;; is stale since a folder was added. - (when (equal prefix (get-text-property (mh-line-beginning-position) + (when (equal prefix (get-text-property (line-beginning-position) 'mh-folder)) (mh-speed-toggle) (unless (get-text-property (point) 'mh-expanded) @@ -359,9 +359,9 @@ uses." (setf (gethash folder-name mh-speed-folder-map) (set-marker (or (gethash folder-name mh-speed-folder-map) (make-marker)) - (1+ (mh-line-beginning-position)))) + (1+ (line-beginning-position)))) (add-text-properties - (mh-line-beginning-position) (1+ (mh-line-beginning-position)) + (line-beginning-position) (1+ (line-beginning-position)) `(mh-folder ,folder-name mh-expanded nil mh-children-p ,(not (not (cdr f))) @@ -374,12 +374,9 @@ uses." (defvar mh-speed-flists-folder nil) (defmacro mh-process-kill-without-query (process) - "PROCESS can be killed without query on Emacs exit. -Avoid using `process-kill-without-query' if possible since it is -now obsolete." - (if (fboundp 'set-process-query-on-exit-flag) - `(set-process-query-on-exit-flag ,process nil) - `(process-kill-without-query ,process))) + "PROCESS can be killed without query on Emacs exit." + (declare (obsolete set-process-query-on-exit-flag "29.1")) + `(set-process-query-on-exit-flag ,process nil)) ;;;###mh-autoload (defun mh-speed-flists (force &rest folders) @@ -391,7 +388,7 @@ flists is run only for that one folder." (interactive (list t)) (when force (when mh-speed-flists-timer - (mh-cancel-timer mh-speed-flists-timer) + (cancel-timer mh-speed-flists-timer) (setq mh-speed-flists-timer nil)) (when (and (processp mh-speed-flists-process) (not (eq (process-status mh-speed-flists-process) 'exit))) @@ -427,7 +424,7 @@ flists is run only for that one folder." (or mh-speed-flists-folder '("-recurse")))) ;; Run flists on all folders the next time around... (setq mh-speed-flists-folder nil) - (mh-process-kill-without-query mh-speed-flists-process) + (set-process-query-on-exit-flag mh-speed-flists-process nil) (set-process-filter mh-speed-flists-process #'mh-speed-parse-flists-output))))))) @@ -462,25 +459,25 @@ be handled next." face) (when pos (goto-char pos) - (goto-char (mh-line-beginning-position)) + (goto-char (line-beginning-position)) (cond ((null (get-text-property (point) 'mh-count)) - (goto-char (mh-line-end-position)) + (goto-char (line-end-position)) (setq face (get-text-property (1- (point)) 'face)) (insert (format " (%s/%s)" unseen total)) (mh-speed-highlight 'unknown face) - (goto-char (mh-line-beginning-position)) + (goto-char (line-beginning-position)) (add-text-properties (point) (1+ (point)) `(mh-count (,unseen . ,total)))) ((not (equal (get-text-property (point) 'mh-count) (cons unseen total))) - (goto-char (mh-line-end-position)) + (goto-char (line-end-position)) (setq face (get-text-property (1- (point)) 'face)) - (re-search-backward " " (mh-line-beginning-position) t) - (delete-region (point) (mh-line-end-position)) + (re-search-backward " " (line-beginning-position) t) + (delete-region (point) (line-end-position)) (insert (format " (%s/%s)" unseen total)) (mh-speed-highlight 'unknown face) - (goto-char (mh-line-beginning-position)) + (goto-char (line-beginning-position)) (add-text-properties (point) (1+ (point)) `(mh-count (,unseen . ,total)))))))))))) @@ -509,15 +506,15 @@ be handled next." (caar parent-kids))) (setq parent-change ? )))) (goto-char parent-position) - (when (equal (get-text-property (mh-line-beginning-position) 'mh-folder) + (when (equal (get-text-property (line-beginning-position) 'mh-folder) parent) - (when (get-text-property (mh-line-beginning-position) 'mh-expanded) + (when (get-text-property (line-beginning-position) 'mh-expanded) (mh-speed-toggle)) (when parent-change (speedbar-with-writable (mh-speedbar-change-expand-button-char parent-change) (add-text-properties - (mh-line-beginning-position) (1+ (mh-line-beginning-position)) + (line-beginning-position) (1+ (line-beginning-position)) `(mh-children-p ,(equal parent-change ?+))))) (mh-speed-highlight mh-speed-last-selected-folder 'mh-speedbar-folder) (setq mh-speed-last-selected-folder nil) @@ -531,15 +528,15 @@ be handled next." "Change the expansion button character to CHAR for the current line." (save-excursion (beginning-of-line) - (if (re-search-forward "\\[.\\]" (mh-line-end-position) t) + (if (re-search-forward "\\[.\\]" (line-end-position) t) (speedbar-with-writable (backward-char 2) (delete-char 1) (insert-char char 1 t) (put-text-property (point) (1- (point)) 'invisible nil) ;; make sure we fix the image on the text here. - (mh-funcall-if-exists - speedbar-insert-image-button-maybe (- (point) 2) 3))))) + (when (fboundp 'speedbar-insert-image-button-maybe) + (speedbar-insert-image-button-maybe (- (point) 2) 3)))))) ;;;###mh-autoload (defun mh-speed-add-folder (folder) @@ -562,9 +559,9 @@ The function invalidates the latest ancestor that is present." (speedbar-with-writable (mh-speedbar-change-expand-button-char ?+) (add-text-properties - (mh-line-beginning-position) (1+ (mh-line-beginning-position)) + (line-beginning-position) (1+ (line-beginning-position)) '(mh-children-p t))) - (when (get-text-property (mh-line-beginning-position) 'mh-expanded) + (when (get-text-property (line-beginning-position) 'mh-expanded) (mh-speed-toggle)) (setq mh-speed-refresh-flag t)))) diff --git a/lisp/mh-e/mh-thread.el b/lisp/mh-e/mh-thread.el index 89b0dbd9798..1be2185ecdf 100644 --- a/lisp/mh-e/mh-thread.el +++ b/lisp/mh-e/mh-thread.el @@ -86,41 +86,33 @@ message parent children (real-child-p t)) -(defvar mh-thread-id-hash nil +(defvar-local mh-thread-id-hash nil "Hash table used to canonicalize message identifiers.") -(make-variable-buffer-local 'mh-thread-id-hash) -(defvar mh-thread-subject-hash nil +(defvar-local mh-thread-subject-hash nil "Hash table used to canonicalize subject strings.") -(make-variable-buffer-local 'mh-thread-subject-hash) -(defvar mh-thread-id-table nil +(defvar-local mh-thread-id-table nil "Thread ID table maps from message identifiers to message containers.") -(make-variable-buffer-local 'mh-thread-id-table) -(defvar mh-thread-index-id-map nil +(defvar-local mh-thread-index-id-map nil "Table to look up message identifier from message index.") -(make-variable-buffer-local 'mh-thread-index-id-map) -(defvar mh-thread-id-index-map nil +(defvar-local mh-thread-id-index-map nil "Table to look up message index number from message identifier.") -(make-variable-buffer-local 'mh-thread-id-index-map) -(defvar mh-thread-subject-container-hash nil +(defvar-local mh-thread-subject-container-hash nil "Hash table used to group messages by subject.") -(make-variable-buffer-local 'mh-thread-subject-container-hash) -(defvar mh-thread-duplicates nil +(defvar-local mh-thread-duplicates nil "Hash table used to associate messages with the same message identifier.") -(make-variable-buffer-local 'mh-thread-duplicates) -(defvar mh-thread-history () +(defvar-local mh-thread-history () "Variable to remember the transformations to the thread tree. When new messages are added, these transformations are rewound, then the links are added from the newly seen messages. Finally the transformations are redone to get the new thread tree. This makes incremental threading easier.") -(make-variable-buffer-local 'mh-thread-history) (defvar mh-thread-body-width nil "Width of scan substring that contains subject and body of message.") @@ -147,7 +139,7 @@ to the message that started everything." (cond (thread-root-flag (while (mh-thread-immediate-ancestor)) (mh-maybe-show)) - ((equal current-level 1) + ((equal current-level 0) (message "Message has no ancestor")) (t (mh-thread-immediate-ancestor) (mh-maybe-show))))) @@ -250,8 +242,8 @@ sibling." (defun mh-thread-current-indentation-level () "Find the number of spaces by which current message is indented." (save-excursion - (let ((address-start-offset (+ mh-cmd-note mh-scan-date-flag-width - mh-scan-date-width 1)) + (let ((address-start-offset (+ mh-cmd-note + mh-scan-field-from-start-offset)) (level 0)) (beginning-of-line) (forward-char address-start-offset) @@ -283,8 +275,8 @@ at the end." (beginning-of-line) (if (eobp) nil - (let ((address-start-offset (+ mh-cmd-note mh-scan-date-flag-width - mh-scan-date-width 1)) + (let ((address-start-offset (+ mh-cmd-note + mh-scan-field-from-start-offset)) (level (mh-thread-current-indentation-level)) spaces begin) (setq begin (point)) @@ -294,7 +286,7 @@ at the end." (while (not (eobp)) (forward-char address-start-offset) (unless (equal (string-match spaces (buffer-substring-no-properties - (point) (mh-line-end-position))) + (point) (line-end-position))) 0) (beginning-of-line) (backward-char) @@ -455,8 +447,8 @@ If optional argument STRING is given then that is assumed to be the scan line. Otherwise uses the line at point as the scan line to parse." (let* ((string (or string (buffer-substring-no-properties - (mh-line-beginning-position) - (mh-line-end-position)))) + (line-beginning-position) + (line-end-position)))) (address-start (+ mh-cmd-note mh-scan-field-from-start-offset)) (body-start (+ mh-cmd-note mh-scan-field-from-end-offset)) (first-string (substring string 0 address-start))) @@ -597,20 +589,20 @@ Only information about messages in MSG-LIST are added to the tree." (while (not (eobp)) (cl-block process-message (let* ((index-line - (prog1 (buffer-substring (point) (mh-line-end-position)) + (prog1 (buffer-substring (point) (line-end-position)) (forward-line))) (index (string-to-number index-line)) - (id (prog1 (buffer-substring (point) (mh-line-end-position)) + (id (prog1 (buffer-substring (point) (line-end-position)) (forward-line))) (refs (prog1 - (buffer-substring (point) (mh-line-end-position)) + (buffer-substring (point) (line-end-position)) (forward-line))) (in-reply-to (prog1 (buffer-substring (point) - (mh-line-end-position)) + (line-end-position)) (forward-line))) (subject (prog1 (buffer-substring - (point) (mh-line-end-position)) + (point) (line-end-position)) (forward-line))) (subject-re-p nil)) (unless (gethash index mh-thread-scan-line-map) diff --git a/lisp/mh-e/mh-tool-bar.el b/lisp/mh-e/mh-tool-bar.el index 94aa8dd4a92..d451ae34d29 100644 --- a/lisp/mh-e/mh-tool-bar.el +++ b/lisp/mh-e/mh-tool-bar.el @@ -27,10 +27,8 @@ ;;; Code: (require 'mh-e) -(mh-do-in-gnu-emacs - (require 'tool-bar)) -(mh-do-in-xemacs - (require 'toolbar)) +(require 'mh-acros) +(require 'tool-bar) ;;; Tool Bar Commands @@ -79,9 +77,6 @@ When INCLUDE-FLAG is non-nil, include message body being replied to." ;;; Tool Bar Creation -;; Shush compiler. -(defvar image-load-path) - (defmacro mh-tool-bar-define (defaults &rest buttons) "Define a tool bar for MH-E. DEFAULTS is the list of buttons that are present by default. It @@ -145,8 +140,6 @@ where, (let* ((name (nth 0 button)) (name-str (symbol-name name)) (icon (nth 2 button)) - (xemacs-icon (mh-do-in-xemacs - `(cdr (assoc (quote ,(intern icon)) mh-xemacs-icon-map)))) (full-doc (nth 3 button)) (doc (if (string-match "\\(.*\\)\n" full-doc) (match-string 1 full-doc) @@ -186,11 +179,10 @@ where, (t 'folder-buttons))) (docs (cond ((eq mbuttons 'letter-buttons) 'letter-docs) ((eq mbuttons 'folder-buttons) 'folder-docs)))) - (add-to-list vector-list `(vector ,xemacs-icon ',function t ,full-doc)) + (add-to-list vector-list `(vector nil ',function t ,full-doc)) (add-to-list setter `(when (member ',name ,list) - (mh-funcall-if-exists - tool-bar-add-item ,icon ',function ',key + (tool-bar-add-item ,icon ',function ',key :help ,doc :enable ',enable-expr))) (add-to-list mbuttons name) (if docs (add-to-list docs doc)))))) @@ -209,145 +201,69 @@ where, (unless (memq x letter-buttons) (error "Letter defaults contains unknown button %s" x))) `(eval-and-compile - ;; GNU Emacs tool bar specific code - (mh-do-in-gnu-emacs - (defun mh-buffer-exists-p (mode) - "Test whether a buffer with major mode MODE is present." - (cl-loop for buf in (buffer-list) - when (with-current-buffer buf - (eq major-mode mode)) - return t)) - ;; Tool bar initialization functions - (defun mh-tool-bar-folder-buttons-init () - (when (mh-buffer-exists-p 'mh-folder-mode) - (let* ((load-path (mh-image-load-path-for-library "mh-e" - "mh-logo.xpm")) - (image-load-path (cons (car load-path) - (when (boundp 'image-load-path) - image-load-path)))) - (setq mh-folder-tool-bar-map - (let ((tool-bar-map (make-sparse-keymap))) - ,@(nreverse folder-button-setter) - tool-bar-map)) - (setq mh-folder-seq-tool-bar-map - (let ((tool-bar-map (copy-keymap mh-folder-tool-bar-map))) - ,@(nreverse sequence-button-setter) - tool-bar-map)) - (setq mh-show-tool-bar-map - (let ((tool-bar-map (make-sparse-keymap))) - ,@(nreverse show-button-setter) - tool-bar-map)) - (setq mh-show-seq-tool-bar-map - (let ((tool-bar-map (copy-keymap mh-show-tool-bar-map))) - ,@(nreverse show-seq-button-setter) - tool-bar-map))))) - (defun mh-tool-bar-letter-buttons-init () - (when (mh-buffer-exists-p 'mh-letter-mode) - (let* ((load-path (mh-image-load-path-for-library "mh-e" - "mh-logo.xpm")) - (image-load-path (cons (car load-path) - (when (boundp 'image-load-path) - image-load-path)))) - (setq mh-letter-tool-bar-map - (let ((tool-bar-map (make-sparse-keymap))) - ,@(nreverse letter-button-setter) - tool-bar-map))))) - ;; Custom setter functions - (defun mh-tool-bar-update (mode default-map sequence-map) - "Update `tool-bar-map' in all buffers of MODE. + (defun mh-buffer-exists-p (mode) + "Test whether a buffer with major mode MODE is present." + (cl-loop for buf in (buffer-list) + when (with-current-buffer buf + (eq major-mode mode)) + return t)) + ;; Tool bar initialization functions + (defun mh-tool-bar-folder-buttons-init () + (when (mh-buffer-exists-p 'mh-folder-mode) + (mh--with-image-load-path + (setq mh-folder-tool-bar-map + (let ((tool-bar-map (make-sparse-keymap))) + ,@(nreverse folder-button-setter) + tool-bar-map)) + (setq mh-folder-seq-tool-bar-map + (let ((tool-bar-map (copy-keymap mh-folder-tool-bar-map))) + ,@(nreverse sequence-button-setter) + tool-bar-map)) + (setq mh-show-tool-bar-map + (let ((tool-bar-map (make-sparse-keymap))) + ,@(nreverse show-button-setter) + tool-bar-map)) + (setq mh-show-seq-tool-bar-map + (let ((tool-bar-map (copy-keymap mh-show-tool-bar-map))) + ,@(nreverse show-seq-button-setter) + tool-bar-map))))) + (defun mh-tool-bar-letter-buttons-init () + (when (mh-buffer-exists-p 'mh-letter-mode) + (mh--with-image-load-path + (setq mh-letter-tool-bar-map + (let ((tool-bar-map (make-sparse-keymap))) + ,@(nreverse letter-button-setter) + tool-bar-map))))) + ;; Custom setter functions + (defun mh-tool-bar-update (mode default-map sequence-map) + "Update `tool-bar-map' in all buffers of MODE. Use SEQUENCE-MAP if display is limited; DEFAULT-MAP otherwise." - (cl-loop for buf in (buffer-list) - do (with-current-buffer buf - (when (eq mode major-mode) ;FIXME: derived-mode-p? - (let ((map (if mh-folder-view-stack - sequence-map - default-map))) - ;; Yes, make-local-variable is necessary since we - ;; get here during initialization when loading - ;; mh-e.el, after the +inbox buffer has been - ;; created, but before mh-folder-mode has run and - ;; created the local map. - (set (make-local-variable 'tool-bar-map) map)))))) - (defun mh-tool-bar-folder-buttons-set (symbol value) - "Construct tool bar for `mh-folder-mode' and `mh-show-mode'." - (set-default symbol value) - (mh-tool-bar-folder-buttons-init) - (mh-tool-bar-update 'mh-folder-mode mh-folder-tool-bar-map - mh-folder-seq-tool-bar-map) - (mh-tool-bar-update 'mh-show-mode mh-show-tool-bar-map - mh-show-seq-tool-bar-map)) - (defun mh-tool-bar-letter-buttons-set (symbol value) - "Construct tool bar for `mh-letter-mode'." - (set-default symbol value) - (mh-tool-bar-letter-buttons-init) - (mh-tool-bar-update 'mh-letter-mode mh-letter-tool-bar-map - mh-letter-tool-bar-map))) - ;; XEmacs specific code - (mh-do-in-xemacs - (defvar mh-tool-bar-folder-vector-map - (list ,@(cl-loop for button in folder-buttons - for vector in folder-vectors - collect `(cons ',button ,vector)))) - (defvar mh-tool-bar-show-vector-map - (list ,@(cl-loop for button in show-buttons - for vector in show-vectors - collect `(cons ',button ,vector)))) - (defvar mh-tool-bar-letter-vector-map - (list ,@(cl-loop for button in letter-buttons - for vector in letter-vectors - collect `(cons ',button ,vector)))) - (defvar mh-tool-bar-folder-buttons) - (defvar mh-tool-bar-show-buttons) - (defvar mh-tool-bar-letter-buttons) - ;; Custom setter functions - (defun mh-tool-bar-letter-buttons-set (symbol value) - (set-default symbol value) - (when mh-xemacs-has-tool-bar-flag - (setq mh-tool-bar-letter-buttons - (cl-loop - for b in value - collect (cdr (assoc b mh-tool-bar-letter-vector-map)))))) - (defun mh-tool-bar-folder-buttons-set (symbol value) - (set-default symbol value) - (when mh-xemacs-has-tool-bar-flag - (setq mh-tool-bar-folder-buttons - (cl-loop - for b in value - collect (cdr (assoc b mh-tool-bar-folder-vector-map)))) - (setq mh-tool-bar-show-buttons - (cl-loop - for b in value - collect (cdr (assoc b mh-tool-bar-show-vector-map)))))) - (defun mh-tool-bar-init (mode) - "Install tool bar in MODE." - (when mh-xemacs-use-tool-bar-flag - (let ((tool-bar (cond ((eq mode :folder) - mh-tool-bar-folder-buttons) - ((eq mode :letter) - mh-tool-bar-letter-buttons) - ((eq mode :show) - mh-tool-bar-show-buttons))) - (height 37) - (width 40) - (buffer (current-buffer))) - (cond - ((eq mh-xemacs-tool-bar-position 'top) - (set-specifier top-toolbar tool-bar buffer) - (set-specifier top-toolbar-visible-p t) - (set-specifier top-toolbar-height height)) - ((eq mh-xemacs-tool-bar-position 'bottom) - (set-specifier bottom-toolbar tool-bar buffer) - (set-specifier bottom-toolbar-visible-p t) - (set-specifier bottom-toolbar-height height)) - ((eq mh-xemacs-tool-bar-position 'left) - (set-specifier left-toolbar tool-bar buffer) - (set-specifier left-toolbar-visible-p t) - (set-specifier left-toolbar-width width)) - ((eq mh-xemacs-tool-bar-position 'right) - (set-specifier right-toolbar tool-bar buffer) - (set-specifier right-toolbar-visible-p t) - (set-specifier right-toolbar-width width)) - (t (set-specifier default-toolbar tool-bar buffer))))))) + (cl-loop for buf in (buffer-list) + do (with-current-buffer buf + (when (eq mode major-mode) ;FIXME: derived-mode-p? + (let ((map (if mh-folder-view-stack + sequence-map + default-map))) + ;; Yes, make-local-variable is necessary since we + ;; get here during initialization when loading + ;; mh-e.el, after the +inbox buffer has been + ;; created, but before mh-folder-mode has run and + ;; created the local map. + (setq-local tool-bar-map map)))))) + (defun mh-tool-bar-folder-buttons-set (symbol value) + "Construct tool bar for `mh-folder-mode' and `mh-show-mode'." + (set-default symbol value) + (mh-tool-bar-folder-buttons-init) + (mh-tool-bar-update 'mh-folder-mode mh-folder-tool-bar-map + mh-folder-seq-tool-bar-map) + (mh-tool-bar-update 'mh-show-mode mh-show-tool-bar-map + mh-show-seq-tool-bar-map)) + (defun mh-tool-bar-letter-buttons-set (symbol value) + "Construct tool bar for `mh-letter-mode'." + (set-default symbol value) + (mh-tool-bar-letter-buttons-init) + (mh-tool-bar-update 'mh-letter-mode mh-letter-tool-bar-map + mh-letter-tool-bar-map)) ;; Declare customizable tool bars (custom-declare-variable 'mh-tool-bar-folder-buttons @@ -372,7 +288,6 @@ Use SEQUENCE-MAP if display is limited; DEFAULT-MAP otherwise." ;;:package-version '(MH-E "7.1") )))) -;; The icon names are duplicated in the Makefile and mh-xemacs.el. (mh-tool-bar-define ((:folder mh-inc-folder mh-mime-save-parts mh-previous-undeleted-msg mh-page-msg diff --git a/lisp/mh-e/mh-utils.el b/lisp/mh-e/mh-utils.el index bbce17013b1..b75025d6a4d 100644 --- a/lisp/mh-e/mh-utils.el +++ b/lisp/mh-e/mh-utils.el @@ -52,7 +52,7 @@ used in lieu of `search' in the CL package." (let ((syntax-table (syntax-table))) (unwind-protect (save-excursion - (mh-mail-abbrev-make-syntax-table) + (mail-abbrev-make-syntax-table) (set-syntax-table mail-abbrev-syntax-table) (backward-word n) (point)) @@ -61,9 +61,9 @@ used in lieu of `search' in the CL package." ;;;###mh-autoload (defun mh-colors-available-p () "Check if colors are available in the Emacs being used." - (or (featurep 'xemacs) - (let ((color-cells (mh-display-color-cells))) - (and (numberp color-cells) (>= color-cells 8))))) + ;; FIXME: Can this be replaced with `display-color-p'? + (let ((color-cells (display-color-cells))) + (and (numberp color-cells) (>= color-cells 8)))) ;;;###mh-autoload (defun mh-colors-in-use-p () @@ -78,16 +78,13 @@ used in lieu of `search' in the CL package." ;;;###mh-autoload (defun mh-make-local-vars (&rest pairs) "Initialize local variables according to the variable-value PAIRS." + (declare (obsolete setq-local "29.1")) (while pairs (set (make-local-variable (car pairs)) (car (cdr pairs))) (setq pairs (cdr (cdr pairs))))) ;;;###mh-autoload -(defun mh-mapc (function list) - "Apply FUNCTION to each element of LIST for side effects only." - (while list - (funcall function (car list)) - (setq list (cdr list)))) +(define-obsolete-function-alias 'mh-mapc #'mapc "29.1") (defvar mh-pick-regexp-chars ".*$[" "List of special characters in pick regular expressions.") @@ -102,7 +99,7 @@ PICK-EXPR is a list of strings. Return nil if PICK-EXPR is nil." (not (string-equal string ""))) (cl-loop for i from 0 to (1- (length mh-pick-regexp-chars)) do (let ((s (string ?\\ (aref mh-pick-regexp-chars i)))) - (setq string (mh-replace-regexp-in-string s s string t t)))) + (setq string (replace-regexp-in-string s s string t t)))) (setq quoted-pick-expr (append quoted-pick-expr (list string))))) quoted-pick-expr)) @@ -119,34 +116,32 @@ Ignores case when searching for OLD." ;;; Logo Display -(defvar mh-logo-cache nil) +;;;###mh-autoload +(defmacro mh--with-image-load-path (&rest body) + "Load `image' and eval BODY with `image-load-path' set appropriately." + (declare (debug t) (indent 0)) + `(progn + ;; Not preloaded in without-x builds. + (require 'image) + (defvar image-load-path) + (declare-function image-load-path-for-library "image") + (let* ((load-path (image-load-path-for-library "mh-e" "mh-logo.xpm")) + (image-load-path (cons (car load-path) image-load-path))) + ,@body))) -;; Shush compiler. -(defvar image-load-path) +(defvar mh-logo-cache nil) ;;;###mh-autoload (defun mh-logo-display () "Modify mode line to display MH-E logo." - (mh-do-in-gnu-emacs - (let* ((load-path (mh-image-load-path-for-library "mh-e" "mh-logo.xpm")) - (image-load-path (cons (car load-path) - (when (boundp 'image-load-path) - image-load-path)))) - (add-text-properties - 0 2 - `(display ,(or mh-logo-cache - (setq mh-logo-cache - (mh-funcall-if-exists - find-image '((:type xpm :ascent center - :file "mh-logo.xpm")))))) - (car mode-line-buffer-identification)))) - (mh-do-in-xemacs - (setq modeline-buffer-identification - (list - (if mh-modeline-glyph - (cons modeline-buffer-id-left-extent mh-modeline-glyph) - (cons modeline-buffer-id-left-extent "XEmacs%N:")) - (cons modeline-buffer-id-right-extent " %17b"))))) + (mh--with-image-load-path + (add-text-properties + 0 2 + `(display ,(or mh-logo-cache + (setq mh-logo-cache + (find-image '(( :type xpm :ascent center + :file "mh-logo.xpm" )))))) + (car mode-line-buffer-identification)))) @@ -509,8 +504,8 @@ they will not be returned." ;; folder is specified, ensure it is nil to avoid adding the ;; folder to the folder-list and adding a slash to it. (when folder - (setq folder (mh-replace-regexp-in-string "^\\+" "" folder)) - (setq folder (mh-replace-regexp-in-string "/+$" "" folder)) + (setq folder (replace-regexp-in-string "^\\+" "" folder)) + (setq folder (replace-regexp-in-string "/+$" "" folder)) (if (equal folder "") (setq folder nil))) ;; Add provided folder to list, unless all folders are asked for. @@ -535,7 +530,12 @@ results of the actual folders call. If optional argument ADD-TRAILING-SLASH-FLAG is non-nil then a slash is added to each of the sub-folder names that may have nested folders within them." - (let* ((folder (mh-normalize-folder-name folder nil nil t)) + ;; In most cases we want to remove a trailing slash. We keep the + ;; slash for "+/", because it refers to folders in the system root + ;; directory, whereas "+" refers to the user's top-level folders. + (let* ((folder (mh-normalize-folder-name folder nil + (string= folder "+/") + t)) (match (gethash folder mh-sub-folders-cache 'no-result)) (sub-folders (cond ((eq match 'no-result) (setf (gethash folder mh-sub-folders-cache) @@ -562,7 +562,6 @@ Expects FOLDER to have already been normalized with (let ((arg-list `(,(expand-file-name "folders" mh-progs) nil (t nil) nil "-noheader" "-norecurse" "-nototal" ,@(if (stringp folder) (list folder) ()))) - (results ()) (current-folder (concat (with-temp-buffer (call-process (expand-file-name "folder" mh-progs) @@ -571,33 +570,48 @@ Expects FOLDER to have already been normalized with "+"))) (with-temp-buffer (apply #'call-process arg-list) - (goto-char (point-min)) - (while (not (and (eolp) (bolp))) - (goto-char (mh-line-end-position)) - (let ((start-pos (mh-line-beginning-position)) - (has-pos (search-backward " has " - (mh-line-beginning-position) t))) - (when (integerp has-pos) - (while (equal (char-after has-pos) ? ) - (cl-decf has-pos)) - (cl-incf has-pos) - (while (equal (char-after start-pos) ? ) - (cl-incf start-pos)) - (let* ((name (buffer-substring start-pos has-pos)) - (first-char (aref name 0)) - (last-char (aref name (1- (length name))))) - (unless (member first-char '(?. ?# ?,)) - (when (and (equal last-char ?+) (equal name current-folder)) - (setq name (substring name 0 (1- (length name))))) - (push - (cons name - (search-forward "(others)" (mh-line-end-position) t)) - results)))) - (forward-line 1)))) + (mh-sub-folders-parse folder current-folder)))) + +(defun mh-sub-folders-parse (folder current-folder) + "Parse the results of \"folders FOLDER\" and return a list of sub-folders. +CURRENT-FOLDER is the result of \"folder -fast\". +FOLDER will be nil or start with '+'; CURRENT-FOLDER will end with '+'. +This function is a testable helper of `mh-sub-folders-actual'." + (let ((results ())) + (goto-char (point-min)) + (while (not (and (eolp) (bolp))) + (goto-char (line-end-position)) + (let ((start-pos (line-beginning-position)) + (has-pos (search-backward " has " + (line-beginning-position) t))) + (when (integerp has-pos) + (while (equal (char-after has-pos) ? ) + (cl-decf has-pos)) + (cl-incf has-pos) + (while (equal (char-after start-pos) ? ) + (cl-incf start-pos)) + (let* ((name (buffer-substring start-pos has-pos)) + (first-char (aref name 0)) + (second-char (and (length> name 1) (aref name 1))) + (last-char (aref name (1- (length name))))) + (unless (member first-char '(?. ?# ?,)) + (when (and (equal last-char ?+) (equal name current-folder)) + (setq name (substring name 0 (1- (length name))))) + ;; nmh outputs double slash in root folder, e.g., "//tmp" + (when (and (equal first-char ?/) (equal second-char ?/)) + (setq name (substring name 1))) + (push + (cons name + (search-forward "(others)" (line-end-position) t)) + results)))) + (forward-line 1))) (setq results (nreverse results)) (when (stringp folder) (setq results (cdr results)) (let ((folder-name-len (length (format "%s/" (substring folder 1))))) + (when (equal "+/" folder) + ;; folder "+/" includes a trailing slash + (cl-decf folder-name-len)) (setq results (mapcar (lambda (f) (cons (substring (car f) folder-name-len) (cdr f))) @@ -727,16 +741,12 @@ See Info node `(elisp) Programmed Completion' for details." ((equal path mh-user-path) nil) (t (file-directory-p path)))))))) -;; Shush compiler. -(defvar completion-root-regexp) ;; Apparently used in XEmacs - (defun mh-folder-completing-read (prompt default allow-root-folder-flag) "Read folder name with PROMPT and default result DEFAULT. If ALLOW-ROOT-FOLDER-FLAG is non-nil then \"+\" is allowed to be a folder name corresponding to `mh-user-path'." (mh-normalize-folder-name - (let ((completion-root-regexp "^[+/]") ;FIXME: Who/what uses that? - (minibuffer-local-completion-map mh-folder-completion-map) + (let ((minibuffer-local-completion-map mh-folder-completion-map) (mh-allow-root-folder-flag allow-root-folder-flag)) (completing-read prompt 'mh-folder-completion-function nil nil nil 'mh-folder-hist default)) @@ -920,11 +930,7 @@ Handle RFC 822 (or later) continuation lines." (defvar mh-hidden-header-keymap (let ((map (make-sparse-keymap))) - (mh-do-in-gnu-emacs - (define-key map [mouse-2] #'mh-letter-toggle-header-field-display-button)) - (mh-do-in-xemacs - (define-key map '(button2) - #'mh-letter-toggle-header-field-display-button)) + (define-key map [mouse-2] #'mh-letter-toggle-header-field-display-button) map)) ;;;###mh-autoload @@ -958,9 +964,9 @@ is hidden, if positive then the field is displayed." (and (numberp arg) (>= arg 0)) (and (eq arg 'long) - (> (mh-line-beginning-position 5) end))) + (> (line-beginning-position 5) end))) (remove-text-properties begin end '(invisible nil)) - (search-forward ":" (mh-line-end-position) t) + (search-forward ":" (line-end-position) t) (mh-letter-skip-leading-whitespace-in-header-field)) ;; XXX Redesign to make usable by user. Perhaps use a positive ;; numeric prefix to make that many lines visible. diff --git a/lisp/mh-e/mh-xface.el b/lisp/mh-e/mh-xface.el index 58177c1794e..8350f3d0fbb 100644 --- a/lisp/mh-e/mh-xface.el +++ b/lisp/mh-e/mh-xface.el @@ -30,17 +30,11 @@ (autoload 'mail-header-parse-address "mail-parse") (autoload 'message-fetch-field "message") -(defvar mh-show-xface-function - (cond ((and (featurep 'xemacs) (locate-library "x-face") (not (featurep 'xface))) - (load "x-face" t t) - #'mh-face-display-function) - ((>= emacs-major-version 21) - #'mh-face-display-function) - (t #'ignore)) +(defvar mh-show-xface-function #'mh-face-display-function "Determine at run time what function should be called to display X-Face.") +(make-obsolete-variable 'mh-show-xface-function nil "29.1") -(defvar mh-uncompface-executable - (and (fboundp 'executable-find) (executable-find "uncompface"))) +(defvar mh-uncompface-executable (executable-find "uncompface")) @@ -52,7 +46,7 @@ (when (and window-system mh-show-use-xface-flag (or mh-decode-mime-flag mh-mhl-format-file mh-clean-message-header-flag)) - (funcall mh-show-xface-function))) + (mh-face-display-function))) (defun mh-face-display-function () "Display a Face, X-Face, or X-Image-URL header field. @@ -77,53 +71,20 @@ in this order is used." (when type (goto-char (point-min)) (when (re-search-forward "^from:" (point-max) t) - ;; GNU Emacs - (mh-do-in-gnu-emacs - (if (eq type 'url) - (mh-x-image-url-display url) - (mh-funcall-if-exists - insert-image (create-image - raw type t - :foreground - (mh-face-foreground 'mh-show-xface nil t) - :background - (mh-face-background 'mh-show-xface nil t)) - " "))) - ;; XEmacs - (mh-do-in-xemacs - (cond - ((eq type 'url) - (mh-x-image-url-display url)) - ((eq type 'png) - (when (featurep 'png) - (set-extent-begin-glyph - (make-extent (point) (point)) - (make-glyph (vector 'png ':data (mh-face-to-png face)))))) - ;; Try internal xface support if available... - ((and (eq type 'pbm) (featurep 'xface)) - (set-glyph-face - (set-extent-begin-glyph - (make-extent (point) (point)) - (make-glyph (vector 'xface ':data (concat "X-Face: " x-face)))) - 'mh-show-xface)) - ;; Otherwise try external support with x-face... - ((and (eq type 'pbm) - (fboundp 'x-face-xmas-wl-display-x-face) - (fboundp 'executable-find) (executable-find "uncompface")) - (mh-funcall-if-exists x-face-xmas-wl-display-x-face)) - ;; Picon display - ((and raw (member type '(xpm xbm gif))) - (when (featurep type) - (set-extent-begin-glyph - (make-extent (point) (point)) - (make-glyph (vector type ':data raw)))))) - (when raw (insert " ")))))))) + (if (eq type 'url) + (mh-x-image-url-display url) + (insert-image (create-image + raw type t + :foreground + (face-foreground 'mh-show-xface nil t) + :background + (face-background 'mh-show-xface nil t)) + " "))))))) (defun mh-face-to-png (data) "Convert base64 encoded DATA to png image." (with-temp-buffer - (if (fboundp 'set-buffer-multibyte) - (set-buffer-multibyte nil)) + (set-buffer-multibyte nil) (insert data) (ignore-errors (base64-decode-region (point-min) (point-max))) (buffer-string))) @@ -131,8 +92,7 @@ in this order is used." (defun mh-uncompface (data) "Run DATA through `uncompface' to generate bitmap." (with-temp-buffer - (if (fboundp 'set-buffer-multibyte) - (set-buffer-multibyte nil)) + (set-buffer-multibyte nil) (insert data) (when (and mh-uncompface-executable (equal (call-process-region (point-min) (point-max) @@ -176,10 +136,8 @@ The directories are searched for in the order they appear in the list.") (defvar mh-picon-image-types (cl-loop for type in '(xpm xbm gif) - when (or (mh-do-in-gnu-emacs - (ignore-errors - (mh-funcall-if-exists image-type-available-p type))) - (mh-do-in-xemacs (featurep type))) + when (ignore-errors + (image-type-available-p type)) collect type)) (autoload 'message-tokenize-header "sendmail") @@ -270,8 +228,7 @@ file contents as a string is returned. If FILE is nil, then both elements of the list are nil." (if (stringp file) (with-temp-buffer - (if (fboundp 'set-buffer-multibyte) - (set-buffer-multibyte nil)) + (set-buffer-multibyte nil) (let ((type (and (string-match ".*\\.\\(...\\)$" file) (intern (match-string 1 file))))) (insert-file-contents-literally file) @@ -321,7 +278,7 @@ If the URL isn't present in the cache then it is fetched with wget." (let* ((cache-filename (mh-x-image-url-cache-canonicalize url)) (state (mh-x-image-get-download-state cache-filename)) (marker (point-marker))) - (set (make-local-variable 'mh-x-image-marker) marker) + (setq-local mh-x-image-marker marker) (cond ((not (mh-x-image-url-sane-p url))) ((eq state 'ok) (mh-x-image-display cache-filename marker)) @@ -357,14 +314,14 @@ This is only done if `mh-x-image-cache-directory' is nil." (defun mh-x-image-url-cache-canonicalize (url) "Canonicalize URL. Replace the ?/ character with a ?! character and append .png. -Also replaces special characters with `mh-url-hexify-string' +Also replaces special characters with `url-hexify-string' since not all characters, such as :, are valid within Windows filenames. In addition, replaces * with %2a. See URL `https://msdn.microsoft.com/library/default.asp?url=/library/en-us/shellcc/platform/shell/reference/ifaces/iitemnamelimits/GetValidCharacters.asp'." (format "%s/%s.png" mh-x-image-cache-directory - (mh-replace-regexp-in-string + (replace-regexp-in-string "\\*" "%2a" - (mh-url-hexify-string + (url-hexify-string (with-temp-buffer (insert url) (mh-replace-string "/" "!") @@ -404,16 +361,7 @@ filenames. In addition, replaces * with %2a. See URL (when (and (file-readable-p image) (not (file-symlink-p image)) (eq marker mh-x-image-marker)) (goto-char marker) - (mh-do-in-gnu-emacs - (mh-funcall-if-exists insert-image (create-image image 'png))) - (mh-do-in-xemacs - (when (featurep 'png) - (set-extent-begin-glyph - (make-extent (point) (point)) - (make-glyph - (vector 'png ':data (with-temp-buffer - (insert-file-contents-literally image) - (buffer-string)))))))) + (insert-image (create-image image 'png))) (set-buffer-modified-p buffer-modified-flag))))) (defun mh-x-image-url-fetch-image (url cache-file marker sentinel) @@ -423,12 +371,11 @@ be displayed in a buffer and position specified by MARKER. The actual display is carried out by the SENTINEL function." (if mh-wget-executable (let ((buffer (generate-new-buffer mh-temp-fetch-buffer)) - (filename (or (mh-funcall-if-exists make-temp-file "mhe-fetch") - (expand-file-name (make-temp-name "~/mhe-fetch"))))) + (filename (make-temp-file "mhe-fetch"))) (with-current-buffer buffer - (set (make-local-variable 'mh-x-image-url-cache-file) cache-file) - (set (make-local-variable 'mh-x-image-marker) marker) - (set (make-local-variable 'mh-x-image-temp-file) filename)) + (setq-local mh-x-image-url-cache-file cache-file) + (setq-local mh-x-image-marker marker) + (setq-local mh-x-image-temp-file filename)) (set-process-sentinel (start-process "*mh-x-image-url-fetch*" buffer mh-wget-executable mh-wget-option filename url) diff --git a/lisp/midnight.el b/lisp/midnight.el index b3adbf00172..51173e7429f 100644 --- a/lisp/midnight.el +++ b/lisp/midnight.el @@ -159,7 +159,7 @@ the current date/time, buffer name, how many seconds ago it was displayed (can be nil if the buffer was never displayed) and its lifetime, i.e., its \"age\" when it will be purged." (interactive) - (let ((tm (current-time)) bts (ts (format-time-string "%Y-%m-%d %T")) + (let* ((tm (current-time)) bts (ts (format-time-string "%Y-%m-%d %T" tm)) delay cbld bn) (dolist (buf (buffer-list)) (when (buffer-live-p buf) diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 21d610fdf44..28bd1df59ab 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -1,4 +1,4 @@ -;;; minibuffer.el --- Minibuffer completion functions -*- lexical-binding: t -*- +;;; minibuffer.el --- Minibuffer and completion functions -*- lexical-binding: t -*- ;; Copyright (C) 2008-2021 Free Software Foundation, Inc. @@ -2735,7 +2735,7 @@ not active.") This is only used when the minibuffer area has no active minibuffer. Note that the minibuffer may change to this mode more often than -you might expect. For instance, typing `M-x' may change the +you might expect. For instance, typing \\`M-x' may change the buffer to this mode, then to a different mode, and then back again to this mode upon exit. Code running from `minibuffer-inactive-mode-hook' has to be prepared to run diff --git a/lisp/mouse.el b/lisp/mouse.el index 8474a821118..11fdd3f6391 100644 --- a/lisp/mouse.el +++ b/lisp/mouse.el @@ -184,8 +184,8 @@ items `Turn Off' and `Help'." "-" " " (format "%S" minor-mode)))) (turn-off menu-item "Turn off minor mode" ,mm-fun) (help menu-item "Help for minor mode" - (lambda () (interactive) - (describe-function ',mm-fun))))))) + ,(lambda () (interactive) + (describe-function mm-fun))))))) (if menu (popup-menu menu) (message "No menu available"))))) @@ -271,7 +271,7 @@ not it is actually displayed." ;; FIXME: We have a problem here: we have to use the global/local/minor ;; so they're displayed in the expected order, but later on in the command ;; loop, they're actually looked up in the opposite order. - (apply 'append + (apply #'append global-menu local-menu minor-mode-menus))) @@ -327,13 +327,23 @@ the function `context-menu-filter-function'." (setq menu (funcall fun menu click)) nil))) - ;; Remove duplicate separators - (let ((l menu)) - (while (consp l) - (when (and (equal (cdr-safe (car l)) menu-bar-separator) - (equal (cdr-safe (cadr l)) menu-bar-separator)) - (setcdr l (cddr l))) - (setq l (cdr l)))) + ;; Remove duplicate separators as well as ones at the beginning or + ;; end of the menu. + (let ((l menu) saw-first-item) + (while (and (consp l) + (consp (cdr l))) + ;; If the next item is a separator, remove it if 1) we haven't + ;; seen any other items yet, or 2) it's followed by either + ;; another separator or the end of the list. + (if (and (equal (cdr-safe (cadr l)) menu-bar-separator) + (or (not saw-first-item) + (null (caddr l)) + (equal (cdr-safe (caddr l)) menu-bar-separator))) + (setcdr l (cddr l)) + ;; The "first item" is any cons cell; this excludes the + ;; `keymap' symbol and the menu name. + (when (consp (cadr l)) (setq saw-first-item t)) + (setq l (cdr l))))) (when (functionp context-menu-filter-function) (setq menu (funcall context-menu-filter-function menu click))) @@ -514,8 +524,8 @@ Some context functions add menu items below the separator." menu) (defvar context-menu-entry - `(menu-item ,(purecopy "Context Menu") ignore - :filter (lambda (_) (context-menu-map))) + `(menu-item ,(purecopy "Context Menu") ,(make-sparse-keymap) + :filter ,(lambda (_) (context-menu-map))) "Menu item that creates the context menu and can be bound to a mouse key.") (defvar context-menu-mode-map @@ -536,7 +546,7 @@ Some context functions add menu items below the separator." When Context Menu mode is enabled, clicking the mouse button down-mouse-3 activates the menu whose contents depends on its surrounding context." - :global t :group 'mouse) + :global t) (defun context-menu-open () "Start key navigation of the context menu. @@ -548,7 +558,7 @@ This is the keyboard interface to \\[context-menu-map]." (call-interactively map) (popup-menu map (point))))) -(global-set-key [S-f10] 'context-menu-open) +(global-set-key [S-f10] #'context-menu-open) (defun mark-thing-at-mouse (click thing) "Activate the region around THING found near the mouse CLICK." @@ -603,7 +613,7 @@ This command must be bound to a mouse click." (or (eq frame oframe) (set-mouse-position (selected-frame) (1- (frame-width)) 0)))) -(define-obsolete-function-alias 'mouse-tear-off-window 'tear-off-window "24.4") +(define-obsolete-function-alias 'mouse-tear-off-window #'tear-off-window "24.4") (defun tear-off-window (click) "Delete the selected window, and create a new frame displaying its buffer." (interactive (list last-nonmenu-event)) @@ -679,7 +689,6 @@ must be one of the symbols `header', `mode', or `vertical'." ;; previously sampled position. The difference of `position' ;; and `last-position' determines the size change of WINDOW. (last-position position) - (draggable t) posn-window growth dragged) ;; Decide on whether we are allowed to track at all and whose ;; window's edge we drag. @@ -732,7 +741,7 @@ must be one of the symbols `header', `mode', or `vertical'." (setq dragged t) (adjust-window-trailing-edge window growth t t)) (setq last-position position)) - (draggable + (t ;; Drag bottom edge of `window'. (setq start (event-start event)) ;; Set `posn-window' to the window where `event' was recorded. @@ -1573,8 +1582,7 @@ The region will be defined with mark and point." (mouse-minibuffer-check start-event) (setq mouse-selection-click-count-buffer (current-buffer)) (deactivate-mark) - (let* ((scroll-margin 0) ; Avoid margin scrolling (Bug#9541). - (start-posn (event-start start-event)) + (let* ((start-posn (event-start start-event)) (start-point (posn-point start-posn)) (start-window (posn-window start-posn)) (_ (with-current-buffer (window-buffer start-window) @@ -1596,76 +1604,88 @@ The region will be defined with mark and point." ;; Don't count the mode line. (1- (nth 3 bounds)))) (click-count (1- (event-click-count start-event))) - ;; Suppress automatic hscrolling, because that is a nuisance - ;; when setting point near the right fringe (but see below). + ;; Save original automatic scrolling behavior (see below). (auto-hscroll-mode-saved auto-hscroll-mode) - (old-track-mouse track-mouse)) + (scroll-margin-saved scroll-margin) + (old-track-mouse track-mouse) + (cleanup (lambda () + (setq track-mouse old-track-mouse) + (setq auto-hscroll-mode auto-hscroll-mode-saved) + (setq scroll-margin scroll-margin-saved)))) + (condition-case err + (progn + (setq mouse-selection-click-count click-count) + + ;; Suppress automatic scrolling near the edges while tracking + ;; movement, as it interferes with the natural dragging behavior + ;; (point will unexpectedly be moved beneath the pointer, making + ;; selections in auto-scrolling margins impossible). + (setq auto-hscroll-mode nil) + (setq scroll-margin 0) + + ;; In case the down click is in the middle of some intangible text, + ;; use the end of that text, and put it in START-POINT. + (if (< (point) start-point) + (goto-char start-point)) + (setq start-point (point)) + + ;; Activate the region, using `mouse-start-end' to determine where + ;; to put point and mark (e.g., double-click will select a word). + (setq-local transient-mark-mode + (if (eq transient-mark-mode 'lambda) + '(only) + (cons 'only transient-mark-mode))) + (let ((range (mouse-start-end start-point start-point click-count))) + (push-mark (nth 0 range) t t) + (goto-char (nth 1 range))) - (setq mouse-selection-click-count click-count) - ;; In case the down click is in the middle of some intangible text, - ;; use the end of that text, and put it in START-POINT. - (if (< (point) start-point) - (goto-char start-point)) - (setq start-point (point)) + (setf (terminal-parameter nil 'mouse-drag-start) start-event) + ;; Set 'track-mouse' to something neither nil nor t, so that mouse + ;; events are not reported to have happened on the tool bar or the + ;; tab bar, as that breaks drag events that originate on the window + ;; body below these bars; see make_lispy_position and bug#51794. + (setq track-mouse 'drag-tracking) - ;; Activate the region, using `mouse-start-end' to determine where - ;; to put point and mark (e.g., double-click will select a word). - (setq-local transient-mark-mode - (if (eq transient-mark-mode 'lambda) - '(only) - (cons 'only transient-mark-mode))) - (let ((range (mouse-start-end start-point start-point click-count))) - (push-mark (nth 0 range) t t) - (goto-char (nth 1 range))) - - (setf (terminal-parameter nil 'mouse-drag-start) start-event) - ;; Set 'track-mouse' to something neither nil nor t, so that mouse - ;; events are not reported to have happened on the tool bar or the - ;; tab bar, as that breaks drag events that originate on the window - ;; body below these bars; see make_lispy_position and bug#51794. - (setq track-mouse 'drag-tracking) - (setq auto-hscroll-mode nil) - - (set-transient-map - (let ((map (make-sparse-keymap))) - (define-key map [switch-frame] #'ignore) - (define-key map [select-window] #'ignore) - (define-key map [mouse-movement] - (lambda (event) (interactive "e") - (let* ((end (event-end event)) - (end-point (posn-point end))) - (unless (eq end-point start-point) - ;; As soon as the user moves, we can re-enable auto-hscroll. - (setq auto-hscroll-mode auto-hscroll-mode-saved) - ;; And remember that we have moved, so mouse-set-region can know - ;; its event is really a drag event. - (setcar start-event 'mouse-movement)) - (if (and (eq (posn-window end) start-window) - (integer-or-marker-p end-point)) - (mouse--drag-set-mark-and-point start-point - end-point click-count) - (let ((mouse-row (cdr (cdr (mouse-position))))) - (cond - ((null mouse-row)) - ((< mouse-row top) - (mouse-scroll-subr start-window (- mouse-row top) - nil start-point)) - ((>= mouse-row bottom) - (mouse-scroll-subr start-window (1+ (- mouse-row bottom)) - nil start-point)))))))) - map) - t (lambda () - (setq track-mouse old-track-mouse) - (setq auto-hscroll-mode auto-hscroll-mode-saved) - ;; Don't deactivate the mark when the context menu was invoked - ;; by down-mouse-3 immediately after down-mouse-1 and without - ;; releasing the mouse button with mouse-1. This allows to use - ;; region-related context menu to operate on the selected region. - (unless (and context-menu-mode - (eq (car-safe (aref (this-command-keys-vector) 0)) - 'down-mouse-3)) - (deactivate-mark) - (pop-mark)))))) + (set-transient-map + (let ((map (make-sparse-keymap))) + (define-key map [switch-frame] #'ignore) + (define-key map [select-window] #'ignore) + (define-key map [mouse-movement] + (lambda (event) (interactive "e") + (let* ((end (event-end event)) + (end-point (posn-point end))) + (unless (eq end-point start-point) + ;; And remember that we have moved, so mouse-set-region can know + ;; its event is really a drag event. + (setcar start-event 'mouse-movement)) + (if (and (eq (posn-window end) start-window) + (integer-or-marker-p end-point)) + (mouse--drag-set-mark-and-point start-point + end-point click-count) + (let ((mouse-row (cdr (cdr (mouse-position))))) + (cond + ((null mouse-row)) + ((< mouse-row top) + (mouse-scroll-subr start-window (- mouse-row top) + nil start-point)) + ((>= mouse-row bottom) + (mouse-scroll-subr start-window (1+ (- mouse-row bottom)) + nil start-point)))))))) + map) + t (lambda () + (funcall cleanup) + ;; Don't deactivate the mark when the context menu was invoked + ;; by down-mouse-3 immediately after down-mouse-1 and without + ;; releasing the mouse button with mouse-1. This allows to use + ;; region-related context menu to operate on the selected region. + (unless (and context-menu-mode + (eq (car-safe (aref (this-command-keys-vector) 0)) + 'down-mouse-3)) + (deactivate-mark) + (pop-mark))))) + ;; Cleanup on errors + (error (funcall cleanup) + (signal (car err) (cdr err)))))) (defun mouse--drag-set-mark-and-point (start click click-count) (let* ((range (mouse-start-end start click click-count)) @@ -1821,7 +1841,7 @@ If MODE is 2 then do the same for lines." event))) (setcar last new) (if (and (not (equal modifiers old-modifiers)) - (key-binding (apply 'vector events))) + (key-binding (apply #'vector events))) t (setcar last event) nil))) @@ -1875,12 +1895,12 @@ regardless of where you click." (setq mouse-selection-click-count 0) (yank arg)) -(defun mouse-yank-primary (click) - "Insert the primary selection at the position clicked on. +(defun mouse-yank-primary (&optional event) + "Insert the primary selection, Move point to the end of the inserted text, and set mark at beginning. If `mouse-yank-at-point' is non-nil, insert at point -regardless of where you click." - (interactive "e") +otherwise insert it at the position of EVENT." + (interactive (list last-nonmenu-event)) ;; Give temporary modes such as isearch a chance to turn off. (run-hooks 'mouse-leave-buffer-hook) ;; Without this, confusing things happen upon e.g. inserting into @@ -1888,7 +1908,7 @@ regardless of where you click." (when select-active-regions (let (select-active-regions) (deactivate-mark))) - (or mouse-yank-at-point (mouse-set-point click)) + (or mouse-yank-at-point (mouse-set-point event)) (let ((primary (gui-get-primary-selection))) (push-mark) (insert-for-yank primary))) @@ -2028,11 +2048,11 @@ if `mouse-drag-copy-region' is non-nil)." (setq mouse-save-then-kill-posn click-pt))))) -(global-set-key [M-mouse-1] 'mouse-start-secondary) -(global-set-key [M-drag-mouse-1] 'mouse-set-secondary) -(global-set-key [M-down-mouse-1] 'mouse-drag-secondary) -(global-set-key [M-mouse-3] 'mouse-secondary-save-then-kill) -(global-set-key [M-mouse-2] 'mouse-yank-secondary) +(global-set-key [M-mouse-1] #'mouse-start-secondary) +(global-set-key [M-drag-mouse-1] #'mouse-set-secondary) +(global-set-key [M-down-mouse-1] #'mouse-drag-secondary) +(global-set-key [M-mouse-3] #'mouse-secondary-save-then-kill) +(global-set-key [M-mouse-2] #'mouse-yank-secondary) (defconst mouse-secondary-overlay (let ((ol (make-overlay (point-min) (point-min)))) @@ -3192,78 +3212,78 @@ is copied instead of being cut." ;;; Bindings for mouse commands. -(global-set-key [down-mouse-1] 'mouse-drag-region) -(global-set-key [mouse-1] 'mouse-set-point) -(global-set-key [drag-mouse-1] 'mouse-set-region) +(global-set-key [down-mouse-1] #'mouse-drag-region) +(global-set-key [mouse-1] #'mouse-set-point) +(global-set-key [drag-mouse-1] #'mouse-set-region) (defun mouse--strip-first-event (_prompt) (substring (this-single-command-raw-keys) 1)) -(define-key function-key-map [left-fringe mouse-1] 'mouse--strip-first-event) -(define-key function-key-map [right-fringe mouse-1] 'mouse--strip-first-event) +(define-key function-key-map [left-fringe mouse-1] #'mouse--strip-first-event) +(define-key function-key-map [right-fringe mouse-1] #'mouse--strip-first-event) -(global-set-key [mouse-2] 'mouse-yank-primary) +(global-set-key [mouse-2] #'mouse-yank-primary) ;; Allow yanking also when the corresponding cursor is "in the fringe". -(define-key function-key-map [right-fringe mouse-2] 'mouse--strip-first-event) -(define-key function-key-map [left-fringe mouse-2] 'mouse--strip-first-event) -(global-set-key [mouse-3] 'mouse-save-then-kill) -(define-key function-key-map [right-fringe mouse-3] 'mouse--strip-first-event) -(define-key function-key-map [left-fringe mouse-3] 'mouse--strip-first-event) +(define-key function-key-map [right-fringe mouse-2] #'mouse--strip-first-event) +(define-key function-key-map [left-fringe mouse-2] #'mouse--strip-first-event) +(global-set-key [mouse-3] #'mouse-save-then-kill) +(define-key function-key-map [right-fringe mouse-3] #'mouse--strip-first-event) +(define-key function-key-map [left-fringe mouse-3] #'mouse--strip-first-event) ;; By binding these to down-going events, we let the user use the up-going ;; event to make the selection, saving a click. -(global-set-key [C-down-mouse-1] 'mouse-buffer-menu) +(global-set-key [C-down-mouse-1] #'mouse-buffer-menu) (if (not (eq system-type 'ms-dos)) - (global-set-key [S-down-mouse-1] 'mouse-appearance-menu)) + (global-set-key [S-down-mouse-1] #'mouse-appearance-menu)) ;; C-down-mouse-2 is bound in facemenu.el. (global-set-key [C-down-mouse-3] `(menu-item ,(purecopy "Menu Bar") ignore - :filter (lambda (_) - (if (zerop (or (frame-parameter nil 'menu-bar-lines) 0)) - (mouse-menu-bar-map) - (mouse-menu-major-mode-map))))) + :filter ,(lambda (_) + (if (zerop (or (frame-parameter nil 'menu-bar-lines) 0)) + (mouse-menu-bar-map) + (mouse-menu-major-mode-map))))) ;; Binding mouse-1 to mouse-select-window when on mode-, header-, or ;; vertical-line prevents Emacs from signaling an error when the mouse ;; button is released after dragging these lines, on non-toolkit ;; versions. -(global-set-key [header-line down-mouse-1] 'mouse-drag-header-line) -(global-set-key [header-line mouse-1] 'mouse-select-window) -(global-set-key [tab-line down-mouse-1] 'mouse-drag-tab-line) -(global-set-key [tab-line mouse-1] 'mouse-select-window) +(global-set-key [header-line down-mouse-1] #'mouse-drag-header-line) +(global-set-key [header-line mouse-1] #'mouse-select-window) +(global-set-key [tab-line down-mouse-1] #'mouse-drag-tab-line) +(global-set-key [tab-line mouse-1] #'mouse-select-window) ;; (global-set-key [mode-line drag-mouse-1] 'mouse-select-window) -(global-set-key [mode-line down-mouse-1] 'mouse-drag-mode-line) -(global-set-key [mode-line mouse-1] 'mouse-select-window) -(global-set-key [mode-line mouse-2] 'mouse-delete-other-windows) -(global-set-key [mode-line mouse-3] 'mouse-delete-window) -(global-set-key [mode-line C-mouse-2] 'mouse-split-window-horizontally) -(global-set-key [vertical-scroll-bar C-mouse-2] 'mouse-split-window-vertically) -(global-set-key [horizontal-scroll-bar C-mouse-2] 'mouse-split-window-horizontally) -(global-set-key [vertical-line down-mouse-1] 'mouse-drag-vertical-line) -(global-set-key [vertical-line mouse-1] 'mouse-select-window) -(global-set-key [vertical-line C-mouse-2] 'mouse-split-window-vertically) -(global-set-key [right-divider down-mouse-1] 'mouse-drag-vertical-line) -(global-set-key [right-divider mouse-1] 'ignore) -(global-set-key [right-divider C-mouse-2] 'mouse-split-window-vertically) -(global-set-key [bottom-divider down-mouse-1] 'mouse-drag-mode-line) -(global-set-key [bottom-divider mouse-1] 'ignore) -(global-set-key [bottom-divider C-mouse-2] 'mouse-split-window-horizontally) -(global-set-key [left-edge down-mouse-1] 'mouse-drag-left-edge) -(global-set-key [left-edge mouse-1] 'ignore) -(global-set-key [top-left-corner down-mouse-1] 'mouse-drag-top-left-corner) -(global-set-key [top-left-corner mouse-1] 'ignore) -(global-set-key [top-edge down-mouse-1] 'mouse-drag-top-edge) -(global-set-key [top-edge mouse-1] 'ignore) -(global-set-key [top-right-corner down-mouse-1] 'mouse-drag-top-right-corner) -(global-set-key [top-right-corner mouse-1] 'ignore) -(global-set-key [right-edge down-mouse-1] 'mouse-drag-right-edge) -(global-set-key [right-edge mouse-1] 'ignore) -(global-set-key [bottom-right-corner down-mouse-1] 'mouse-drag-bottom-right-corner) -(global-set-key [bottom-right-corner mouse-1] 'ignore) -(global-set-key [bottom-edge down-mouse-1] 'mouse-drag-bottom-edge) -(global-set-key [bottom-edge mouse-1] 'ignore) -(global-set-key [bottom-left-corner down-mouse-1] 'mouse-drag-bottom-left-corner) -(global-set-key [bottom-left-corner mouse-1] 'ignore) +(global-set-key [mode-line down-mouse-1] #'mouse-drag-mode-line) +(global-set-key [mode-line mouse-1] #'mouse-select-window) +(global-set-key [mode-line mouse-2] #'mouse-delete-other-windows) +(global-set-key [mode-line mouse-3] #'mouse-delete-window) +(global-set-key [mode-line C-mouse-2] #'mouse-split-window-horizontally) +(global-set-key [vertical-scroll-bar C-mouse-2] #'mouse-split-window-vertically) +(global-set-key [horizontal-scroll-bar C-mouse-2] #'mouse-split-window-horizontally) +(global-set-key [vertical-line down-mouse-1] #'mouse-drag-vertical-line) +(global-set-key [vertical-line mouse-1] #'mouse-select-window) +(global-set-key [vertical-line C-mouse-2] #'mouse-split-window-vertically) +(global-set-key [right-divider down-mouse-1] #'mouse-drag-vertical-line) +(global-set-key [right-divider mouse-1] #'ignore) +(global-set-key [right-divider C-mouse-2] #'mouse-split-window-vertically) +(global-set-key [bottom-divider down-mouse-1] #'mouse-drag-mode-line) +(global-set-key [bottom-divider mouse-1] #'ignore) +(global-set-key [bottom-divider C-mouse-2] #'mouse-split-window-horizontally) +(global-set-key [left-edge down-mouse-1] #'mouse-drag-left-edge) +(global-set-key [left-edge mouse-1] #'ignore) +(global-set-key [top-left-corner down-mouse-1] #'mouse-drag-top-left-corner) +(global-set-key [top-left-corner mouse-1] #'ignore) +(global-set-key [top-edge down-mouse-1] #'mouse-drag-top-edge) +(global-set-key [top-edge mouse-1] #'ignore) +(global-set-key [top-right-corner down-mouse-1] #'mouse-drag-top-right-corner) +(global-set-key [top-right-corner mouse-1] #'ignore) +(global-set-key [right-edge down-mouse-1] #'mouse-drag-right-edge) +(global-set-key [right-edge mouse-1] #'ignore) +(global-set-key [bottom-right-corner down-mouse-1] #'mouse-drag-bottom-right-corner) +(global-set-key [bottom-right-corner mouse-1] #'ignore) +(global-set-key [bottom-edge down-mouse-1] #'mouse-drag-bottom-edge) +(global-set-key [bottom-edge mouse-1] #'ignore) +(global-set-key [bottom-left-corner down-mouse-1] #'mouse-drag-bottom-left-corner) +(global-set-key [bottom-left-corner mouse-1] #'ignore) (provide 'mouse) diff --git a/lisp/mwheel.el b/lisp/mwheel.el index 51410e3ef4c..9d303b7ee35 100644 --- a/lisp/mwheel.el +++ b/lisp/mwheel.el @@ -55,7 +55,8 @@ (mouse-wheel-mode 1))) (defcustom mouse-wheel-down-event - (if (or (featurep 'w32-win) (featurep 'ns-win)) + (if (or (featurep 'w32-win) (featurep 'ns-win) + (featurep 'haiku-win)) 'wheel-up 'mouse-4) "Event used for scrolling down." @@ -63,8 +64,20 @@ :type 'symbol :set 'mouse-wheel-change-button) +(defcustom mouse-wheel-down-alternate-event + (if (featurep 'xinput2) + 'wheel-up + (unless (featurep 'x) + 'mouse-4)) + "Alternative wheel down event to consider." + :group 'mouse + :type 'symbol + :version "29.1" + :set 'mouse-wheel-change-button) + (defcustom mouse-wheel-up-event - (if (or (featurep 'w32-win) (featurep 'ns-win)) + (if (or (featurep 'w32-win) (featurep 'ns-win) + (featurep 'haiku-win)) 'wheel-down 'mouse-5) "Event used for scrolling up." @@ -72,6 +85,17 @@ :type 'symbol :set 'mouse-wheel-change-button) +(defcustom mouse-wheel-up-alternate-event + (if (featurep 'xinput2) + 'wheel-down + (unless (featurep 'x) + 'mouse-5)) + "Alternative wheel up event to consider." + :group 'mouse + :type 'symbol + :version "29.1" + :set 'mouse-wheel-change-button) + (defcustom mouse-wheel-click-event 'mouse-2 "Event that should be temporarily inhibited after mouse scrolling. The mouse wheel is typically on the mouse-2 button, so it may easily @@ -221,17 +245,33 @@ Also see `mouse-wheel-tilt-scroll'." "Function that does the job of scrolling right.") (defvar mouse-wheel-left-event - (if (or (featurep 'w32-win) (featurep 'ns-win)) + (if (or (featurep 'w32-win) (featurep 'ns-win) + (featurep 'haiku-win)) 'wheel-left 'mouse-6) "Event used for scrolling left.") +(defvar mouse-wheel-left-alternate-event + (if (featurep 'xinput2) + 'wheel-left + (unless (featurep 'x) + 'mouse-6)) + "Alternative wheel left event to consider.") + (defvar mouse-wheel-right-event - (if (or (featurep 'w32-win) (featurep 'ns-win)) + (if (or (featurep 'w32-win) (featurep 'ns-win) + (featurep 'haiku-win)) 'wheel-right 'mouse-7) "Event used for scrolling right.") +(defvar mouse-wheel-right-alternate-event + (if (featurep 'xinput2) + 'wheel-right + (unless (featurep 'x) + 'mouse-7)) + "Alternative wheel right event to consider.") + (defun mouse-wheel--get-scroll-window (event) "Return window for mouse wheel event EVENT. If `mouse-wheel-follow-mouse' is non-nil, return the window that @@ -296,14 +336,16 @@ value of ARG, and the command uses it in subsequent scrolls." (condition-case nil (unwind-protect (let ((button (mwheel-event-button event))) - (cond ((and (eq amt 'hscroll) (eq button mouse-wheel-down-event)) + (cond ((and (eq amt 'hscroll) (memq button (list mouse-wheel-down-event + mouse-wheel-down-alternate-event))) (when (and (natnump arg) (> arg 0)) (setq mouse-wheel-scroll-amount-horizontal arg)) (funcall (if mouse-wheel-flip-direction mwheel-scroll-left-function mwheel-scroll-right-function) mouse-wheel-scroll-amount-horizontal)) - ((eq button mouse-wheel-down-event) + ((memq button (list mouse-wheel-down-event + mouse-wheel-down-alternate-event)) (condition-case nil (funcall mwheel-scroll-down-function amt) ;; Make sure we do indeed scroll to the beginning of ;; the buffer. @@ -318,23 +360,27 @@ value of ARG, and the command uses it in subsequent scrolls." ;; for a reason that escapes me. This problem seems ;; to only affect scroll-down. --Stef (set-window-start (selected-window) (point-min)))))) - ((and (eq amt 'hscroll) (eq button mouse-wheel-up-event)) + ((and (eq amt 'hscroll) (memq button (list mouse-wheel-up-event + mouse-wheel-up-alternate-event))) (when (and (natnump arg) (> arg 0)) (setq mouse-wheel-scroll-amount-horizontal arg)) (funcall (if mouse-wheel-flip-direction mwheel-scroll-right-function mwheel-scroll-left-function) mouse-wheel-scroll-amount-horizontal)) - ((eq button mouse-wheel-up-event) + ((memq button (list mouse-wheel-up-event + mouse-wheel-up-alternate-event)) (condition-case nil (funcall mwheel-scroll-up-function amt) ;; Make sure we do indeed scroll to the end of the buffer. (end-of-buffer (while t (funcall mwheel-scroll-up-function))))) - ((eq button mouse-wheel-left-event) ; for tilt scroll + ((memq button (list mouse-wheel-left-event + mouse-wheel-left-alternate-event)) ; for tilt scroll (when mouse-wheel-tilt-scroll (funcall (if mouse-wheel-flip-direction mwheel-scroll-right-function mwheel-scroll-left-function) amt))) - ((eq button mouse-wheel-right-event) ; for tilt scroll + ((memq button (list mouse-wheel-right-event + mouse-wheel-right-alternate-event)) ; for tilt scroll (when mouse-wheel-tilt-scroll (funcall (if mouse-wheel-flip-direction mwheel-scroll-left-function @@ -378,9 +424,11 @@ value of ARG, and the command uses it in subsequent scrolls." (button (mwheel-event-button event))) (select-window scroll-window 'mark-for-redisplay) (unwind-protect - (cond ((eq button mouse-wheel-down-event) + (cond ((memq button (list mouse-wheel-down-event + mouse-wheel-down-alternate-event)) (text-scale-increase 1)) - ((eq button mouse-wheel-up-event) + ((memq button (list mouse-wheel-up-event + mouse-wheel-up-alternate-event)) (text-scale-decrease 1))) (select-window selected-window)))) @@ -432,15 +480,23 @@ an event used for scrolling, such as `mouse-wheel-down-event'." (cond ;; Bindings for changing font size. ((and (consp binding) (eq (cdr binding) 'text-scale)) - (dolist (event (list mouse-wheel-down-event mouse-wheel-up-event)) - (mouse-wheel--add-binding `[,(list (caar binding) event)] - 'mouse-wheel-text-scale))) + (dolist (event (list mouse-wheel-down-event mouse-wheel-up-event + mouse-wheel-down-alternate-event + mouse-wheel-up-alternate-event)) + (when event + (mouse-wheel--add-binding `[,(list (caar binding) event)] + 'mouse-wheel-text-scale)))) ;; Bindings for scrolling. (t (dolist (event (list mouse-wheel-down-event mouse-wheel-up-event - mouse-wheel-left-event mouse-wheel-right-event)) - (dolist (key (mouse-wheel--create-scroll-keys binding event)) - (mouse-wheel--add-binding key 'mwheel-scroll))))))) + mouse-wheel-left-event mouse-wheel-right-event + mouse-wheel-down-alternate-event + mouse-wheel-up-alternate-event + mouse-wheel-left-alternate-event + mouse-wheel-right-alternate-event)) + (when event + (dolist (key (mouse-wheel--create-scroll-keys binding event)) + (mouse-wheel--add-binding key 'mwheel-scroll)))))))) (when mouse-wheel-mode (mouse-wheel--setup-bindings)) diff --git a/lisp/net/ange-ftp.el b/lisp/net/ange-ftp.el index 2585833e1d4..a6c256eeba8 100644 --- a/lisp/net/ange-ftp.el +++ b/lisp/net/ange-ftp.el @@ -1230,8 +1230,9 @@ only return the directory part of FILE." ;; found another machine with the same user. ;; Try that account. (read-passwd - (format "passwd for %s@%s (default same as %s@%s): " - user host user other) + (format-prompt "passwd for %s@%s" + (format "same as %s@%s" user other) + user host) nil (ange-ftp-lookup-passwd other user)) diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index 4ae56864c55..2be9c7c025c 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -39,6 +39,7 @@ ;; browse-url-chrome Chrome 47.0.2526.111 ;; browse-url-chromium Chromium 3.0 ;; browse-url-epiphany GNOME Web (Epiphany) Don't know +;; browse-url-webpositive WebPositive 1.2-alpha (Haiku R1/beta3) ;; browse-url-w3 w3 0 ;; browse-url-text-* Any text browser 0 ;; browse-url-generic arbitrary @@ -156,6 +157,7 @@ (function-item :tag "Google Chrome" :value browse-url-chrome) (function-item :tag "Chromium" :value browse-url-chromium) (function-item :tag "GNOME Web (Epiphany)" :value browse-url-epiphany) + (function-item :tag "WebPositive" :value browse-url-webpositive) (function-item :tag "Text browser in an xterm window" :value browse-url-text-xterm) (function-item :tag "Text browser in an Emacs window" @@ -219,7 +221,7 @@ be used instead." (defcustom browse-url-button-regexp (concat - "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|" + "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|gemini\\|" "nntp\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)" "\\(//[-a-z0-9_.]+:[0-9]*\\)?" (let ((chars "-a-z0-9_=#$@~%&*+\\/[:word:]") @@ -238,33 +240,6 @@ be used instead." :version "27.1" :type 'regexp) -(defcustom browse-url-netscape-program "netscape" - ;; Info about netscape-remote from Karl Berry. - "The name by which to invoke Netscape. - -The free program `netscape-remote' from -<URL:http://home.netscape.com/newsref/std/remote.c> is said to start -up very much quicker than `netscape'. Reported to compile on a GNU -system, given vroot.h from the same directory, with cc flags - -DSTANDALONE -L/usr/X11R6/lib -lXmu -lX11." - :type 'string) - -(make-obsolete-variable 'browse-url-netscape-program nil "25.1") - -(defcustom browse-url-netscape-arguments nil - "A list of strings to pass to Netscape as arguments." - :type '(repeat (string :tag "Argument"))) - -(make-obsolete-variable 'browse-url-netscape-arguments nil "25.1") - -(defcustom browse-url-netscape-startup-arguments browse-url-netscape-arguments - "A list of strings to pass to Netscape when it starts up. -Defaults to the value of `browse-url-netscape-arguments' at the time -`browse-url' is loaded." - :type '(repeat (string :tag "Argument"))) - -(make-obsolete-variable 'browse-url-netscape-startup-arguments nil "25.1") - (defcustom browse-url-browser-display nil "The X display for running the browser, if not same as Emacs's." :type '(choice string (const :tag "Default" nil))) @@ -283,11 +258,13 @@ Defaults to the value of `browse-url-mozilla-arguments' at the time `browse-url' is loaded." :type '(repeat (string :tag "Argument"))) +(defun browse-url--find-executable (candidates default) + (while (and candidates (not (executable-find (car candidates)))) + (setq candidates (cdr candidates))) + (or (car candidates) default)) + (defcustom browse-url-firefox-program - (let ((candidates '("icecat" "iceweasel" "firefox"))) - (while (and candidates (not (executable-find (car candidates)))) - (setq candidates (cdr candidates))) - (or (car candidates) "firefox")) + (browse-url--find-executable '("icecat" "iceweasel") "firefox") "The name by which to invoke Firefox or a variant of it." :type 'string) @@ -305,10 +282,8 @@ Defaults to the value of `browse-url-firefox-arguments' at the time "it no longer has any effect." "24.5") (defcustom browse-url-chrome-program - (let ((candidates '("google-chrome-stable" "google-chrome"))) - (while (and candidates (not (executable-find (car candidates)))) - (setq candidates (cdr candidates))) - (or (car candidates) "chromium")) + (browse-url--find-executable '("google-chrome-stable" "google-chrome") + "chromium") "The name by which to invoke the Chrome browser." :type 'string :version "25.1") @@ -319,10 +294,7 @@ Defaults to the value of `browse-url-firefox-arguments' at the time :version "25.1") (defcustom browse-url-chromium-program - (let ((candidates '("chromium" "chromium-browser"))) - (while (and candidates (not (executable-find (car candidates)))) - (setq candidates (cdr candidates))) - (or (car candidates) "chromium")) + (browse-url--find-executable '("chromium" "chromium-browser") "chromium") "The name by which to invoke Chromium." :type 'string :version "24.1") @@ -332,26 +304,6 @@ Defaults to the value of `browse-url-firefox-arguments' at the time :type '(repeat (string :tag "Argument")) :version "24.1") -(defcustom browse-url-galeon-program "galeon" - "The name by which to invoke Galeon." - :type 'string) - -(make-obsolete-variable 'browse-url-galeon-program nil "25.1") - -(defcustom browse-url-galeon-arguments nil - "A list of strings to pass to Galeon as arguments." - :type '(repeat (string :tag "Argument"))) - -(make-obsolete-variable 'browse-url-galeon-arguments nil "25.1") - -(defcustom browse-url-galeon-startup-arguments browse-url-galeon-arguments - "A list of strings to pass to Galeon when it starts up. -Defaults to the value of `browse-url-galeon-arguments' at the time -`browse-url' is loaded." - :type '(repeat (string :tag "Argument"))) - -(make-obsolete-variable 'browse-url-galeon-startup-arguments nil "25.1") - (defcustom browse-url-epiphany-program "epiphany" "The name by which to invoke GNOME Web (Epiphany)." :type 'string) @@ -366,7 +318,12 @@ Defaults to the value of `browse-url-epiphany-arguments' at the time `browse-url' is loaded." :type '(repeat (string :tag "Argument"))) -;; GNOME means of invoking either Mozilla or Netscape. +(defcustom browse-url-webpositive-program "WebPositive" + "The name by which to invoke WebPositive." + :type 'string + :version "29.1") + +;; GNOME means of invoking Mozilla. (defvar browse-url-gnome-moz-program "gnome-moz-remote") (make-obsolete-variable 'browse-url-gnome-moz-program nil "25.1") @@ -399,29 +356,12 @@ If non-nil, then open the URL in a new buffer rather than a new window if (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 -`browse-url-galeon' is asked to open it in a new window." - :type 'boolean) - -(make-obsolete-variable 'browse-url-galeon-new-window-is-tab nil "25.1") - (defcustom browse-url-epiphany-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 `browse-url-epiphany' is asked to open it in a new window." :type 'boolean) -(defcustom browse-url-netscape-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 `browse-url-netscape' is asked to open it in a new -window." - :type 'boolean) - -(make-obsolete-variable 'browse-url-netscape-new-window-is-tab nil "25.1") - (defcustom browse-url-new-window-flag nil "Non-nil means always open a new browser window with appropriate browsers. Passing an interactive argument to \\[browse-url], or specific browser @@ -518,14 +458,6 @@ You might want to set this to somewhere with restricted read permissions for privacy's sake." :type 'string) -(defcustom browse-url-netscape-version 3 - "The version of Netscape you are using. -This affects how URL reloading is done; the mechanism changed -incompatibly at version 4." - :type 'number) - -(make-obsolete-variable 'browse-url-netscape-version nil "25.1") - (defcustom browse-url-text-browser "lynx" "The name of the text browser to invoke." :type 'string @@ -730,8 +662,7 @@ position clicked before acting. This function returns a list (URL NEW-WINDOW-FLAG) for use in `interactive'." (let ((event (elt (this-command-keys) 0))) - (when (mouse-event-p event) - (mouse-set-point event))) + (mouse-set-point event)) (list (read-string prompt (or (and transient-mark-mode mark-active ;; rfc2396 Appendix E. (replace-regexp-in-string @@ -1003,8 +934,6 @@ The optional NEW-WINDOW argument is not used." (function-put 'browse-url-default-macosx-browser 'browse-url-browser-kind 'external) -;; --- Netscape --- - (defun browse-url-process-environment () "Set DISPLAY in the environment to the X display the browser will use. This is either the value of variable `browse-url-browser-display' if @@ -1047,10 +976,9 @@ instead of `browse-url-new-window-flag'." ((executable-find browse-url-mozilla-program) 'browse-url-mozilla) ((executable-find browse-url-firefox-program) 'browse-url-firefox) ((executable-find browse-url-chromium-program) 'browse-url-chromium) -;;; ((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-chrome-program) 'browse-url-chrome) + ((executable-find browse-url-webpositive-program) 'browse-url-webpositive) ((executable-find browse-url-xterm-program) 'browse-url-text-xterm) ((locate-library "w3") 'browse-url-w3) (t @@ -1083,82 +1011,6 @@ The optional argument IGNORED is not used." (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. -Default to the URL around or before point. The strings in variable -`browse-url-netscape-arguments' are also passed to Netscape. - -When called interactively, if variable `browse-url-new-window-flag' is -non-nil, load the document in a new Netscape window, otherwise use a -random existing one. A non-nil interactive prefix argument reverses -the effect of `browse-url-new-window-flag'. - -If `browse-url-netscape-new-window-is-tab' is non-nil, then -whenever a document would otherwise be loaded in a new window, it -is loaded in a new tab in an existing window instead. - -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 "URL: ")) - (setq url (browse-url-encode-url url)) - (let* ((process-environment (browse-url-process-environment)) - (process - (apply #'start-process - (concat "netscape " url) nil - browse-url-netscape-program - (append - browse-url-netscape-arguments - (if (eq window-system 'w32) - (list url) - (append - (if new-window '("-noraise")) - (list "-remote" - (concat "openURL(" url - (if (browse-url-maybe-new-window - new-window) - (if browse-url-netscape-new-window-is-tab - ",new-tab" - ",new-window")) - ")")))))))) - (set-process-sentinel process - (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")) - (or (eq (process-exit-status process) 0) - (let* ((process-environment (browse-url-process-environment))) - ;; Netscape not running - start it - (message "Starting %s..." browse-url-netscape-program) - (apply #'start-process (concat "netscape" url) nil - browse-url-netscape-program - (append browse-url-netscape-startup-arguments (list url)))))) - -(defun browse-url-netscape-reload () - "Ask Netscape to reload its current document. -How depends on `browse-url-netscape-version'." - (declare (obsolete nil "25.1")) - (interactive) - ;; Backwards incompatibility reported by - ;; <peter.kruse@psychologie.uni-regensburg.de>. - (browse-url-netscape-send (if (>= browse-url-netscape-version 4) - "xfeDoCommand(reload)" - "reload"))) - -(defun browse-url-netscape-send (command) - "Send a remote control command to Netscape." - (declare (obsolete nil "25.1")) - (let* ((process-environment (browse-url-process-environment))) - (apply #'start-process "netscape" nil - browse-url-netscape-program - (append browse-url-netscape-arguments - (list "-remote" command))))) - -;;;###autoload (defun browse-url-mozilla (url &optional new-window) "Ask the Mozilla WWW browser to load URL. Default to the URL around or before point. The strings in variable @@ -1278,56 +1130,6 @@ The optional argument NEW-WINDOW is not used." (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. -Default to the URL around or before point. The strings in variable -`browse-url-galeon-arguments' are also passed to Galeon. - -When called interactively, if variable `browse-url-new-window-flag' is -non-nil, load the document in a new Galeon window, otherwise use a -random existing one. A non-nil interactive prefix argument reverses -the effect of `browse-url-new-window-flag'. - -If `browse-url-galeon-new-window-is-tab' is non-nil, then whenever a -document would otherwise be loaded in a new window, it is loaded in a -new tab in an existing window instead. - -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 "URL: ")) - (setq url (browse-url-encode-url url)) - (let* ((process-environment (browse-url-process-environment)) - (process (apply #'start-process - (concat "galeon " url) - nil - browse-url-galeon-program - (append - browse-url-galeon-arguments - (if (browse-url-maybe-new-window new-window) - (if browse-url-galeon-new-window-is-tab - '("--new-tab") - '("--new-window" "--noraise")) - '("--existing")) - (list url))))) - (set-process-sentinel process - (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")) - (or (eq (process-exit-status process) 0) - (let* ((process-environment (browse-url-process-environment))) - ;; Galeon is not running - start it - (message "Starting %s..." browse-url-galeon-program) - (apply #'start-process (concat "galeon " url) nil - browse-url-galeon-program - (append browse-url-galeon-startup-arguments (list url)))))) - (defun browse-url-epiphany (url &optional new-window) "Ask the GNOME Web (Epiphany) WWW browser to load URL. Default to the URL around or before point. The strings in variable @@ -1378,6 +1180,18 @@ used instead of `browse-url-new-window-flag'." (defvar url-handler-regexp) ;;;###autoload +(defun browse-url-webpositive (url &optional _new-window) + "Ask the WebPositive WWW browser to load URL. +Default to the URL around or before point. +The optional argument NEW-WINDOW is not used." + (interactive (browse-url-interactive-arg "URL: ")) + (setq url (browse-url-encode-url url)) + (let* ((process-environment (browse-url-process-environment))) + (start-process (concat "WebPositive " url) nil "WebPositive" url))) + +(function-put 'browse-url-webpositive 'browse-url-browser-kind 'external) + +;;;###autoload (defun browse-url-emacs (url &optional same-window) "Ask Emacs to load URL into a buffer and show it in another window. Optional argument SAME-WINDOW non-nil means show the URL in the @@ -1399,7 +1213,7 @@ currently selected window instead." ;;;###autoload (defun browse-url-gnome-moz (url &optional new-window) - "Ask Mozilla/Netscape to load URL via the GNOME program `gnome-moz-remote'. + "Ask Mozilla to load URL via the GNOME program `gnome-moz-remote'. Default to the URL around or before point. The strings in variable `browse-url-gnome-moz-arguments' are also passed. diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index 560ece67517..411249767f5 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -2102,7 +2102,7 @@ has been handled by this function." (interface (dbus-event-interface-name event)) (member (dbus-event-member-name event)) (arguments (dbus-event-arguments event)) - (time (time-to-seconds (current-time)))) + (time (float-time))) (save-excursion ;; Check for matching method-call. (goto-char (point-max)) @@ -2252,15 +2252,19 @@ keywords `:system-private' or `:session-private', respectively." bus nil dbus-path-local dbus-interface-local "Disconnected" #'dbus-handle-bus-disconnect))) - -;; Initialize `:system' and `:session' buses. This adds their file -;; descriptors to input_wait_mask, in order to detect incoming -;; messages immediately. -(when (featurep 'dbusbind) - (dbus-ignore-errors - (dbus-init-bus :system)) - (dbus-ignore-errors - (dbus-init-bus :session))) + +(defun dbus--init () + ;; Initialize `:system' and `:session' buses. This adds their file + ;; descriptors to input_wait_mask, in order to detect incoming + ;; messages immediately. + (when (featurep 'dbusbind) + (dbus-ignore-errors + (dbus-init-bus :system)) + (dbus-ignore-errors + (dbus-init-bus :session)))) + +(add-hook 'after-pdump-load-hook #'dbus--init) +(dbus--init) (provide 'dbus) diff --git a/lisp/net/eudc.el b/lisp/net/eudc.el index 14e5c28b2dc..62c2913b50a 100644 --- a/lisp/net/eudc.el +++ b/lisp/net/eudc.el @@ -46,16 +46,9 @@ ;;; Code: (require 'wid-edit) - (require 'cl-lib) - -(unless (fboundp 'custom-menu-create) - (autoload 'custom-menu-create "cus-edit")) - (require 'eudc-vars) - - ;;{{{ Internal cooking ;;{{{ Internal variables and compatibility tricks diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 238900db0c3..e86d21f889c 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -178,6 +178,40 @@ the tab bar is enabled." :group 'eww :type 'hook) +(defcustom eww-auto-rename-buffer nil + "Automatically rename EWW buffers once the page is rendered. + +When nil, do not rename the buffer. With a non-nil value +determine the renaming scheme, as follows: + +- `title': Use the web page's title. +- `url': Use the web page's URL. +- a function's symbol: Run a user-defined function that returns a + string with which to rename the buffer. Sample of a + user-defined function: + + (defun my-eww-rename-buffer () + (when (eq major-mode 'eww-mode) + (when-let ((string (or (plist-get eww-data :title) + (plist-get eww-data :url)))) + (format \"*%s*\" string)))) + +The string of `title' and `url' is always truncated to the value +of `eww-buffer-name-length'." + :version "29.1" + :type '(choice + (const :tag "Do not rename buffers (default)" nil) + (const :tag "Rename buffer to web page title" title) + (const :tag "Rename buffer to web page URL" url) + (function :tag "A user-defined function to rename the buffer")) + :group 'eww) + +(defcustom eww-buffer-name-length 40 + "Length of renamed buffer name, per `eww-auto-rename-buffer'." + :type 'natnum + :version "29.1" + :group 'eww) + (defcustom eww-form-checkbox-selected-symbol "[X]" "Symbol used to represent a selected checkbox. See also `eww-form-checkbox-symbol'." @@ -197,8 +231,15 @@ See also `eww-form-checkbox-selected-symbol'." (const "☐") ; Unicode BALLOT BOX string)) +(defcustom eww-url-transformers '(eww-remove-tracking) + "This is a list of transforming functions applied to an URL before usage. +The functions will be called with the URL as the single +parameter, and should return the (possibly) transformed URL." + :type '(repeat function) + :version "29.1") + (defface eww-form-submit - '((((type x w32 ns) (class color)) ; Like default mode line + '((((type x w32 ns haiku) (class color)) ; Like default mode line :box (:line-width 2 :style released-button) :background "#808080" :foreground "black")) "Face for eww buffer buttons." @@ -206,7 +247,7 @@ See also `eww-form-checkbox-selected-symbol'." :group 'eww) (defface eww-form-file - '((((type x w32 ns) (class color)) ; Like default mode line + '((((type x w32 ns haiku) (class color)) ; Like default mode line :box (:line-width 2 :style released-button) :background "#808080" :foreground "black")) "Face for eww buffer buttons." @@ -214,7 +255,7 @@ See also `eww-form-checkbox-selected-symbol'." :group 'eww) (defface eww-form-checkbox - '((((type x w32 ns) (class color)) ; Like default mode line + '((((type x w32 ns haiku) (class color)) ; Like default mode line :box (:line-width 2 :style released-button) :background "lightgrey" :foreground "black")) "Face for eww buffer buttons." @@ -222,7 +263,7 @@ See also `eww-form-checkbox-selected-symbol'." :group 'eww) (defface eww-form-select - '((((type x w32 ns) (class color)) ; Like default mode line + '((((type x w32 ns haiku) (class color)) ; Like default mode line :box (:line-width 2 :style released-button) :background "lightgrey" :foreground "black")) "Face for eww buffer buttons." @@ -271,15 +312,13 @@ See also `eww-form-checkbox-selected-symbol'." "text/html, text/plain, text/sgml, text/css, application/xhtml+xml, */*;q=0.01" "Value used for the HTTP 'Accept' header.") -(defvar eww-link-keymap - (let ((map (copy-keymap shr-map))) - (define-key map "\r" 'eww-follow-link) - map)) +(defvar-keymap eww-link-keymap + :parent shr-map + "RET" #'eww-follow-link) -(defvar eww-image-link-keymap - (let ((map (copy-keymap shr-image-map))) - (define-key map "\r" 'eww-follow-link) - map)) +(defvar-keymap eww-image-link-keymap + :parent shr-map + "RET" #'eww-follow-link) (defun eww-suggested-uris nil "Return the list of URIs to suggest at the `eww' prompt. @@ -313,13 +352,13 @@ will start Emacs and browse the GNU web site." ;;;###autoload -(defun eww (url &optional arg buffer) +(defun eww (url &optional new-buffer 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. +If NEW-BUFFER is non-nil (interactively, the prefix arg), use a +new buffer instead of reusing 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 @@ -329,11 +368,11 @@ killed after rendering." (list (read-string (format-prompt "Enter URL or keywords" (and uris (car uris))) nil 'eww-prompt-history uris) - (prefix-numeric-value current-prefix-arg)))) + current-prefix-arg))) (setq url (eww--dwim-expand-url url)) (pop-to-buffer-same-window (cond - ((eq arg 4) + (new-buffer (generate-new-buffer "*eww*")) ((eq major-mode 'eww-mode) (current-buffer)) @@ -353,9 +392,10 @@ killed after rendering." (while (string-match "\\`/[.][.]/" (url-filename parsed)) (setf (url-filename parsed) (substring (url-filename parsed) 3)))) (setq url (url-recreate-url parsed))) + (setq url (eww--transform-url url)) (plist-put eww-data :url url) (plist-put eww-data :title "") - (eww-update-header-line-format) + (eww--after-page-change) (let ((inhibit-read-only t)) (insert (format "Loading %s..." url)) (goto-char (point-min))) @@ -504,6 +544,30 @@ Currently this means either text/html or application/xhtml+xml." (member content-type '("text/html" "application/xhtml+xml"))) +(defun eww--rename-buffer () + "Rename the current EWW buffer. +The renaming scheme is performed in accordance with +`eww-auto-rename-buffer'." + (let ((rename-string) + (formatter + (lambda (string) + (format "*%s # eww*" (truncate-string-to-width + string eww-buffer-name-length)))) + (site-title (plist-get eww-data :title)) + (site-url (plist-get eww-data :url))) + (cond ((null eww-auto-rename-buffer)) + ((eq eww-auto-rename-buffer 'url) + (setq rename-string (funcall formatter site-url))) + ((functionp eww-auto-rename-buffer) + (setq rename-string (funcall eww-auto-rename-buffer))) + (t (setq rename-string + (funcall formatter (if (or (equal site-title "") + (null site-title)) + "Untitled" + site-title))))) + (when rename-string + (rename-buffer rename-string t)))) + (defun eww-render (status url &optional point buffer encode) (let* ((headers (eww-parse-headers)) (content-type @@ -554,7 +618,7 @@ Currently this means either text/html or application/xhtml+xml." (eww-display-raw buffer (or encode charset 'utf-8)))) (with-current-buffer buffer (plist-put eww-data :url url) - (eww-update-header-line-format) + (eww--after-page-change) (setq eww-history-position 0) (and last-coding-system-used (set-buffer-file-coding-system last-coding-system-used)) @@ -638,7 +702,8 @@ Currently this means either text/html or application/xhtml+xml." (meta . eww-tag-meta) (a . eww-tag-a))))) (erase-buffer) - (shr-insert-document document) + (with-delayed-message (2 "Rendering HTML...") + (shr-insert-document document)) (cond (point (goto-char point)) @@ -798,12 +863,16 @@ Currently this means either text/html or application/xhtml+xml." `((?u . ,(or url "")) (?t . ,title)))))))) +(defun eww--after-page-change () + (eww-update-header-line-format) + (eww--rename-buffer)) + (defun eww-tag-title (dom) (plist-put eww-data :title (replace-regexp-in-string "^ \\| $" "" (replace-regexp-in-string "[ \t\r\n]+" " " (dom-text dom)))) - (eww-update-header-line-format)) + (eww--after-page-change)) (defun eww-display-raw (buffer &optional encode) (let ((data (buffer-substring (point) (point-max)))) @@ -931,7 +1000,7 @@ the like." nil (current-buffer)) (dolist (elem '(:source :url :title :next :previous :up)) (plist-put eww-data elem (plist-get old-data elem))) - (eww-update-header-line-format))) + (eww--after-page-change))) (defun eww-score-readability (node) (let ((score -1)) @@ -973,67 +1042,67 @@ the like." (setq result highest)))) result)) -(defvar eww-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "g" 'eww-reload) ;FIXME: revert-buffer-function instead! - (define-key map "G" 'eww) - (define-key map [?\M-\r] 'eww-open-in-new-buffer) - (define-key map [?\t] 'shr-next-link) - (define-key map [?\M-\t] 'shr-previous-link) - (define-key map [backtab] 'shr-previous-link) - (define-key map [delete] 'scroll-down-command) - (define-key map "l" 'eww-back-url) - (define-key map "r" 'eww-forward-url) - (define-key map "n" 'eww-next-url) - (define-key map "p" 'eww-previous-url) - (define-key map "u" 'eww-up-url) - (define-key map "t" 'eww-top-url) - (define-key map "&" 'eww-browse-with-external-browser) - (define-key map "d" 'eww-download) - (define-key map "w" 'eww-copy-page-url) - (define-key map "C" 'url-cookie-list) - (define-key map "v" 'eww-view-source) - (define-key map "R" 'eww-readable) - (define-key map "H" 'eww-list-histories) - (define-key map "E" 'eww-set-character-encoding) - (define-key map "s" 'eww-switch-to-buffer) - (define-key map "S" 'eww-list-buffers) - (define-key map "F" 'eww-toggle-fonts) - (define-key map "D" 'eww-toggle-paragraph-direction) - (define-key map [(meta C)] 'eww-toggle-colors) - (define-key map [(meta I)] 'eww-toggle-images) - - (define-key map "b" 'eww-add-bookmark) - (define-key map "B" 'eww-list-bookmarks) - (define-key map [(meta n)] 'eww-next-bookmark) - (define-key map [(meta p)] 'eww-previous-bookmark) - - (easy-menu-define nil map "" - '("Eww" - ["Exit" quit-window t] - ["Close browser" quit-window t] - ["Reload" eww-reload t] - ["Follow URL in new buffer" eww-open-in-new-buffer] - ["Back to previous page" eww-back-url - :active (not (zerop (length eww-history)))] - ["Forward to next page" eww-forward-url - :active (not (zerop eww-history-position))] - ["Browse with external browser" eww-browse-with-external-browser t] - ["Download" eww-download t] - ["View page source" eww-view-source] - ["Copy page URL" eww-copy-page-url t] - ["List histories" eww-list-histories t] - ["Switch to buffer" eww-switch-to-buffer t] - ["List buffers" eww-list-buffers t] - ["Add bookmark" eww-add-bookmark t] - ["List bookmarks" eww-list-bookmarks t] - ["List cookies" url-cookie-list t] - ["Toggle fonts" eww-toggle-fonts t] - ["Toggle colors" eww-toggle-colors t] - ["Toggle images" eww-toggle-images t] - ["Character Encoding" eww-set-character-encoding] - ["Toggle Paragraph Direction" eww-toggle-paragraph-direction])) - map)) +(defvar-keymap eww-mode-map + "g" #'eww-reload ;FIXME: revert-buffer-function instead! + "G" #'eww + "M-RET" #'eww-open-in-new-buffer + "TAB" #'shr-next-link + "C-M-i" #'shr-previous-link + "<backtab>" #'shr-previous-link + "<delete>" #'scroll-down-command + "l" #'eww-back-url + "r" #'eww-forward-url + "n" #'eww-next-url + "p" #'eww-previous-url + "u" #'eww-up-url + "t" #'eww-top-url + "&" #'eww-browse-with-external-browser + "d" #'eww-download + "w" #'eww-copy-page-url + "C" #'url-cookie-list + "v" #'eww-view-source + "R" #'eww-readable + "H" #'eww-list-histories + "E" #'eww-set-character-encoding + "s" #'eww-switch-to-buffer + "S" #'eww-list-buffers + "F" #'eww-toggle-fonts + "D" #'eww-toggle-paragraph-direction + "M-C" #'eww-toggle-colors + "M-I" #'eww-toggle-images + + "b" #'eww-add-bookmark + "B" #'eww-list-bookmarks + "M-n" #'eww-next-bookmark + "M-p" #'eww-previous-bookmark + + "<mouse-8>" #'eww-back-url + "<mouse-9>" #'eww-forward-url + + :menu '("Eww" + ["Exit" quit-window t] + ["Close browser" quit-window t] + ["Reload" eww-reload t] + ["Follow URL in new buffer" eww-open-in-new-buffer] + ["Back to previous page" eww-back-url + :active (not (zerop (length eww-history)))] + ["Forward to next page" eww-forward-url + :active (not (zerop eww-history-position))] + ["Browse with external browser" eww-browse-with-external-browser t] + ["Download" eww-download t] + ["View page source" eww-view-source] + ["Copy page URL" eww-copy-page-url t] + ["List histories" eww-list-histories t] + ["Switch to buffer" eww-switch-to-buffer t] + ["List buffers" eww-list-buffers t] + ["Add bookmark" eww-add-bookmark t] + ["List bookmarks" eww-list-bookmarks t] + ["List cookies" url-cookie-list t] + ["Toggle fonts" eww-toggle-fonts t] + ["Toggle colors" eww-toggle-colors t] + ["Toggle images" eww-toggle-images t] + ["Character Encoding" eww-set-character-encoding] + ["Toggle Paragraph Direction" eww-toggle-paragraph-direction])) (defun eww-context-menu (menu click) "Populate MENU with eww commands at CLICK." @@ -1166,7 +1235,7 @@ instead of `browse-url-new-window-flag'." (goto-char (plist-get elem :point)) ;; Make buffer listings more informative. (setq list-buffers-directory (plist-get elem :url)) - (eww-update-header-line-format)))) + (eww--after-page-change)))) (defun eww-next-url () "Go to the page marked `next'. @@ -1230,54 +1299,43 @@ just re-display the HTML already fetched." (defvar eww-form nil) -(defvar eww-submit-map - (let ((map (make-sparse-keymap))) - (define-key map "\r" 'eww-submit) - (define-key map [(control c) (control c)] 'eww-submit) - map)) - -(defvar eww-submit-file - (let ((map (make-sparse-keymap))) - (define-key map "\r" 'eww-select-file) - (define-key map [(control c) (control c)] 'eww-submit) - map)) - -(defvar eww-checkbox-map - (let ((map (make-sparse-keymap))) - (define-key map " " 'eww-toggle-checkbox) - (define-key map "\r" 'eww-toggle-checkbox) - (define-key map [(control c) (control c)] 'eww-submit) - map)) - -(defvar eww-text-map - (let ((map (make-keymap))) - (set-keymap-parent map text-mode-map) - (define-key map "\r" 'eww-submit) - (define-key map [(control a)] 'eww-beginning-of-text) - (define-key map [(control c) (control c)] 'eww-submit) - (define-key map [(control e)] 'eww-end-of-text) - (define-key map [?\t] 'shr-next-link) - (define-key map [?\M-\t] 'shr-previous-link) - (define-key map [backtab] 'shr-previous-link) - map)) - -(defvar eww-textarea-map - (let ((map (make-keymap))) - (set-keymap-parent map text-mode-map) - (define-key map "\r" 'forward-line) - (define-key map [(control c) (control c)] 'eww-submit) - (define-key map [?\t] 'shr-next-link) - (define-key map [?\M-\t] 'shr-previous-link) - (define-key map [backtab] 'shr-previous-link) - map)) - -(defvar eww-select-map - (let ((map (make-sparse-keymap))) - (define-key map "\r" 'eww-change-select) - (define-key map [follow-link] 'mouse-face) - (define-key map [mouse-2] 'eww-change-select) - (define-key map [(control c) (control c)] 'eww-submit) - map)) +(defvar-keymap eww-submit-map + "RET" #'eww-submit + "C-c C-c" #'eww-submit) + +(defvar-keymap eww-submit-file + "RET" #'eww-select-file + "C-c C-c" #'eww-submit) + +(defvar-keymap eww-checkbox-map + "SPC" #'eww-toggle-checkbox + "RET" #'eww-toggle-checkbox + "C-c C-c" #'eww-submit) + +(defvar-keymap eww-text-map + :full t :parent text-mode-map + "RET" #'eww-submit + "C-a" #'eww-beginning-of-text + "C-c C-c" #'eww-submit + "C-e" #'eww-end-of-text + "TAB" #'shr-next-link + "M-TAB" #'shr-previous-link + "<backtab>" #'shr-previous-link) + +(defvar-keymap eww-textarea-map + :full t :parent text-mode-map + "RET" #'forward-line + "C-c C-c" #'eww-submit + "TAB" #'shr-next-link + "M-TAB" #'shr-previous-link + "<backtab>" #'shr-previous-link) + +(defvar-keymap eww-select-map + :doc "Map for select buttons" + "RET" #'eww-change-select + "<follow-link>" 'mouse-face + "<mouse-2>" #'eww-change-select + "C-c C-c" #'eww-submit) (defun eww-beginning-of-text () "Move to the start of the input field." @@ -1784,6 +1842,17 @@ The browser to used is specified by the (funcall browse-url-secondary-browser-function (or url (plist-get eww-data :url)))) +(defun eww-remove-tracking (url) + "Remove the commong utm_ tracking cookies from URLs." + (replace-regexp-in-string ".utm_.*" "" url)) + +(defun eww--transform-url (url) + "Appy `eww-url-transformers'." + (when url + (dolist (func eww-url-transformers) + (setq url (funcall func url))) + url)) + (defun eww-follow-link (&optional external mouse-event) "Browse the URL under point. If EXTERNAL is single prefix, browse the URL using @@ -1794,7 +1863,8 @@ If EXTERNAL is double prefix, browse in new buffer." (list current-prefix-arg last-nonmenu-event) eww-mode) (mouse-set-point mouse-event) - (let ((url (get-text-property (point) 'shr-url))) + (let* ((orig-url (get-text-property (point) 'shr-url)) + (url (eww--transform-url orig-url))) (cond ((not url) (message "No link under point")) @@ -1813,7 +1883,7 @@ If EXTERNAL is double prefix, browse in new buffer." (plist-put eww-data :url url) (eww-display-html 'utf-8 url dom nil (current-buffer)))) (t - (eww-browse-url url external))))) + (eww-browse-url orig-url external))))) (defun eww-same-page-p (url1 url2) "Return non-nil if URL1 and URL2 represent the same page. @@ -2100,23 +2170,18 @@ If ERROR-OUT, signal user-error if there are no bookmarks." 'eww-bookmark))) (eww-browse-url (plist-get bookmark :url)))) -(defvar eww-bookmark-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [(control k)] 'eww-bookmark-kill) - (define-key map [(control y)] 'eww-bookmark-yank) - (define-key map "\r" 'eww-bookmark-browse) - - (easy-menu-define nil map - "Menu for `eww-bookmark-mode-map'." - '("Eww Bookmark" - ["Exit" quit-window t] - ["Browse" eww-bookmark-browse - :active (get-text-property (line-beginning-position) 'eww-bookmark)] - ["Kill" eww-bookmark-kill - :active (get-text-property (line-beginning-position) 'eww-bookmark)] - ["Yank" eww-bookmark-yank - :active eww-bookmark-kill-ring])) - map)) +(defvar-keymap eww-bookmark-mode-map + "C-k" #'eww-bookmark-kill + "C-y" #'eww-bookmark-yank + "RET" #'eww-bookmark-browse + :menu '("Eww Bookmark" + ["Exit" quit-window t] + ["Browse" eww-bookmark-browse + :active (get-text-property (line-beginning-position) 'eww-bookmark)] + ["Kill" eww-bookmark-kill + :active (get-text-property (line-beginning-position) 'eww-bookmark)] + ["Yank" eww-bookmark-yank + :active eww-bookmark-kill-ring])) (define-derived-mode eww-bookmark-mode special-mode "eww bookmarks" "Mode for listing bookmarks. @@ -2181,19 +2246,15 @@ If ERROR-OUT, signal user-error if there are no bookmarks." (pop-to-buffer-same-window buffer))) (eww-restore-history history))) -(defvar eww-history-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\r" 'eww-history-browse) - (define-key map "n" 'next-line) - (define-key map "p" 'previous-line) - - (easy-menu-define nil map - "Menu for `eww-history-mode-map'." - '("Eww History" - ["Exit" quit-window t] - ["Browse" eww-history-browse - :active (get-text-property (line-beginning-position) 'eww-history)])) - map)) +(defvar-keymap eww-history-mode-map + "RET" #'eww-history-browse + "n" #'next-line + "p" #'previous-line + :menu '("Eww History" + ["Exit" quit-window t] + ["Browse" eww-history-browse + :active (get-text-property (line-beginning-position) + 'eww-history)])) (define-derived-mode eww-history-mode special-mode "eww history" "Mode for listing eww-histories. @@ -2304,22 +2365,18 @@ If ERROR-OUT, signal user-error if there are no bookmarks." (forward-line -1)) (eww-buffer-show)) -(defvar eww-buffers-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [(control k)] 'eww-buffer-kill) - (define-key map "\r" 'eww-buffer-select) - (define-key map "n" 'eww-buffer-show-next) - (define-key map "p" 'eww-buffer-show-previous) - - (easy-menu-define nil map - "Menu for `eww-buffers-mode-map'." - '("Eww Buffers" - ["Exit" quit-window t] - ["Select" eww-buffer-select - :active (get-text-property (line-beginning-position) 'eww-buffer)] - ["Kill" eww-buffer-kill - :active (get-text-property (line-beginning-position) 'eww-buffer)])) - map)) +(defvar-keymap eww-buffers-mode-map + "C-k" #'eww-buffer-kill + "RET" #'eww-buffer-select + "n" #'eww-buffer-show-next + "p" #'eww-buffer-show-previous + :menu '("Eww Buffers" + ["Exit" quit-window t] + ["Select" eww-buffer-select + :active (get-text-property (line-beginning-position) 'eww-buffer)] + ["Kill" eww-buffer-kill + :active (get-text-property (line-beginning-position) + 'eww-buffer)])) (define-derived-mode eww-buffers-mode special-mode "eww buffers" "Mode for listing buffers. diff --git a/lisp/net/hmac-def.el b/lisp/net/hmac-def.el index 5af6d4324ae..5778857ff80 100644 --- a/lisp/net/hmac-def.el +++ b/lisp/net/hmac-def.el @@ -37,6 +37,7 @@ a string and return a digest of it (in binary form). B is a byte length of a block size of H. (B=64 for both SHA1 and MD5.) L is a byte length of hash outputs. (L=16 for MD5, L=20 for SHA1.) If BIT is non-nil, truncate output to specified bits." + (declare (indent defun)) `(defun ,name (text key) ,(concat "Compute " (upcase (symbol-name name)) diff --git a/lisp/net/mailcap.el b/lisp/net/mailcap.el index 83d0eeef9f1..14d49251f55 100644 --- a/lisp/net/mailcap.el +++ b/lisp/net/mailcap.el @@ -55,7 +55,7 @@ you have an entry for \"image/*\" in your ~/.mailcap file." "A syntax table for parsing SGML attributes.") (defvar mailcap-print-command - (mapconcat 'identity + (mapconcat #'identity (cons (if (boundp 'lpr-command) lpr-command "lpr") @@ -116,8 +116,7 @@ is consulted." (regexp :tag "MIME Type") (sexp :tag "Test (optional)"))) :get #'mailcap--get-user-mime-data - :set #'mailcap--set-user-mime-data - :group 'mailcap) + :set #'mailcap--set-user-mime-data) ;; Postpone using defcustom for this as it's so big and we essentially ;; have to have two copies of the data around then. Perhaps just @@ -344,8 +343,7 @@ Same format as `mailcap-mime-data'.") "Directory to which `mailcap-save-binary-file' downloads files by default. nil means your home directory." :type '(choice (const :tag "Home directory" nil) - directory) - :group 'mailcap) + directory)) (defvar mailcap-poor-system-types '(ms-dos windows-nt) @@ -423,14 +421,6 @@ MAILCAPS if set; otherwise (on Unix) use the path from RFC 1524, plus (interactive (list nil t)) (when (or (not mailcap-parsed-p) force) - ;; Clear out all old data. - (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") @@ -447,18 +437,26 @@ MAILCAPS if set; otherwise (on Unix) use the path from RFC 1524, plus ("/etc/mailcap" system) ("/usr/etc/mailcap" system) ("/usr/local/etc/mailcap" system))))) - ;; The ~/.mailcap entries will end up first in the resulting data. - (dolist (spec (reverse - (if (stringp path) - (split-string path path-separator t) - path))) - (let ((source (and (consp spec) (cadr spec))) - (file-name (if (stringp spec) - spec - (car spec)))) - (when (and (file-readable-p file-name) - (file-regular-p file-name)) - (mailcap-parse-mailcap file-name source)))) + (when (stringp path) + (setq path (mapcar #'list (split-string path path-separator t)))) + (when (seq-some (lambda (f) + (file-has-changed-p (car f) 'mail-parse-mailcaps)) + path) + ;; Clear out all old data. + (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))) + ;; The ~/.mailcap entries will end up first in the resulting data. + (dolist (spec (reverse path)) + (let ((source (cadr spec)) + (file-name (car spec))) + (when (and (file-readable-p file-name) + (file-regular-p file-name)) + (mailcap-parse-mailcap file-name source))))) (setq mailcap-parsed-p t))) (defun mailcap-parse-mailcap (fname &optional source) @@ -636,7 +634,7 @@ the test clause will be unchanged." ((and (listp test) (symbolp (car test))) test) ((or (stringp test) (and (listp test) (stringp (car test)) - (setq test (mapconcat 'identity test " ")))) + (setq test (mapconcat #'identity test " ")))) (with-temp-buffer (insert test) (goto-char (point-min)) @@ -707,12 +705,12 @@ to supply to the test." (symbol-value test)) ((and (listp test) ; List to be eval'd (symbolp (car test))) - (eval test)) + (eval test t)) (t (setq test (mailcap-unescape-mime-test test type-info) test (list shell-file-name nil nil nil shell-command-switch test) - status (apply 'call-process test)) + status (apply #'call-process test)) (eq 0 status)))) (push (list otest result) mailcap-viewer-test-cache) result)))) @@ -837,7 +835,7 @@ If NO-DECODE is non-nil, don't decode STRING." (dolist (entry viewers) (when (mailcap-viewer-passes-test entry info) (push entry passed))) - (setq passed (sort (nreverse passed) 'mailcap-viewer-lessp)) + (setq passed (sort (nreverse passed) #'mailcap-viewer-lessp)) ;; When we want to prefer entries from the user's ;; ~/.mailcap file, then we filter out the system entries ;; and see whether we have anything left. @@ -1065,12 +1063,21 @@ For instance, \"foo.png\" will result in \"image/png\"." (match-string 1 file-name) ""))) +;;;###autoload +(defun mailcap-mime-type-to-extension (mime-type) + "Return a file name extension based on a MIME-TYPE. +For instance, `image/png' will result in `png'." + (intern (cadr (split-string (if (symbolp mime-type) + (symbol-name mime-type) + mime-type) + "/")))) + (defun mailcap-mime-types () "Return a list of MIME media types." (mailcap-parse-mimetypes) (delete-dups (nconc - (mapcar 'cdr mailcap-mime-extensions) + (mapcar #'cdr mailcap-mime-extensions) (let (res type) (dolist (data mailcap--computed-mime-data) (dolist (info (cdr data)) diff --git a/lisp/net/newst-backend.el b/lisp/net/newst-backend.el index 03a297ca41f..d51f8c0189f 100644 --- a/lisp/net/newst-backend.el +++ b/lisp/net/newst-backend.el @@ -402,13 +402,6 @@ headline after it has been retrieved for the first time." "Miscellaneous newsticker settings." :group 'newsticker) -(defcustom newsticker-cache-filename - "~/.newsticker-cache" - "Name of the newsticker cache file." - :type 'string - :group 'newsticker-miscellaneous) -(make-obsolete-variable 'newsticker-cache-filename 'newsticker-dir "23.1") - (defcustom newsticker-dir (locate-user-emacs-file "newsticker/" ".newsticker/") "Directory where newsticker saves data." @@ -2114,28 +2107,6 @@ well." (throw 'result t))))) (< (or (newsticker--pos item1) 0) (or (newsticker--pos item2) 0)))) -(defun newsticker--cache-save-version1 () - "Update and save newsticker cache file." - (interactive) - (newsticker--cache-update t)) - -(defun newsticker--cache-update (&optional save) - "Update newsticker cache file. -If optional argument SAVE is not nil the cache file is saved to disk." - (save-excursion - (unless (file-directory-p newsticker-dir) - (make-directory newsticker-dir t)) - (let ((coding-system-for-write 'utf-8) - (buf (find-file-noselect newsticker-cache-filename))) - (when buf - (set-buffer buf) - (setq buffer-undo-list t) - (erase-buffer) - (insert ";; -*- coding: utf-8 -*-\n") - (insert (prin1-to-string newsticker--cache)) - (when save - (save-buffer)))))) - (defun newsticker--cache-get-feed (feed) "Return the cached data for the feed FEED. FEED is a symbol!" @@ -2162,30 +2133,11 @@ FEED is a symbol!" (insert ";; -*- coding: utf-8 -*-\n") (insert (prin1-to-string (cdr feed))))))) -(defun newsticker--cache-read-version1 () - "Read version1 cache data." - (let ((coding-system-for-read 'utf-8)) - (when (file-exists-p newsticker-cache-filename) - (with-temp-buffer - (insert-file-contents newsticker-cache-filename) - (goto-char (point-min)) - (condition-case nil - (setq newsticker--cache (read (current-buffer))) - (error - (message "Error while reading newsticker cache file!") - (setq newsticker--cache nil))))))) - (defun newsticker--cache-read () "Read cache data." (setq newsticker--cache nil) - (if (file-exists-p newsticker-cache-filename) - (progn - (when (y-or-n-p "Old newsticker cache file exists. Read it? ") - (newsticker--cache-read-version1)) - (when (y-or-n-p "Delete old newsticker cache file? ") - (delete-file newsticker-cache-filename))) - (dolist (f (append newsticker-url-list-defaults newsticker-url-list)) - (newsticker--cache-read-feed (car f))))) + (dolist (f (append newsticker-url-list-defaults newsticker-url-list)) + (newsticker--cache-read-feed (car f)))) (defun newsticker--cache-read-feed (feed-name) "Read cache data for feed named FEED-NAME." diff --git a/lisp/net/newst-plainview.el b/lisp/net/newst-plainview.el index 420cf82e4d8..82977b000b6 100644 --- a/lisp/net/newst-plainview.el +++ b/lisp/net/newst-plainview.el @@ -589,7 +589,7 @@ calls `w3m-toggle-inline-image'. It works only if (defun newsticker-close-buffer () "Close the newsticker buffer." (interactive) - (newsticker--cache-update t) + (newsticker--cache-save) (bury-buffer)) (defun newsticker-next-new-item (&optional do-not-wrap-at-eob) @@ -748,7 +748,7 @@ Return new buffer position." (newsticker--cache-replace-age newsticker--cache feed 'new 'old) (newsticker--cache-replace-age newsticker--cache feed 'obsolete 'old) - (newsticker--cache-update) + (newsticker--cache-save) (newsticker--buffer-set-uptodate nil) (newsticker--ticker-text-setup) (newsticker-buffer-update) @@ -879,7 +879,7 @@ not get changed." (newsticker--cache-replace-age newsticker--cache 'any 'new 'old) (newsticker--buffer-set-uptodate nil) (newsticker--ticker-text-setup) - (newsticker--cache-update) + (newsticker--cache-save) (newsticker-buffer-update))) (defun newsticker-hide-extra () diff --git a/lisp/net/nsm.el b/lisp/net/nsm.el index 2ac1df1d58a..b067b23f8ff 100644 --- a/lisp/net/nsm.el +++ b/lisp/net/nsm.el @@ -79,8 +79,7 @@ option." (const :tag "Off" nil) (function :tag "Custom function"))) -(defcustom nsm-settings-file (expand-file-name "network-security.data" - user-emacs-directory) +(defcustom nsm-settings-file (locate-user-emacs-file "network-security.data") "The file the security manager settings will be stored in." :version "25.1" :type 'file) diff --git a/lisp/net/puny.el b/lisp/net/puny.el index 42a7e796798..c1833ffdb0b 100644 --- a/lisp/net/puny.el +++ b/lisp/net/puny.el @@ -43,6 +43,7 @@ For instance, \"fśf.org\" => \"xn--ff-2sa.org\"." "Encode STRING according to the IDNA/punycode algorithm. This is used to encode non-ASCII domain names. For instance, \"bücher\" => \"xn--bcher-kva\"." + (setq string (downcase (string-glyph-compose string))) (let ((ascii (seq-filter (lambda (char) (< char 128)) string))) diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el index 5c92c60eda2..2375b14cca2 100644 --- a/lisp/net/rcirc.el +++ b/lisp/net/rcirc.el @@ -262,6 +262,7 @@ The ARGUMENTS for each METHOD symbol are: `bitlbee': NICK PASSWORD `quakenet': ACCOUNT PASSWORD `sasl': NICK PASSWORD + `certfp': KEY CERT Examples: ((\"Libera.Chat\" nickserv \"bob\" \"p455w0rd\") @@ -291,7 +292,11 @@ Examples: (list :tag "SASL" (const sasl) (string :tag "Nick") - (string :tag "Password"))))) + (string :tag "Password")) + (list :tag "CertFP" + (const certfp) + (string :tag "Key") + (string :tag "Certificate"))))) (defcustom rcirc-auto-authenticate-flag t "Non-nil means automatically send authentication string to server. @@ -547,6 +552,9 @@ If ARG is non-nil, instead prompt for connection parameters." (password (plist-get (cdr c) :password)) (encryption (plist-get (cdr c) :encryption)) (server-alias (plist-get (cdr c) :server-alias)) + (client-cert (when (eq (rcirc-get-server-method (car c)) + 'certfp) + (rcirc-get-server-cert (car c)))) contact) (when-let (((not password)) (auth (auth-source-search :host server @@ -563,7 +571,7 @@ If ARG is non-nil, instead prompt for connection parameters." (condition-case nil (let ((process (rcirc-connect server port nick user-name full-name channels password encryption - server-alias))) + client-cert server-alias))) (when rcirc-display-server-buffer (pop-to-buffer-same-window (process-buffer process)))) (quit (message "Quit connecting to %s" @@ -646,29 +654,23 @@ See `rcirc-connect' for more details on these variables.") (defun rcirc-get-server-method (server) "Return authentication method for SERVER." - (catch 'method - (dolist (i rcirc-authinfo) - (let ((server-i (car i)) - (method (cadr i))) - (when (string-match server-i server) - (throw 'method method)))))) + (cadr (assoc server rcirc-authinfo #'string-match))) (defun rcirc-get-server-password (server) "Return password for SERVER." - (catch 'pass - (dolist (i rcirc-authinfo) - (let ((server-i (car i)) - (args (cdddr i))) - (when (string-match server-i server) - (throw 'pass (car args))))))) + (cadddr (assoc server rcirc-authinfo #'string-match))) + +(defun rcirc-get-server-cert (server) + "Return a list of key and certificate for SERVER." + (cddr (assoc server rcirc-authinfo #'string-match))) ;;;###autoload (defun rcirc-connect (server &optional port nick user-name full-name startup-channels password encryption - server-alias) + certfp server-alias) "Connect to SERVER. The arguments PORT, NICK, USER-NAME, FULL-NAME, PASSWORD, -ENCRYPTION, SERVER-ALIAS are interpreted as in +ENCRYPTION, CERTFP, SERVER-ALIAS are interpreted as in `rcirc-server-alist'. STARTUP-CHANNELS is a list of channels that are joined after authentication." (save-excursion @@ -695,6 +697,7 @@ that are joined after authentication." (setq process (open-network-stream (or server-alias server) nil server port-number :type (or encryption 'plain) + :client-certificate certfp :nowait t)) (set-process-coding-system process 'raw-text 'raw-text) (with-current-buffer (get-buffer-create (rcirc-generate-new-buffer-name process nil)) @@ -713,8 +716,8 @@ that are joined after authentication." (setq rcirc-nick-table (make-hash-table :test 'equal)) (setq rcirc-nick nick) (setq rcirc-startup-channels startup-channels) - (setq rcirc-last-server-message-time (current-time)) (setq rcirc-last-connect-time (current-time)) + (setq rcirc-last-server-message-time rcirc-last-connect-time) ;; Check if the immediate process state (sit-for .1) diff --git a/lisp/net/sasl.el b/lisp/net/sasl.el index b7f814f7237..0a3ecf9f534 100644 --- a/lisp/net/sasl.el +++ b/lisp/net/sasl.el @@ -174,21 +174,24 @@ It contain at least 64 bits of entropy." ;; stolen (and renamed) from message.el (defun sasl-unique-id-function () - ;; Don't use microseconds from (current-time), they may be unsupported. + ;; Don't use fractional seconds from timestamp; they may be unsupported. ;; Instead we use this randomly inited counter. (setq sasl-unique-id-char - (% (1+ (or sasl-unique-id-char (logand (random) (1- (ash 1 20))))) - ;; (current-time) returns 16-bit ints, - ;; and 2^16*25 just fits into 4 digits i base 36. - (* 25 25))) - (let ((tm (current-time))) + ;; 2^16 * 25 just fits into 4 digits i base 36. + (let ((base (* 25 25))) + (if sasl-unique-id-char + (% (1+ sasl-unique-id-char) base) + (random base)))) + (let ((tm (time-convert nil 'integer))) (concat (sasl-unique-id-number-base36 - (+ (car tm) - (ash (% sasl-unique-id-char 25) 16)) 4) + (+ (ash tm -16) + (ash (% sasl-unique-id-char 25) 16)) + 4) (sasl-unique-id-number-base36 - (+ (nth 1 tm) - (ash (/ sasl-unique-id-char 25) 16)) 4)))) + (+ (logand tm #xffff) + (ash (/ sasl-unique-id-char 25) 16)) + 4)))) (defun sasl-unique-id-number-base36 (num len) (if (if (< len 0) diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 48590fd675a..5f31f034303 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -40,6 +40,7 @@ (require 'image) (require 'puny) (require 'url-cookie) +(require 'pixel-fill) (require 'text-property-search) (defgroup shr nil @@ -162,6 +163,10 @@ cid: URL as the argument.") (defvar shr-put-image-function #'shr-put-image "Function called to put image and alt string.") +(defface shr-text '((t :inherit variable-pitch-text)) + "Face used for rendering text." + :version "29.1") + (defface shr-strike-through '((t :strike-through t)) "Face for <s> elements." :version "24.1") @@ -183,6 +188,11 @@ temporarily blinks with this face." "Face for <abbr> elements." :version "27.1") +(defface shr-sup + '((t :height 0.8)) + "Face for <sup> and <sub> elements." + :version "29.1") + (defface shr-h1 '((t :height 1.3 :weight bold)) "Face for <h1> elements." @@ -231,7 +241,6 @@ and other things: (defvar shr-internal-width nil) (defvar shr-list-mode nil) (defvar shr-content-cache nil) -(defvar shr-kinsoku-shorten nil) (defvar shr-table-depth 0) (defvar shr-stylesheet nil) (defvar shr-base nil) @@ -247,23 +256,21 @@ and other things: (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) - (define-key map "i" #'shr-browse-image) - (define-key map "z" #'shr-zoom-image) - (define-key map [?\t] #'shr-next-link) - (define-key map [?\M-\t] #'shr-previous-link) - (define-key map [follow-link] 'mouse-face) - (define-key map [mouse-2] #'shr-browse-url) - (define-key map [C-down-mouse-1] #'shr-mouse-browse-url-new-window) - (define-key map "I" #'shr-insert-image) - (define-key map "w" #'shr-maybe-probe-and-copy-url) - (define-key map "u" #'shr-maybe-probe-and-copy-url) - (define-key map "v" #'shr-browse-url) - (define-key map "O" #'shr-save-contents) - (define-key map "\r" #'shr-browse-url) - map)) +(defvar-keymap shr-map + "a" #'shr-show-alt-text + "i" #'shr-browse-image + "z" #'shr-zoom-image + "TAB" #'shr-next-link + "C-M-i" #'shr-previous-link + "<follow-link>" 'mouse-face + "<mouse-2>" #'shr-browse-url + "C-<down-mouse-1>" #'shr-mouse-browse-url-new-window + "I" #'shr-insert-image + "w" #'shr-maybe-probe-and-copy-url + "u" #'shr-maybe-probe-and-copy-url + "v" #'shr-browse-url + "O" #'shr-save-contents + "RET" #'shr-browse-url) (defvar shr-image-map (let ((map (copy-keymap shr-map))) @@ -305,6 +312,18 @@ and other things: (or (not (zerop (fringe-columns 'right))) (not (zerop (fringe-columns 'left)))))) +(defun shr--window-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)) + (pixel-fill-width))) + ;;;###autoload (defun shr-insert-document (dom) "Render the parsed document DOM into the current buffer. @@ -326,21 +345,7 @@ DOM should be a parse tree as generated by (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)))) + (shr--window-width))) (max-specpdl-size max-specpdl-size) ;; `bidi-display-reordering' is supposed to be only used for ;; debugging purposes, but Shr's naïve filling algorithm @@ -577,7 +582,7 @@ size, and full-buffer size." (setq shr-warning "Not rendering the complete page because of too-deep nesting") (when style - (if (string-match "color\\|display\\|border-collapse" style) + (if (string-match-p "color\\|display\\|border-collapse" style) (setq shr-stylesheet (nconc (shr-parse-style style) shr-stylesheet)) (setq style nil))) @@ -619,43 +624,11 @@ size, and full-buffer size." (with-temp-buffer (let ((shr-indentation 0) (shr-start nil) - (shr-internal-width (- (window-body-width nil t) - (* 2 (frame-char-width)) - ;; Adjust the window width for when - ;; the user disables the fringes, - ;; which causes the display engine - ;; to usurp one column for the - ;; continuation glyph. - (if (and (null shr-width) - (not (shr--have-one-fringe-p))) - (* (frame-char-width) 2) - 0)))) + (shr-internal-width (shr--window-width))) (shr-insert text) (shr-fill-lines (point-min) (point-max)) (buffer-string))))) -(define-inline shr-char-breakable-p (char) - "Return non-nil if a line can be broken before and after CHAR." - (inline-quote (aref fill-find-break-point-function-table ,char))) -(define-inline shr-char-nospace-p (char) - "Return non-nil if no space is required before and after CHAR." - (inline-quote (aref fill-nospace-between-words-table ,char))) - -;; KINSOKU is a Japanese word meaning a rule that should not be violated. -;; In Emacs, it is a term used for characters, e.g. punctuation marks, -;; parentheses, and so on, that should not be placed in the beginning -;; of a line or the end of a line. -(define-inline shr-char-kinsoku-bol-p (char) - "Return non-nil if a line ought not to begin with CHAR." - (inline-letevals (char) - (inline-quote (and (not (eq ,char ?')) - (aref (char-category-set ,char) ?>))))) -(define-inline shr-char-kinsoku-eol-p (char) - "Return non-nil if a line ought not to end with CHAR." - (inline-quote (aref (char-category-set ,char) ?<))) -(unless (shr-char-kinsoku-bol-p (make-char 'japanese-jisx0208 33 35)) - (load "kinsoku" nil t)) - (defun shr-pixel-column () (if (not shr-use-fonts) (current-column) @@ -669,6 +642,7 @@ size, and full-buffer size." (car (window-text-pixel-size nil (line-beginning-position) (point)))))) (defun shr-pixel-region () + (declare (obsolete nil "29.1")) (- (shr-pixel-column) (save-excursion (goto-char (mark)) @@ -711,7 +685,7 @@ size, and full-buffer size." (goto-char (point-max))))) (t (let ((font-start (point))) - (when (and (string-match "\\`[ \t\n\r]" text) + (when (and (string-match-p "\\`[ \t\n\r]" text) (not (bolp)) (not (eq (char-after (1- (point))) ? ))) (insert " ")) @@ -739,7 +713,7 @@ size, and full-buffer size." (when shr-use-fonts (put-text-property font-start (point) 'face - (or shr-current-font 'variable-pitch))))))))) + (or shr-current-font 'shr-text))))))))) (defun shr-fill-lines (start end) (if (<= shr-internal-width 0) @@ -788,7 +762,7 @@ size, and full-buffer size." (while (not (eolp)) ;; We have to do some folding. First find the first ;; previous point suitable for folding. - (if (or (not (shr-find-fill-point (line-beginning-position))) + (if (or (not (pixel-fill-find-fill-point (line-beginning-position))) (= (point) start)) ;; We had unbreakable text (for this width), so just go to ;; the first space and carry on. @@ -829,84 +803,6 @@ size, and full-buffer size." (when (looking-at " $") (delete-region (point) (line-end-position))))))) -(defun shr-find-fill-point (start) - (let ((bp (point)) - (end (point)) - failed) - (while (not (or (setq failed (<= (point) start)) - (eq (preceding-char) ? ) - (eq (following-char) ? ) - (shr-char-breakable-p (preceding-char)) - (shr-char-breakable-p (following-char)) - (and (shr-char-kinsoku-bol-p (preceding-char)) - (shr-char-breakable-p (following-char)) - (not (shr-char-kinsoku-bol-p (following-char)))) - (shr-char-kinsoku-eol-p (following-char)) - (bolp))) - (backward-char 1)) - (if failed - ;; There's no breakable point, so we give it up. - (let (found) - (goto-char bp) - ;; Don't overflow the window edge, even if - ;; shr-kinsoku-shorten is nil. - (unless (or shr-kinsoku-shorten (null shr-width)) - (while (setq found (re-search-forward - "\\(\\c>\\)\\| \\|\\c<\\|\\c|" - (line-end-position) 'move))) - (if (and found - (not (match-beginning 1))) - (goto-char (match-beginning 0))))) - (or - (eolp) - ;; Don't put kinsoku-bol characters at the beginning of a line, - ;; or kinsoku-eol characters at the end of a line. - (cond - ;; Don't overflow the window edge, even if shr-kinsoku-shorten - ;; is nil. - ((or shr-kinsoku-shorten (null shr-width)) - (while (and (not (memq (preceding-char) (list ?\C-@ ?\n ? ))) - (or (shr-char-kinsoku-eol-p (preceding-char)) - (shr-char-kinsoku-bol-p (following-char)))) - (backward-char 1)) - (when (setq failed (<= (point) start)) - ;; There's no breakable point that doesn't violate kinsoku, - ;; so we look for the second best position. - (while (and (progn - (forward-char 1) - (<= (point) end)) - (progn - (setq bp (point)) - (shr-char-kinsoku-eol-p (following-char))))) - (goto-char bp))) - ((shr-char-kinsoku-eol-p (preceding-char)) - ;; Find backward the point where kinsoku-eol characters begin. - (let ((count 4)) - (while - (progn - (backward-char 1) - (and (> (setq count (1- count)) 0) - (not (memq (preceding-char) (list ?\C-@ ?\n ? ))) - (or (shr-char-kinsoku-eol-p (preceding-char)) - (shr-char-kinsoku-bol-p (following-char))))))) - (when (setq failed (<= (point) start)) - ;; There's no breakable point that doesn't violate kinsoku, - ;; so we go to the second best position. - (if (looking-at "\\(\\c<+\\)\\c<") - (goto-char (match-end 1)) - (forward-char 1)))) - ((shr-char-kinsoku-bol-p (following-char)) - ;; Find forward the point where kinsoku-bol characters end. - (let ((count 4)) - (while (progn - (forward-char 1) - (and (>= (setq count (1- count)) 0) - (shr-char-kinsoku-bol-p (following-char)) - (shr-char-breakable-p (following-char)))))))) - (when (eq (following-char) ? ) - (forward-char 1)))) - (not failed))) - (defun shr-parse-base (url) ;; Always chop off anchors. (when (string-match "#.*" url) @@ -947,7 +843,7 @@ size, and full-buffer size." (cond ((zerop (length url)) (nth 3 base)) ((or (not base) - (string-match "\\`[a-z]*:" url)) + (string-match-p "\\`[a-z]*:" url)) ;; Absolute or empty URI url) ((eq (aref url 0) ?/) @@ -1132,14 +1028,14 @@ the mouse click event." (let ((param (match-string 4 data)) (payload (url-unhex-string (match-string 5 data)))) (when (and param - (string-match "^.*\\(;[ \t]*base64\\)$" param)) + (string-match-p "^.*\\(;[ \t]*base64\\)$" param)) (setq payload (ignore-errors (base64-decode-string payload)))) payload))) ;; Behind display-graphic-p test. (declare-function image-size "image.c" (spec &optional pixels frame)) -(declare-function image-animate "image" (image &optional index limit)) +(declare-function image-animate "image" (image &optional index limit position)) (defun shr-put-image (spec alt &optional flags) "Insert image SPEC with a string ALT. Return image. @@ -1176,13 +1072,14 @@ element is the data blob and the second element is the content-type." (when (and (> (current-column) 0) (> (car (image-size image t)) 400)) (insert "\n")) - (if (eq size 'original) - (insert-sliced-image image (or alt "*") nil 20 1) - (insert-image image (or alt "*"))) - (put-text-property start (point) 'image-size size) - (when (and shr-image-animate - (cdr (image-multi-frame-p image))) - (image-animate image nil 60))) + (let ((image-pos (point))) + (if (eq size 'original) + (insert-sliced-image image (or alt "*") nil 20 1) + (insert-image image (or alt "*"))) + (put-text-property start (point) 'image-size size) + (when (and shr-image-animate + (cdr (image-multi-frame-p image))) + (image-animate image nil 60 image-pos)))) image) (insert (or alt "")))) @@ -1448,7 +1345,7 @@ ones, in case fg and bg are nil." ;; Filter out blocked elements inside the SVG image. (not (setq url (dom-attr elem ':xlink:href))) (not shr-blocked-images) - (not (string-match shr-blocked-images url))) + (not (string-match-p shr-blocked-images url))) (insert " ") (shr-dom-print elem))))) (insert (format "</%s>" (dom-tag dom)))) @@ -1465,12 +1362,14 @@ ones, in case fg and bg are nil." (defun shr-tag-sup (dom) (let ((start (point))) (shr-generic dom) - (put-text-property start (point) 'display '(raise 0.2)))) + (put-text-property start (point) 'display '(raise 0.2)) + (add-face-text-property start (point) 'shr-sup))) (defun shr-tag-sub (dom) (let ((start (point))) (shr-generic dom) - (put-text-property start (point) 'display '(raise -0.2)))) + (put-text-property start (point) 'display '(raise -0.2)) + (add-face-text-property start (point) 'shr-sup))) (defun shr-tag-p (dom) (shr-ensure-paragraph) @@ -1532,9 +1431,7 @@ ones, in case fg and bg are nil." (defun shr-parse-style (style) (when style - (save-match-data - (when (string-match "\n" style) - (setq style (replace-match " " t t style)))) + (setq style (replace-regexp-in-string "\n" " " style)) (let ((plist nil)) (dolist (elem (split-string style ";")) (when elem @@ -1592,7 +1489,7 @@ ones, in case fg and bg are nil." (let ((start (point)) url multimedia image) (when-let* ((type (dom-attr dom 'type))) - (when (string-match "\\`image/svg" type) + (when (string-match-p "\\`image/svg" type) (setq url (dom-attr dom 'data) image t))) (dolist (child (dom-non-text-children dom)) @@ -1628,6 +1525,14 @@ url if no type is specified. The value should be a float in the range 0.0 to :version "24.4" :type '(alist :key-type regexp :value-type float)) +(defcustom shr-use-xwidgets-for-media nil + "If non-nil, use xwidgets to display video and audio elements. +This also depends on Emacs being built with xwidgets capability. +Note that this is experimental, and may lead to instability on +some platforms." + :type 'boolean + :version "29.1") + (defun shr--get-media-pref (elem) "Determine the preference for ELEM. The preference is a float determined from `shr-prefer-media-type'." @@ -1664,16 +1569,39 @@ The preference is a float determined from `shr-prefer-media-type'." pref (cdr ret))))))))) (cons url pref)) +(declare-function xwidget-webkit-execute-script "xwidget.c" + (xwidget script &optional callback)) + (defun shr-tag-video (dom) (let ((image (dom-attr dom 'poster)) (url (dom-attr dom 'src)) (start (point))) (unless url (setq url (car (shr--extract-best-source dom)))) - (if (> (length image) 0) - (shr-indirect-call 'img nil image) - (shr-insert " [video] ")) - (shr-urlify start (shr-expand-url url)))) + (if (and shr-use-xwidgets-for-media + (fboundp 'make-xwidget)) + ;; Play the video. + (progn + (require 'xwidget) + (let ((widget (make-xwidget + 'webkit + "Video" + (truncate (* (window-pixel-width) 0.8)) + (truncate (* (window-pixel-width) 0.8 0.75))))) + (insert + (propertize + " [video] " + 'display (list 'xwidget :xwidget widget))) + (xwidget-webkit-execute-script + widget (format "document.body.innerHTML = %S;" + (format + "<style>body { margin: 0px; }</style><div style='background: black; height: 100%%; display: flex; align-items: center; justify-content: center;'><video autoplay loop muted controls style='max-width: 100%%; max-height: 100%%;'><source src=%S type='video/mp4'></source></video></div>" + url))))) + ;; No xwidgets. + (if (> (length image) 0) + (shr-indirect-call 'img nil image) + (shr-insert " [video] ")) + (shr-urlify start (shr-expand-url url))))) (defun shr-tag-audio (dom) (let ((url (dom-attr dom 'src)) @@ -1724,7 +1652,7 @@ The preference is a float determined from `shr-prefer-media-type'." (list :width width :height height))))) ((or shr-inhibit-images (and shr-blocked-images - (string-match shr-blocked-images url))) + (string-match-p shr-blocked-images url))) (setq shr-start (point)) (shr-insert alt)) ((and (not shr-ignore-cache) @@ -2036,7 +1964,8 @@ BASE is the URL of the HTML being rendered." (setq dom (or (dom-child-by-tag dom 'tbody) dom)) (let* ((shr-inhibit-images t) (shr-table-depth (1+ shr-table-depth)) - (shr-kinsoku-shorten t) + ;; Fill hard in CJK languages. + (pixel-fill-respect-kinsoku nil) ;; Find all suggested widths. (columns (shr-column-specs dom)) ;; Compute how many pixels wide each TD should be. @@ -2532,7 +2461,7 @@ flags that control whether to collect or render objects." (max-width 0) natural-width) (when style - (setq style (and (string-match "color" style) + (setq style (and (string-search "color" style) (shr-parse-style style)))) (when bgcolor (setq style (nconc (list (cons 'background-color bgcolor)) diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 362a258f43d..341357d404c 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -107,7 +107,8 @@ It is used for TCP/IP devices." ;;;###tramp-autoload (defconst tramp-adb-file-name-handler-alist - '((access-file . tramp-handle-access-file) + '(;; `abbreviate-file-name' performed by default handler. + (access-file . tramp-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) @@ -191,11 +192,10 @@ It is used for TCP/IP devices." ;; 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-adb-file-name-p (filename) - "Check if it's a FILENAME for ADB." - (and (tramp-tramp-file-p filename) - (string= (tramp-file-name-method (tramp-dissect-file-name filename)) - tramp-adb-method))) +(defsubst tramp-adb-file-name-p (vec-or-filename) + "Check if it's a VEC-OR-FILENAME for ADB." + (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) + (string= (tramp-file-name-method vec) tramp-adb-method))) ;;;###tramp-autoload (defun tramp-adb-file-name-handler (operation &rest args) @@ -306,7 +306,7 @@ arguments to pass to the OPERATION." (directory &optional full match nosort id-format count) "Like `directory-files-and-attributes' for Tramp files." (unless (file-exists-p directory) - (tramp-compat-file-missing (tramp-dissect-file-name directory) directory)) + (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) (when (file-directory-p directory) (with-parsed-tramp-file-name (expand-file-name directory) nil (copy-tree @@ -499,7 +499,7 @@ Emacs dired can't find files." "Like `file-local-copy' for Tramp files." (with-parsed-tramp-file-name filename nil (unless (file-exists-p (file-truename filename)) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (let ((tmpfile (tramp-compat-make-temp-file filename))) (with-tramp-progress-reporter v 3 (format "Fetching %s to tmp file %s" filename tmpfile) @@ -591,8 +591,7 @@ Emacs dired can't find files." ;; Set file modification time. (when (or (eq visit t) (stringp visit)) (set-visited-file-modtime - (or (tramp-compat-file-attribute-modification-time - (file-attributes filename)) + (or (file-attribute-modification-time (file-attributes filename)) (current-time)))) ;; Unlock file. @@ -660,7 +659,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (jka-compr-inhibit t)) (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing 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) @@ -720,8 +719,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when keep-date (tramp-compat-set-file-times newname - (tramp-compat-file-attribute-modification-time - (file-attributes filename)) + (file-attribute-modification-time (file-attributes filename)) (unless ok-if-already-exists 'nofollow))))) (defun tramp-adb-handle-rename-file @@ -742,7 +740,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (jka-compr-inhibit t)) (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing 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) @@ -1349,22 +1347,18 @@ connection if a previous connection has died for some reason." ;; Mark it as connected. (tramp-set-connection-property p "connected" t))))))) -;;; Default connection-local variables for Tramp: -;; `connection-local-set-profile-variables' and -;; `connection-local-set-profiles' exists since Emacs 26.1. +;;; Default connection-local variables for Tramp. (defconst tramp-adb-connection-local-default-shell-variables '((shell-file-name . "/system/bin/sh") (shell-command-switch . "-c")) "Default connection-local shell variables for remote adb connections.") -(tramp-compat-funcall - 'connection-local-set-profile-variables +(connection-local-set-profile-variables 'tramp-adb-connection-local-default-shell-profile tramp-adb-connection-local-default-shell-variables) (with-eval-after-load 'shell - (tramp-compat-funcall - 'connection-local-set-profiles + (connection-local-set-profiles `(:application tramp :protocol ,tramp-adb-method) 'tramp-adb-connection-local-default-shell-profile)) diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index bd0f82cbad6..b44a4e86aad 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -54,6 +54,7 @@ ;; * ".ar" - UNIX archiver formats ;; * ".cab", ".CAB" - Microsoft Windows cabinets ;; * ".cpio" - CPIO archives +;; * ".crate" - Cargo (Rust) packages ;; * ".deb" - Debian packages ;; * ".depot" - HP-UX SD depots ;; * ".exe" - Self extracting Microsoft Windows EXE files @@ -141,6 +142,7 @@ "ar" ;; UNIX archiver formats. "cab" "CAB" ;; Microsoft Windows cabinets. "cpio" ;; CPIO archives. + "crate" ;; Cargo (Rust) packages. Not in libarchive testsuite. "deb" ;; Debian packages. Not in libarchive testsuite. "depot" ;; HP-UX SD depot. Not in libarchive testsuite. "exe" ;; Self extracting Microsoft Windows EXE files. @@ -211,7 +213,8 @@ It must be supported by libarchive(3).") ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-archive-file-name-handler-alist - '((access-file . tramp-archive-handle-access-file) + '(;; `abbreviate-file-name' performed by default handler. + (access-file . tramp-archive-handle-access-file) (add-name-to-file . tramp-archive-handle-not-implemented) ;; `byte-compiler-base-file-name' performed by default handler. ;; `copy-directory' performed by default handler. @@ -618,7 +621,7 @@ offered." (defun tramp-archive-handle-file-system-info (filename) "Like `file-system-info' for file archives." (with-parsed-tramp-archive-file-name filename nil - (list (tramp-compat-file-attribute-size (file-attributes archive)) 0 0))) + (list (file-attribute-size (file-attributes archive)) 0 0))) (defun tramp-archive-handle-file-truename (filename) "Like `file-truename' for file archives." @@ -658,7 +661,7 @@ offered." ;; mounted directory, it is returned as it. Not what we want. (with-parsed-tramp-archive-file-name default-directory nil (let ((default-directory (file-name-directory archive))) - (tramp-compat-temporary-file-directory-function)))) + (temporary-file-directory)))) (defun tramp-archive-handle-not-implemented (operation &rest args) "Generic handler for operations not implemented for file archives." diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index f1c656ec209..b909c5706d6 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -49,8 +49,6 @@ ;; 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. -;; "lock-pid" is the timestamp a (network) process is created, it is -;; used instead of the pid in file locks. ;; ;; - The key is nil. These are temporary properties related to the ;; local machine. Examples: "parse-passwd" and "parse-group" keep @@ -101,8 +99,7 @@ details see the info pages." (choice :tag " Value" sexp)))) ;;;###tramp-autoload -(defcustom tramp-persistency-file-name - (expand-file-name (locate-user-emacs-file "tramp")) +(defcustom tramp-persistency-file-name (locate-user-emacs-file "tramp") "File which keeps connection history for Tramp connections." :group 'tramp :type 'file) @@ -225,7 +222,9 @@ Return VALUE." (defun tramp-flush-file-upper-properties (key file) "Remove some properties of FILE's upper directory." (when (file-name-absolute-p file) - (let ((file (directory-file-name (file-name-directory file)))) + ;; `file-name-directory' can return nil, for example for "~". + (when-let ((file (file-name-directory file)) + (file (directory-file-name file))) ;; Unify localname. Remove hop from `tramp-file-name' structure. (setq file (tramp-compat-file-name-unquote file) key (copy-tramp-file-name key)) diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el index 63eab1b31a1..2eaebebed9f 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -67,7 +67,7 @@ SYNTAX can be one of the symbols `default' (default), nil (mapcar (lambda (x) - (with-current-buffer x (when (tramp-tramp-file-p default-directory) x))) + (when (tramp-tramp-file-p (tramp-get-default-directory x)) x)) (buffer-list)))) ;;;###tramp-autoload @@ -593,9 +593,8 @@ buffer in your bug report. (defun tramp-reporter-dump-variable (varsym mailbuf) "Pretty-print the value of the variable in symbol VARSYM." - (let* ((reporter-eval-buffer (symbol-value 'reporter-eval-buffer)) - (val (with-current-buffer reporter-eval-buffer - (symbol-value varsym)))) + (when-let ((reporter-eval-buffer reporter-eval-buffer) + (val (buffer-local-value varsym reporter-eval-buffer))) (if (hash-table-p val) ;; Pretty print the cache. diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index fbc3d684ce8..627ff1edaec 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -23,17 +23,12 @@ ;;; Commentary: -;; Tramp's main Emacs version for development is Emacs 28. This -;; package provides compatibility functions for Emacs 25, Emacs 26 and -;; Emacs 27. +;; Tramp's main Emacs version for development is Emacs 29. This +;; package provides compatibility functions for Emacs 26, Emacs 27 and +;; Emacs 28. ;;; Code: -;; 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) (require 'format-spec) (require 'ls-lisp) ;; Due to `tramp-handle-insert-directory'. @@ -42,8 +37,6 @@ (require 'subr-x) (declare-function tramp-error "tramp") -;; `temporary-file-directory' as function is introduced with Emacs 26.1. -(declare-function tramp-handle-temporary-file-directory "tramp") (declare-function tramp-tramp-file-p "tramp") (defvar tramp-temp-name-prefix) @@ -83,133 +76,19 @@ Add the extension of F, if existing." 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 - (if (fboundp 'temporary-file-directory) - #'temporary-file-directory - #'tramp-handle-temporary-file-directory)) - -;; `file-attribute-*' are introduced in Emacs 26.1. - -(defalias 'tramp-compat-file-attribute-type - (if (fboundp 'file-attribute-type) - #'file-attribute-type - (lambda (attributes) - "The type field in ATTRIBUTES returned by `file-attributes'. -The value is either t for directory, string (name linked to) for -symbolic link, or nil." - (nth 0 attributes)))) - -(defalias 'tramp-compat-file-attribute-link-number - (if (fboundp 'file-attribute-link-number) - #'file-attribute-link-number - (lambda (attributes) - "Return the number of links in ATTRIBUTES returned by `file-attributes'." - (nth 1 attributes)))) - -(defalias 'tramp-compat-file-attribute-user-id - (if (fboundp 'file-attribute-user-id) - #'file-attribute-user-id - (lambda (attributes) - "The UID field in ATTRIBUTES returned by `file-attributes'. -This is either a string or a number. If a string value cannot be -looked up, a numeric value, either an integer or a float, is -returned." - (nth 2 attributes)))) - -(defalias 'tramp-compat-file-attribute-group-id - (if (fboundp 'file-attribute-group-id) - #'file-attribute-group-id - (lambda (attributes) - "The GID field in ATTRIBUTES returned by `file-attributes'. -This is either a string or a number. If a string value cannot be -looked up, a numeric value, either an integer or a float, is -returned." - (nth 3 attributes)))) - -(defalias 'tramp-compat-file-attribute-access-time - (if (fboundp 'file-attribute-access-time) - #'file-attribute-access-time - (lambda (attributes) - "The last access time in ATTRIBUTES returned by `file-attributes'. -This a Lisp timestamp in the style of `current-time'." - (nth 4 attributes)))) - -(defalias 'tramp-compat-file-attribute-modification-time - (if (fboundp 'file-attribute-modification-time) - #'file-attribute-modification-time - (lambda (attributes) - "The modification time in ATTRIBUTES returned by `file-attributes'. -This is the time of the last change to the file's contents, and -is a Lisp timestamp in the style of `current-time'." - (nth 5 attributes)))) - -(defalias 'tramp-compat-file-attribute-status-change-time - (if (fboundp 'file-attribute-status-change-time) - #'file-attribute-status-change-time - (lambda (attributes) - "The status modification time in ATTRIBUTES returned by `file-attributes'. -This is the time of last change to the file's attributes: owner -and group, access mode bits, etc., and is a Lisp timestamp in the -style of `current-time'." - (nth 6 attributes)))) - -(defalias 'tramp-compat-file-attribute-size - (if (fboundp 'file-attribute-size) - #'file-attribute-size - (lambda (attributes) - "The size (in bytes) in ATTRIBUTES returned by `file-attributes'. -If the size is too large for a fixnum, this is a bignum in Emacs 27 -and later, and is a float in Emacs 26 and earlier." - (nth 7 attributes)))) - -(defalias 'tramp-compat-file-attribute-modes - (if (fboundp 'file-attribute-modes) - #'file-attribute-modes - (lambda (attributes) - "The file modes in ATTRIBUTES returned by `file-attributes'. -This is a string of ten letters or dashes as in ls -l." - (nth 8 attributes)))) - -;; `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.") - -(defsubst tramp-compat-file-missing (vec file) - "Emit the `file-missing' error." - (if (get 'file-missing 'error-conditions) - (tramp-error vec tramp-file-missing file) - (tramp-error vec tramp-file-missing "No such file or directory: %s" file))) - -;; `file-local-name', `file-name-quoted-p', `file-name-quote' and -;; `file-name-unquote' are introduced in Emacs 26.1. -(defalias 'tramp-compat-file-local-name - (if (fboundp 'file-local-name) - #'file-local-name - (lambda (name) - "Return the local name component of NAME. -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', `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) - (equal (tramp-compat-funcall 'func-arity #'file-name-quoted-p) '(1 . 2))) + (if (equal (func-arity #'file-name-quoted-p) '(1 . 2)) #'file-name-quoted-p (lambda (name &optional top) "Whether NAME is quoted with prefix \"/:\". If NAME is a remote file name and TOP is nil, check the local part of NAME." (let ((file-name-handler-alist (unless top file-name-handler-alist))) - (string-prefix-p "/:" (tramp-compat-file-local-name name)))))) + (string-prefix-p "/:" (file-local-name name)))))) (defalias 'tramp-compat-file-name-quote - (if (and - (fboundp 'file-name-quote) - (equal (tramp-compat-funcall 'func-arity #'file-name-quote) '(1 . 2))) + (if (equal (func-arity #'file-name-quote) '(1 . 2)) #'file-name-quote (lambda (name &optional top) "Add the quotation prefix \"/:\" to file NAME. @@ -217,20 +96,17 @@ If NAME is a remote file name and TOP is nil, the local part of NAME is quoted." (let ((file-name-handler-alist (unless top file-name-handler-alist))) (if (tramp-compat-file-name-quoted-p name top) name - (concat - (file-remote-p name) "/:" (tramp-compat-file-local-name name))))))) + (concat (file-remote-p name) "/:" (file-local-name name))))))) (defalias 'tramp-compat-file-name-unquote - (if (and - (fboundp 'file-name-unquote) - (equal (tramp-compat-funcall 'func-arity #'file-name-unquote) '(1 . 2))) + (if (equal (func-arity #'file-name-unquote) '(1 . 2)) #'file-name-unquote (lambda (name &optional top) "Remove quotation prefix \"/:\" from file NAME. If NAME is a remote file name and TOP is nil, the local part of NAME is unquoted." (let* ((file-name-handler-alist (unless top file-name-handler-alist)) - (localname (tramp-compat-file-local-name name))) + (localname (file-local-name name))) (when (tramp-compat-file-name-quoted-p localname top) (setq localname (if (= (length localname) 2) "/" (substring localname 2)))) @@ -288,8 +164,7 @@ A nil value for either argument stands for the current time." ;; `progress-reporter-update' got argument SUFFIX in Emacs 27.1. (defalias 'tramp-compat-progress-reporter-update - (if (equal (tramp-compat-funcall 'func-arity #'progress-reporter-update) - '(1 . 3)) + (if (equal (func-arity #'progress-reporter-update) '(1 . 3)) #'progress-reporter-update (lambda (reporter &optional value _suffix) (progress-reporter-update reporter value)))) @@ -306,19 +181,19 @@ CONDITION can also be a list of error conditions." ;; `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)) + (if (equal (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)) + (if (equal (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)) + (if (equal (func-arity #'set-file-times) '(1 . 3)) #'set-file-times (lambda (filename &optional timestamp _flag) (set-file-times filename timestamp)))) @@ -326,14 +201,13 @@ CONDITION can also be a list of error conditions." ;; `directory-files' and `directory-files-and-attributes' got argument ;; COUNT in Emacs 28.1. (defalias 'tramp-compat-directory-files - (if (equal (tramp-compat-funcall 'func-arity #'directory-files) '(1 . 5)) + (if (equal (func-arity #'directory-files) '(1 . 5)) #'directory-files (lambda (directory &optional full match nosort _count) (directory-files directory full match nosort)))) (defalias 'tramp-compat-directory-files-and-attributes - (if (equal (tramp-compat-funcall 'func-arity #'directory-files-and-attributes) - '(1 . 6)) + (if (equal (func-arity #'directory-files-and-attributes) '(1 . 6)) #'directory-files-and-attributes (lambda (directory &optional full match nosort id-format _count) (directory-files-and-attributes directory full match nosort id-format)))) @@ -410,8 +284,6 @@ CONDITION can also be a list of error conditions." ;;; TODO: ;; -;; * `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. ;; diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el index 5def3a4137c..4ff8e6bbf12 100644 --- a/lisp/net/tramp-crypt.el +++ b/lisp/net/tramp-crypt.el @@ -157,7 +157,8 @@ If NAME doesn't belong to a crypted remote directory, retun nil." ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-crypt-file-name-handler-alist - '((access-file . tramp-crypt-handle-access-file) + '(;; `abbreviate-file-name' performed by default handler. + (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) @@ -294,8 +295,8 @@ arguments to pass to the OPERATION." (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)) + (locate-user-emacs-file + (concat "tramp-" (tramp-file-name-host vec) tramp-crypt-encfs-config)))) (defun tramp-crypt-maybe-open-connection (vec) "Maybe open a connection VEC. @@ -485,6 +486,7 @@ See `tramp-crypt-do-encrypt-or-decrypt-file'." 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." + ;; (declare (completion tramp-crypt-command-completion-p)) (interactive "DRemote directory name: ") (unless tramp-crypt-enabled (tramp-user-error nil "Feature is not enabled.")) @@ -596,7 +598,7 @@ absolute file names." (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing 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) @@ -698,7 +700,7 @@ absolute file names." (directory &optional full match nosort count) "Like `directory-files' for Tramp files." (unless (file-exists-p directory) - (tramp-compat-file-missing (tramp-dissect-file-name directory) directory)) + (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) (when (file-directory-p directory) (setq directory (file-name-as-directory (expand-file-name directory))) (let* (tramp-crypt-enabled diff --git a/lisp/net/tramp-ftp.el b/lisp/net/tramp-ftp.el index 11ccdc8a4c9..f78c08ec415 100644 --- a/lisp/net/tramp-ftp.el +++ b/lisp/net/tramp-ftp.el @@ -175,11 +175,10 @@ pass to the OPERATION." ;; 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-ftp-file-name-p (filename) - "Check if it's a FILENAME that should be forwarded to Ange-FTP." - (and (tramp-tramp-file-p filename) - (string= (tramp-file-name-method (tramp-dissect-file-name filename)) - tramp-ftp-method))) +(defsubst tramp-ftp-file-name-p (vec-or-filename) + "Check if it's a VEC-OR-FILENAME that should be forwarded to Ange-FTP." + (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) + (string= (tramp-file-name-method vec) tramp-ftp-method))) ;;;###tramp-autoload (tramp--with-startup diff --git a/lisp/net/tramp-fuse.el b/lisp/net/tramp-fuse.el index c359082dc1e..cb270be68fb 100644 --- a/lisp/net/tramp-fuse.el +++ b/lisp/net/tramp-fuse.el @@ -48,7 +48,7 @@ (directory &optional full match nosort count) "Like `directory-files' for Tramp files." (unless (file-exists-p directory) - (tramp-compat-file-missing (tramp-dissect-file-name directory) directory)) + (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) (when (file-directory-p directory) (setq directory (file-name-as-directory (expand-file-name directory))) (with-parsed-tramp-file-name directory nil @@ -107,12 +107,6 @@ (unless (string-match-p elt item) (throw 'match nil))) (setq result (cons (concat item "/") result)))))))))) -(defun tramp-fuse-handle-file-readable-p (filename) - "Like `file-readable-p' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name filename) nil - (with-tramp-file-property v localname "file-readable-p" - (file-readable-p (tramp-fuse-local-file-name filename))))) - ;; This function isn't used. (defun tramp-fuse-handle-insert-directory (filename switches &optional wildcard full-directory-p) diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index cab912bd93a..6b0299aa097 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -122,10 +122,7 @@ (autoload 'zeroconf-init "zeroconf") (tramp-compat-funcall 'dbus-get-unique-name :system) (tramp-compat-funcall 'dbus-get-unique-name :session) - (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") + (or (tramp-process-running-p "gvfs-fuse-daemon") (tramp-process-running-p "gvfsd-fuse")))) "Non-nil when GVFS is available.") @@ -471,8 +468,7 @@ It has been changed in GVFS 1.14.") ;; </method> ;; </interface> -;; The basic structure for GNOME Online Accounts. We use a list :type, -;; in order to be compatible with Emacs 25. +;; The basic structure for GNOME Online Accounts. (cl-defstruct (tramp-goa-account (:type list) :named) method user host port) ;;;###tramp-autoload @@ -672,8 +668,7 @@ It has been changed in GVFS 1.14.") ;; 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. +;; The basic structure for media devices. (cl-defstruct (tramp-media-device (:type list) :named) method host port) ;; "gvfs-<command>" utilities have been deprecated in GVFS 1.31.1. We @@ -749,7 +744,8 @@ It has been changed in GVFS 1.14.") ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-gvfs-file-name-handler-alist - '((access-file . tramp-handle-access-file) + '((abbreviate-file-name . tramp-handle-abbreviate-file-name) + (access-file . tramp-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) @@ -834,12 +830,11 @@ Operations not mentioned here will be handled by the default Emacs primitives.") ;; 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-gvfs-file-name-p (filename) - "Check if it's a FILENAME handled by the GVFS daemon." - (and (tramp-tramp-file-p filename) - (let ((method - (tramp-file-name-method (tramp-dissect-file-name filename)))) - (and (stringp method) (member method tramp-gvfs-methods))))) +(defsubst tramp-gvfs-file-name-p (vec-or-filename) + "Check if it's a VEC-OR-FILENAME handled by the GVFS daemon." + (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) + (let ((method (tramp-file-name-method vec))) + (and (stringp method) (member method tramp-gvfs-methods))))) ;;;###tramp-autoload (defun tramp-gvfs-file-name-handler (operation &rest args) @@ -1002,7 +997,7 @@ file names." (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing 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) @@ -1102,8 +1097,7 @@ file names." (tramp-skeleton-delete-directory directory recursive trash (if (and recursive (not (file-symlink-p directory))) (mapc (lambda (file) - (if (eq t (tramp-compat-file-attribute-type - (file-attributes file))) + (if (eq t (file-attribute-type (file-attributes file))) (delete-directory file recursive) (delete-file file))) (directory-files @@ -1155,15 +1149,12 @@ file names." (make-tramp-file-name :method method :user user :domain domain :host host :port port :localname "/" :hop hop))) - (setq localname - (replace-match - (tramp-get-connection-property v "default-location" "~") - nil t localname 1))) - ;; Tilde expansion is not possible. - (when (string-match-p "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) - (tramp-error - v 'file-error - "Cannot expand tilde in file `%s'" name)) + (unless (string-empty-p + (tramp-get-connection-property v "default-location" "")) + (setq localname + (replace-match + (tramp-get-connection-property v "default-location" "~") + nil t localname 1)))) (unless (tramp-run-real-handler #'file-name-absolute-p (list localname)) (setq localname (concat "/" localname))) ;; We do not pass "/..". @@ -1178,10 +1169,12 @@ file names." ;; Do not keep "/..". (when (string-match-p "^/\\.\\.?$" localname) (setq localname "/")) - ;; No tilde characters in file name, do normal - ;; `expand-file-name' (this does "/./" and "/../"). + ;; Do normal `expand-file-name' (this does "/./" and "/../"), + ;; unless there are tilde characters in file name. (tramp-make-tramp-file-name - v (tramp-run-real-handler #'expand-file-name (list localname)))))) + v (if (string-match-p "\\`~" localname) + localname + (tramp-run-real-handler #'expand-file-name (list localname))))))) (defun tramp-gvfs-get-directory-attributes (directory) "Return GVFS attributes association list of all files in DIRECTORY." @@ -1463,7 +1456,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." `file-notify' events." (let* ((events (process-get proc 'events)) (rest-string (process-get proc 'rest-string)) - (dd (with-current-buffer (process-buffer proc) default-directory)) + (dd (tramp-get-default-directory (process-buffer proc))) (ddu (regexp-quote (tramp-gvfs-url-file-name dd)))) (when rest-string (tramp-message proc 10 "Previous string:\n%s" rest-string)) @@ -1528,11 +1521,11 @@ If FILE-SYSTEM is non-nil, return file system attributes." (size (cdr (assoc "filesystem::size" attr))) (used (cdr (assoc "filesystem::used" attr))) (free (cdr (assoc "filesystem::free" attr)))) - (when (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")))))))) + (when (or size free) + (list (and size (string-to-number size)) + (and free (string-to-number free)) + (and size used + (- (string-to-number size) (string-to-number used)))))))) (defun tramp-gvfs-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." @@ -1602,7 +1595,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." "%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) + nil time))))) (defun tramp-gvfs-handle-get-remote-uid (vec id-format) @@ -1614,9 +1607,8 @@ ID-FORMAT valid values are `string' and `integer'." (tramp-get-connection-property (tramp-get-process vec) "share" (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))))) + (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. @@ -1625,9 +1617,8 @@ ID-FORMAT valid values are `string' and `integer'." (tramp-get-connection-property (tramp-get-process vec) "share" (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)))) + (file-attribute-group-id + (file-attributes (tramp-make-tramp-file-name vec localname) id-format)))) (defun tramp-gvfs-handle-set-file-uid-gid (filename &optional uid gid) "Like `tramp-set-file-uid-gid' for Tramp files." @@ -1865,9 +1856,9 @@ Their full names are \"org.gtk.vfs.MountTracker.mounted\" and host (tramp-file-name-host v) port (tramp-file-name-port v))))) (when (member method tramp-gvfs-methods) - (let ((v (make-tramp-file-name - :method method :user user :domain domain - :host host :port port))) + (let ((v (make-tramp-file-name + :method method :user user :domain domain + :host host :port port))) (tramp-message v 6 "%s %s" signal-name (tramp-gvfs-stringify-dbus-message mount-info)) @@ -2134,9 +2125,6 @@ connection if a previous connection has died for some reason." (process-put p 'vector vec) (set-process-query-on-exit-flag p nil) - ;; Mark process for filelock. - (tramp-set-connection-property p "lock-pid" (truncate (time-to-seconds))) - ;; Set connection-local variables. (tramp-set-connection-local-variables vec))) diff --git a/lisp/net/tramp-integration.el b/lisp/net/tramp-integration.el index 17264193fd6..238abd34230 100644 --- a/lisp/net/tramp-integration.el +++ b/lisp/net/tramp-integration.el @@ -85,13 +85,6 @@ special handling of `substitute-in-file-name'." "An overlay covering the shadowed part of the filename." (format "[^%s/~]*\\(/\\|~\\)" tramp-postfix-host-format)) -;; Package rfn-eshadow is preloaded in Emacs, but for some reason, -;; it only did (defvar rfn-eshadow-overlay) without giving it a global -;; value, so it was only declared as dynamically-scoped within the -;; rfn-eshadow.el file. This is now fixed in Emacs>26.1 but we still need -;; this defvar here for older releases. -(defvar rfn-eshadow-overlay) - (defun tramp-rfn-eshadow-update-overlay () "Update `rfn-eshadow-overlay' to cover shadowed part of minibuffer input. This is intended to be used as a minibuffer `post-command-hook' for @@ -281,22 +274,18 @@ NAME must be equal to `tramp-current-connection'." (remove-hook 'compilation-start-hook #'tramp-compile-disable-ssh-controlmaster-options)))) -;;; Default connection-local variables for Tramp: -;; `connection-local-set-profile-variables' and -;; `connection-local-set-profiles' exists since Emacs 26.1. +;;; Default connection-local variables for Tramp. (defconst tramp-connection-local-default-system-variables '((path-separator . ":") (null-device . "/dev/null")) "Default connection-local system variables for remote connections.") -(tramp-compat-funcall - 'connection-local-set-profile-variables +(connection-local-set-profile-variables 'tramp-connection-local-default-system-profile tramp-connection-local-default-system-variables) -(tramp-compat-funcall - 'connection-local-set-profiles +(connection-local-set-profiles '(:application tramp) 'tramp-connection-local-default-system-profile) @@ -305,14 +294,12 @@ NAME must be equal to `tramp-current-connection'." (shell-command-switch . "-c")) "Default connection-local shell variables for remote connections.") -(tramp-compat-funcall - 'connection-local-set-profile-variables +(connection-local-set-profile-variables 'tramp-connection-local-default-shell-profile tramp-connection-local-default-shell-variables) (with-eval-after-load 'shell - (tramp-compat-funcall - 'connection-local-set-profiles + (connection-local-set-profiles '(:application tramp) 'tramp-connection-local-default-shell-profile)) diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index 812e06f3f11..71ec2607a30 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -71,7 +71,8 @@ ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-rclone-file-name-handler-alist - '((access-file . tramp-handle-access-file) + '(;; `abbreviate-file-name' performed by default handler. + (access-file . tramp-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) @@ -110,7 +111,7 @@ (file-notify-rm-watch . ignore) (file-notify-valid-p . ignore) (file-ownership-preserved-p . ignore) - (file-readable-p . tramp-fuse-handle-file-readable-p) + (file-readable-p . tramp-rclone-handle-file-readable-p) (file-regular-p . tramp-handle-file-regular-p) (file-remote-p . tramp-handle-file-remote-p) (file-selinux-context . tramp-handle-file-selinux-context) @@ -156,11 +157,10 @@ Operations not mentioned here will be handled by the default Emacs primitives.") ;; 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-rclone-file-name-p (filename) - "Check if it's a FILENAME for rclone." - (and (tramp-tramp-file-p filename) - (string= (tramp-file-name-method (tramp-dissect-file-name filename)) - tramp-rclone-method))) +(defsubst tramp-rclone-file-name-p (vec-or-filename) + "Check if it's a VEC-OR-FILENAME for rclone." + (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) + (string= (tramp-file-name-method vec) tramp-rclone-method))) ;;;###tramp-autoload (defun tramp-rclone-file-name-handler (operation &rest args) @@ -223,7 +223,7 @@ file names." (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing 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) @@ -280,6 +280,12 @@ file names." (list filename newname ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes)))) +(defun tramp-rclone-handle-file-readable-p (filename) + "Like `file-readable-p' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name filename) nil + (with-tramp-file-property v localname "file-readable-p" + (file-readable-p (tramp-fuse-local-file-name filename))))) + (defun tramp-rclone-handle-file-system-info (filename) "Like `file-system-info' for Tramp files." (ignore-errors @@ -362,10 +368,6 @@ connection if a previous connection has died for some reason." (process-put p 'vector vec) (set-process-query-on-exit-flag p nil) - ;; Mark process for filelock. - (tramp-set-connection-property - p "lock-pid" (truncate (time-to-seconds))) - ;; Set connection-local variables. (tramp-set-connection-local-variables vec))) diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 21217381f14..72eb63d3929 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -34,6 +34,8 @@ (eval-when-compile (require 'cl-lib)) (require 'tramp) +;; `dired-*' declarations can be removed, starting with Emacs 29.1. +(declare-function dired-compress-file "dired-aux") (declare-function dired-remove-file "dired-aux") (defvar dired-compress-file-suffixes) (defvar process-file-return-signal-string) @@ -940,7 +942,8 @@ Format specifiers \"%s\" are replaced before the script is used.") ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-sh-file-name-handler-alist - '((access-file . tramp-handle-access-file) + '((abbreviate-file-name . tramp-handle-abbreviate-file-name) + (access-file . tramp-handle-access-file) (add-name-to-file . tramp-sh-handle-add-name-to-file) ;; `byte-compiler-base-file-name' performed by default handler. (copy-directory . tramp-sh-handle-copy-directory) @@ -952,6 +955,8 @@ Format specifiers \"%s\" are replaced before the script is used.") (directory-files . tramp-handle-directory-files) (directory-files-and-attributes . tramp-sh-handle-directory-files-and-attributes) + ;; Starting with Emacs 29.1, `dired-compress-file' performed by + ;; default handler. (dired-compress-file . tramp-sh-handle-dired-compress-file) (dired-uncache . tramp-handle-dired-uncache) (exec-path . tramp-sh-handle-exec-path) @@ -1334,7 +1339,7 @@ component is used as the target of the symlink." (with-parsed-tramp-file-name f nil (let* ((remote-file-name-inhibit-cache t) (attr (file-attributes f)) - (modtime (or (tramp-compat-file-attribute-modification-time attr) + (modtime (or (file-attribute-modification-time attr) tramp-time-doesnt-exist))) (setq coding-system-used last-coding-system-used) (if (not (tramp-compat-time-equal-p modtime tramp-time-dont-know)) @@ -1372,7 +1377,7 @@ of." (with-parsed-tramp-file-name f nil (let* ((remote-file-name-inhibit-cache t) (attr (file-attributes f)) - (modtime (tramp-compat-file-attribute-modification-time attr)) + (modtime (file-attribute-modification-time attr)) (mt (visited-file-modtime))) (cond @@ -1424,7 +1429,7 @@ of." (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) + nil time))) (tramp-send-command-and-check v (format @@ -1620,14 +1625,14 @@ ID-FORMAT valid values are `string' and `integer'." ;; information would be lost by an (attempted) delete and create. (or (null attributes) (and - (= (tramp-compat-file-attribute-user-id attributes) + (= (file-attribute-user-id attributes) (tramp-get-remote-uid v 'integer)) (or (not group) ;; On BSD-derived systems files always inherit the ;; parent directory's group, so skip the group-gid ;; test. (tramp-check-remote-uname v "BSD\\|DragonFly\\|Darwin") - (= (tramp-compat-file-attribute-group-id attributes) + (= (file-attribute-group-id attributes) (tramp-get-remote-gid v 'integer))))))))) ;; Directory listings. @@ -1637,8 +1642,7 @@ ID-FORMAT valid values are `string' and `integer'." "Like `directory-files-and-attributes' for Tramp files." (unless id-format (setq id-format 'integer)) (unless (file-exists-p directory) - (tramp-compat-file-missing - (tramp-dissect-file-name directory) directory)) + (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) (when (file-directory-p directory) (setq directory (expand-file-name directory)) (let* ((temp @@ -1858,7 +1862,7 @@ ID-FORMAT valid values are `string' and `integer'." target) (with-parsed-tramp-file-name (if t1 dirname newname) nil (unless (file-exists-p dirname) - (tramp-compat-file-missing v dirname)) + (tramp-error v 'file-missing dirname)) ;; `copy-directory-create-symlink' exists since Emacs 28.1. (if (and (bound-and-true-p copy-directory-create-symlink) @@ -1952,7 +1956,7 @@ file names." (let ((t1 (tramp-tramp-file-p filename)) (t2 (tramp-tramp-file-p newname)) - (length (tramp-compat-file-attribute-size + (length (file-attribute-size (file-attributes (file-truename filename)))) (attributes (and preserve-extended-attributes (file-extended-attributes filename))) @@ -1960,7 +1964,7 @@ file names." (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing 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) @@ -2052,7 +2056,7 @@ KEEP-DATE is non-nil if NEWNAME should have the same timestamp as FILENAME." ;; Check, whether file is too large. Emacs checks in `insert-file-1' ;; and `find-file-noselect', but that's not called here. (abort-if-file-too-large - (tramp-compat-file-attribute-size (file-attributes (file-truename filename))) + (file-attribute-size (file-attributes (file-truename filename))) (symbol-name op) filename) ;; We must disable multibyte, because binary data shall not be ;; converted. We don't want the target file to be compressed, so we @@ -2074,8 +2078,7 @@ KEEP-DATE is non-nil if NEWNAME should have the same timestamp as FILENAME." (when keep-date (tramp-compat-set-file-times newname - (tramp-compat-file-attribute-modification-time - (file-attributes filename)) + (file-attribute-modification-time (file-attributes filename)) (unless ok-if-already-exists 'nofollow))) ;; Set the mode. (set-file-modes newname (tramp-default-file-modes filename)) @@ -2094,7 +2097,7 @@ as FILENAME. PRESERVE-UID-GID, when non-nil, instructs to keep the uid and gid from FILENAME." (let ((t1 (tramp-tramp-file-p filename)) (t2 (tramp-tramp-file-p newname)) - (file-times (tramp-compat-file-attribute-modification-time + (file-times (file-attribute-modification-time (file-attributes filename))) (file-modes (tramp-default-file-modes filename))) (with-parsed-tramp-file-name (if t1 filename newname) nil @@ -2419,8 +2422,7 @@ The method used must be an out-of-band method." (when (and keep-date (not copy-keep-date)) (tramp-compat-set-file-times newname - (tramp-compat-file-attribute-modification-time - (file-attributes filename)) + (file-attribute-modification-time (file-attributes filename)) (unless ok-if-already-exists 'nofollow))) ;; Set the mode. @@ -2476,42 +2478,58 @@ The method used must be an out-of-band method." (defun tramp-sh-handle-dired-compress-file (file) "Like `dired-compress-file' for Tramp files." - ;; Code stolen mainly from dired-aux.el. - (with-parsed-tramp-file-name file nil - (tramp-flush-file-properties v localname) - (let ((suffixes dired-compress-file-suffixes) - suffix) - ;; See if any suffix rule matches this file name. - (while suffixes - (let (case-fold-search) - (if (string-match-p (car (car suffixes)) localname) - (setq suffix (car suffixes) suffixes nil)) - (setq suffixes (cdr suffixes)))) - - (cond ((file-symlink-p file) nil) - ((and suffix (nth 2 suffix)) - ;; We found an uncompression rule. - (with-tramp-progress-reporter - v 0 (format "Uncompressing %s" file) - (when (tramp-send-command-and-check - v (concat (nth 2 suffix) " " - (tramp-shell-quote-argument localname))) - (dired-remove-file file) - (string-match (car suffix) file) - (concat (substring file 0 (match-beginning 0)))))) - (t - ;; We don't recognize the file as compressed, so compress it. - ;; Try gzip. - (with-tramp-progress-reporter v 0 (format "Compressing %s" file) - (when (tramp-send-command-and-check - v (concat "gzip -f " - (tramp-shell-quote-argument localname))) - (dired-remove-file file) - (cond ((file-exists-p (concat file ".gz")) - (concat file ".gz")) - ((file-exists-p (concat file ".z")) - (concat file ".z")) - (t nil))))))))) + ;; Starting with Emacs 29.1, `dired-compress-file' is performed by + ;; default handler. + (if (>= emacs-major-version 29) + (tramp-run-real-handler #'dired-compress-file (list file)) + ;; Code stolen mainly from dired-aux.el. + (with-parsed-tramp-file-name file nil + (tramp-flush-file-properties v localname) + (let ((suffixes dired-compress-file-suffixes) + suffix) + ;; See if any suffix rule matches this file name. + (while suffixes + (let (case-fold-search) + (if (string-match-p (car (car suffixes)) localname) + (setq suffix (car suffixes) suffixes nil)) + (setq suffixes (cdr suffixes)))) + + (cond ((file-symlink-p file) nil) + ((and suffix (nth 2 suffix)) + ;; We found an uncompression rule. + (with-tramp-progress-reporter + v 0 (format "Uncompressing %s" file) + (when (tramp-send-command-and-check + v (if (string-match-p "%[io]" (nth 2 suffix)) + (replace-regexp-in-string + "%i" (tramp-shell-quote-argument localname) + (nth 2 suffix)) + (concat (nth 2 suffix) " " + (tramp-shell-quote-argument localname)))) + (unless (string-match-p "\\.tar\\.gz" file) + (dired-remove-file file)) + (string-match (car suffix) file) + (concat (substring file 0 (match-beginning 0)))))) + (t + ;; We don't recognize the file as compressed, so + ;; compress it. Try gzip. + (with-tramp-progress-reporter v 0 (format "Compressing %s" file) + (when (tramp-send-command-and-check + v (if (file-directory-p file) + (format "tar -cf - %s | gzip -c9 > %s.tar.gz" + (tramp-shell-quote-argument + (file-name-nondirectory localname)) + (tramp-shell-quote-argument localname)) + (concat "gzip -f " + (tramp-shell-quote-argument localname)))) + (unless (file-directory-p file) + (dired-remove-file file)) + (catch 'found nil + (dolist (target (mapcar (lambda (suffix) + (concat file suffix)) + '(".tar.gz" ".gz" ".z"))) + (when (file-exists-p target) + (throw 'found target)))))))))))) (defun tramp-sh-handle-insert-directory (filename switches &optional wildcard full-directory-p) @@ -2583,7 +2601,7 @@ The method used must be an out-of-band method." ;; We cannot use `insert-buffer-substring' because the Tramp ;; buffer changes its contents before insertion due to calling ;; `expand-file-name' and alike. - (insert (with-current-buffer (tramp-get-buffer v) (buffer-string))) + (insert (tramp-get-buffer-string (tramp-get-buffer v))) ;; We must enable unibyte strings, because the "--dired" ;; output counts in bytes. @@ -2693,11 +2711,11 @@ the result will be a local, non-Tramp, file name." ;; Unless NAME is absolute, concat DIR and NAME. (unless (file-name-absolute-p name) (setq name (tramp-compat-file-name-concat dir name))) - ;; If connection is not established yet, run the real handler. - (if (not (tramp-connectable-p name)) - (tramp-run-real-handler #'expand-file-name (list name nil)) - ;; Dissect NAME. - (with-parsed-tramp-file-name name nil + ;; Dissect NAME. + (with-parsed-tramp-file-name name nil + ;; If connection is not established yet, run the real handler. + (if (not (tramp-connectable-p v)) + (tramp-run-real-handler #'expand-file-name (list name nil)) (unless (tramp-run-real-handler #'file-name-absolute-p (list localname)) (setq localname (concat "~/" localname))) ;; Tilde expansion if necessary. This needs a shell which @@ -3142,8 +3160,7 @@ implementation will be used." (when outbuf (with-current-buffer outbuf (insert - (with-current-buffer (tramp-get-connection-buffer v) - (buffer-string)))) + (tramp-get-buffer-string (tramp-get-connection-buffer v)))) (when (and display (get-buffer-window outbuf t)) (redisplay)))) ;; When the user did interrupt, we should do it also. We use ;; return code -1 as marker. @@ -3187,9 +3204,9 @@ implementation will be used." "Like `file-local-copy' for Tramp files." (with-parsed-tramp-file-name filename nil (unless (file-exists-p (file-truename filename)) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) - (let* ((size (tramp-compat-file-attribute-size + (let* ((size (file-attribute-size (file-attributes (file-truename filename)))) (rem-enc (tramp-get-inline-coding v "remote-encoding" size)) (loc-dec (tramp-get-inline-coding v "local-decoding" size)) @@ -3276,11 +3293,9 @@ implementation will be used." (tramp-error v 'file-already-exists filename)) (let ((file-locked (eq (file-locked-p lockname) t)) - (uid (or (tramp-compat-file-attribute-user-id - (file-attributes filename 'integer)) + (uid (or (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)) + (gid (or (file-attribute-group-id (file-attributes filename 'integer)) (tramp-get-remote-gid v 'integer)))) ;; Lock file. @@ -3359,8 +3374,7 @@ implementation will be used." ;; specified. However, if the method _also_ specifies an ;; encoding function, then that is used for encoding the ;; contents of the tmp file. - (let* ((size (tramp-compat-file-attribute-size - (file-attributes tmpfile))) + (let* ((size (file-attribute-size (file-attributes tmpfile))) (rem-dec (tramp-get-inline-coding v "remote-decoding" size)) (loc-enc (tramp-get-inline-coding v "local-encoding" size))) (cond @@ -3460,8 +3474,7 @@ implementation will be used." (not (string-equal (buffer-string) - (with-current-buffer (tramp-get-buffer v) - (buffer-string)))) + (tramp-get-buffer-string (tramp-get-buffer v)))) (tramp-error v 'file-error (concat "Couldn't write region to `%s'," @@ -3495,10 +3508,10 @@ implementation will be used." ;; We must pass modtime explicitly, because FILENAME can ;; be different from (buffer-file-name), f.e. if ;; `file-precious-flag' is set. - (or (tramp-compat-file-attribute-modification-time file-attr) + (or (file-attribute-modification-time file-attr) (current-time))) - (when (and (= (tramp-compat-file-attribute-user-id file-attr) uid) - (= (tramp-compat-file-attribute-group-id file-attr) gid)) + (when (and (= (file-attribute-user-id file-attr) uid) + (= (file-attribute-group-id file-attr) gid)) (setq need-chown nil)))) ;; Set the ownership. @@ -3755,8 +3768,7 @@ Fall back to normal file name handler if no Tramp handler exists." "Read output from \"gio monitor\" and add corresponding `file-notify' events." (let ((events (process-get proc 'events)) (remote-prefix - (with-current-buffer (process-buffer proc) - (file-remote-p default-directory))) + (file-remote-p (tramp-get-default-directory (process-buffer proc)))) (rest-string (process-get proc 'rest-string)) pos) (when rest-string @@ -6011,5 +6023,8 @@ function cell is returned to be applied on a buffer." ;; be to stipulate, as a directory or connection-local variable, an ;; additional rc file on the remote machine that is sourced every ;; time Tramp connects. <https://emacs.stackexchange.com/questions/62306> +;; +;; * Support hostname canonicalization in ~/.ssh/config. +;; <https://stackoverflow.com/questions/70205232/> ;;; tramp-sh.el ends here diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 49f049d3f34..34203076b24 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -222,7 +222,8 @@ See `tramp-actions-before-shell' for more info.") ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-smb-file-name-handler-alist - '((access-file . tramp-handle-access-file) + '((abbreviate-file-name . tramp-handle-abbreviate-file-name) + (access-file . tramp-handle-access-file) (add-name-to-file . tramp-smb-handle-add-name-to-file) ;; `byte-compiler-base-file-name' performed by default handler. (copy-directory . tramp-smb-handle-copy-directory) @@ -330,11 +331,10 @@ This can be used to disable echo etc." ;; 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-smb-file-name-p (filename) - "Check if it's a FILENAME for SMB servers." - (and (tramp-tramp-file-p filename) - (string= (tramp-file-name-method (tramp-dissect-file-name filename)) - tramp-smb-method))) +(defsubst tramp-smb-file-name-p (vec-or-filename) + "Check if it's a VEC-OR-FILENAME for SMB servers." + (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) + (string= (tramp-file-name-method vec) tramp-smb-method))) ;;;###tramp-autoload (defun tramp-smb-file-name-handler (operation &rest args) @@ -419,7 +419,7 @@ arguments to pass to the OPERATION." target) (with-parsed-tramp-file-name (if t1 dirname newname) nil (unless (file-exists-p dirname) - (tramp-compat-file-missing v dirname)) + (tramp-error v 'file-missing dirname)) ;; `copy-directory-create-symlink' exists since Emacs 28.1. (if (and (bound-and-true-p copy-directory-create-symlink) @@ -442,7 +442,7 @@ arguments to pass to the OPERATION." (with-tramp-progress-reporter v 0 (format "Copying %s to %s" dirname newname) (unless (file-exists-p dirname) - (tramp-compat-file-missing v dirname)) + (tramp-error v 'file-missing dirname)) (when (and (file-directory-p newname) (not (directory-name-p newname))) (tramp-error v 'file-already-exists newname)) @@ -567,8 +567,7 @@ arguments to pass to the OPERATION." (when keep-date (tramp-compat-set-file-times newname - (tramp-compat-file-attribute-modification-time - (file-attributes dirname)) + (file-attribute-modification-time (file-attributes dirname)) (unless ok-if-already-exists 'nofollow))) ;; Set the mode. @@ -602,10 +601,10 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (copy-directory filename newname keep-date 'parents 'copy-contents) (unless (file-exists-p filename) - (tramp-compat-file-missing + (tramp-error (tramp-dissect-file-name (if (tramp-tramp-file-p filename) filename newname)) - filename)) + 'file-missing filename)) (if-let ((tmpfile (file-local-copy filename))) ;; Remote filename. @@ -645,8 +644,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when keep-date (tramp-compat-set-file-times newname - (tramp-compat-file-attribute-modification-time - (file-attributes filename)) + (file-attribute-modification-time (file-attributes filename)) (unless ok-if-already-exists 'nofollow))))) (defun tramp-smb-handle-delete-directory (directory &optional recursive trash) @@ -706,7 +704,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (directory &optional full match nosort count) "Like `directory-files' for Tramp files." (unless (file-exists-p directory) - (tramp-compat-file-missing (tramp-dissect-file-name directory) directory)) + (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) (let ((result (mapcar #'directory-file-name (file-name-all-completions "" directory)))) ;; Discriminate with regexp. @@ -976,7 +974,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." "Like `file-local-copy' for Tramp files." (with-parsed-tramp-file-name (file-truename filename) nil (unless (file-exists-p (file-truename filename)) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (let ((tmpfile (tramp-compat-make-temp-file filename))) (with-tramp-progress-reporter v 3 (format "Fetching %s to tmp file %s" filename tmpfile) @@ -1041,8 +1039,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." "Like `file-writable-p' for Tramp files." (if (file-exists-p filename) (tramp-compat-string-search - "w" - (or (tramp-compat-file-attribute-modes (file-attributes filename)) "")) + "w" (or (file-attribute-modes (file-attributes filename)) "")) (let ((dir (file-name-directory filename))) (and (file-exists-p dir) (file-writable-p dir))))) @@ -1145,11 +1142,11 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (insert (format "%10s %3d %-8s %-8s %8s %s " - (or (tramp-compat-file-attribute-modes attr) (nth 1 x)) - (or (tramp-compat-file-attribute-link-number attr) 1) - (or (tramp-compat-file-attribute-user-id attr) "nobody") - (or (tramp-compat-file-attribute-group-id attr) "nogroup") - (or (tramp-compat-file-attribute-size attr) (nth 2 x)) + (or (file-attribute-modes attr) (nth 1 x)) + (or (file-attribute-link-number attr) 1) + (or (file-attribute-user-id attr) "nobody") + (or (file-attribute-group-id attr) "nogroup") + (or (file-attribute-size attr) (nth 2 x)) (format-time-string (if (time-less-p ;; Half a year. @@ -1171,8 +1168,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Insert symlink. (when (and (tramp-compat-string-search "l" switches) - (stringp (tramp-compat-file-attribute-type attr))) - (insert " -> " (tramp-compat-file-attribute-type attr)))) + (stringp (file-attribute-type attr))) + (insert " -> " (file-attribute-type attr)))) (insert "\n") (beginning-of-line))) @@ -1394,7 +1391,7 @@ component is used as the target of the symlink." (with-parsed-tramp-file-name (if (tramp-tramp-file-p filename) filename newname) nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing 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) @@ -1439,9 +1436,9 @@ component is used as the target of the symlink." (unless (process-live-p proc) ;; Accept pending output. (while (tramp-accept-process-output proc)) - (with-current-buffer (tramp-get-connection-buffer vec) - (tramp-message vec 10 "\n%s" (buffer-string)) - (throw 'tramp-action 'ok)))) + (tramp-message + vec 10 "\n%s" (tramp-get-buffer-string (tramp-get-connection-buffer vec))) + (throw 'tramp-action 'ok))) (defun tramp-smb-handle-set-file-acl (filename acl-string) "Like `set-file-acl' for Tramp files." @@ -1647,8 +1644,7 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." ;; Set file modification time. (when (or (eq visit t) (stringp visit)) (set-visited-file-modtime - (or (tramp-compat-file-attribute-modification-time - (file-attributes filename)) + (or (file-attribute-modification-time (file-attributes filename)) (current-time)))) ;; Unlock file. diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el index 1886031dec7..ef1f302546a 100644 --- a/lisp/net/tramp-sshfs.el +++ b/lisp/net/tramp-sshfs.el @@ -71,7 +71,8 @@ ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-sshfs-file-name-handler-alist - '((access-file . tramp-handle-access-file) + '(;; `abbreviate-file-name' performed by default handler. + (access-file . tramp-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) @@ -156,11 +157,10 @@ Operations not mentioned here will be handled by the default Emacs primitives.") ;; 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-sshfs-file-name-p (filename) - "Check if it's a FILENAME for sshfs." - (and (tramp-tramp-file-p filename) - (string= (tramp-file-name-method (tramp-dissect-file-name filename)) - tramp-sshfs-method))) +(defsubst tramp-sshfs-file-name-p (vec-or-filename) + "Check if it's a VEC-OR-FILENAME for sshfs." + (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) + (string= (tramp-file-name-method vec) tramp-sshfs-method))) ;;;###tramp-autoload (defun tramp-sshfs-file-name-handler (operation &rest args) @@ -345,9 +345,6 @@ connection if a previous connection has died for some reason." (process-put p 'vector vec) (set-process-query-on-exit-flag p nil) - ;; Mark process for filelock. - (tramp-set-connection-property p "lock-pid" (truncate (time-to-seconds))) - ;; Set connection-local variables. (tramp-set-connection-local-variables vec))) diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index 845f31d09b1..88e8c43534b 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -63,7 +63,8 @@ See `tramp-actions-before-shell' for more info.") ;;;###tramp-autoload (defconst tramp-sudoedit-file-name-handler-alist - '((access-file . tramp-handle-access-file) + '((abbreviate-file-name . tramp-handle-abbreviate-file-name) + (access-file . tramp-handle-access-file) (add-name-to-file . tramp-sudoedit-handle-add-name-to-file) (byte-compiler-base-file-name . ignore) (copy-directory . tramp-handle-copy-directory) @@ -148,11 +149,10 @@ See `tramp-actions-before-shell' for more info.") ;; 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-sudoedit-file-name-p (filename) - "Check if it's a FILENAME for SUDOEDIT." - (and (tramp-tramp-file-p filename) - (string= (tramp-file-name-method (tramp-dissect-file-name filename)) - tramp-sudoedit-method))) +(defsubst tramp-sudoedit-file-name-p (vec-or-filename) + "Check if it's a VEC-OR-FILENAME for SUDOEDIT." + (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename))) + (string= (tramp-file-name-method vec) tramp-sudoedit-method))) ;;;###tramp-autoload (defun tramp-sudoedit-file-name-handler (operation &rest args) @@ -233,7 +233,7 @@ absolute file names." (let ((t1 (tramp-sudoedit-file-name-p filename)) (t2 (tramp-sudoedit-file-name-p newname)) - (file-times (tramp-compat-file-attribute-modification-time + (file-times (file-attribute-modification-time (file-attributes filename))) (file-modes (tramp-default-file-modes filename)) (attributes (and preserve-extended-attributes @@ -247,7 +247,7 @@ absolute file names." (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing 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) @@ -336,7 +336,7 @@ absolute file names." (if (and delete-by-moving-to-trash trash) (move-file-to-trash filename) (unless (tramp-sudoedit-send-command - v "rm" (tramp-compat-file-name-unquote localname)) + v "rm" "-f" (tramp-compat-file-name-unquote localname)) ;; Propagate the error. (with-current-buffer (tramp-get-connection-buffer v) (goto-char (point-min)) @@ -453,12 +453,13 @@ the result will be a local, non-Tramp, file name." (if (file-directory-p (expand-file-name f directory)) (file-name-as-directory f) f)) - (with-current-buffer (tramp-get-connection-buffer v) - (delq - nil - (mapcar - (lambda (l) (and (not (string-match-p "^[[:space:]]*$" l)) l)) - (split-string (buffer-string) "\n" 'omit))))))))) + (delq + nil + (mapcar + (lambda (l) (and (not (string-match-p "^[[:space:]]*$" l)) l)) + (split-string + (tramp-get-buffer-string (tramp-get-connection-buffer v)) + "\n" 'omit)))))))) (defun tramp-sudoedit-handle-file-readable-p (filename) "Like `file-readable-p' for Tramp files." @@ -534,7 +535,7 @@ the result will be a local, non-Tramp, file name." (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) + nil time))) (tramp-sudoedit-send-command v "env" "TZ=UTC" "touch" "-t" @@ -721,11 +722,9 @@ ID-FORMAT valid values are `string' and `integer'." "Like `write-region' for Tramp files." (setq filename (expand-file-name filename)) (with-parsed-tramp-file-name filename nil - (let* ((uid (or (tramp-compat-file-attribute-user-id - (file-attributes filename 'integer)) + (let* ((uid (or (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)) + (gid (or (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)) @@ -736,10 +735,10 @@ ID-FORMAT valid values are `string' and `integer'." ;; Set the ownership, modes and extended attributes. This is ;; not performed in `tramp-handle-write-region'. - (unless (and (= (tramp-compat-file-attribute-user-id + (unless (and (= (file-attribute-user-id (file-attributes filename 'integer)) uid) - (= (tramp-compat-file-attribute-group-id + (= (file-attribute-group-id (file-attributes filename 'integer)) gid)) (tramp-set-file-uid-gid filename uid gid)) @@ -789,9 +788,6 @@ connection if a previous connection has died for some reason." (process-put p 'vector vec) (set-process-query-on-exit-flag p nil) - ;; Mark process for filelock. - (tramp-set-connection-property p "lock-pid" (truncate (time-to-seconds))) - ;; Set connection-local variables. (tramp-set-connection-local-variables vec) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 740cb23ebee..940e25e04f9 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -751,11 +751,11 @@ The answer will be provided by `tramp-action-process-alive', (defconst tramp-temp-name-prefix "tramp." "Prefix to use for temporary files. -If this is a relative file name (such as \"tramp.\"), it is considered -relative to the directory name returned by the function -`tramp-compat-temporary-file-directory' (which see). It may also be an -absolute file name; don't forget to include a prefix for the filename -part, though.") +If this is a relative file name (such as \"tramp.\"), it is +considered relative to the directory name returned by the +function `temporary-file-directory' (which see). It may also be +an absolute file name; don't forget to include a prefix for the +filename part, though.") (defconst tramp-temp-buffer-name " *tramp temp*" "Buffer name for a temporary buffer. @@ -822,11 +822,10 @@ to be set, depending on VALUE." (tramp-register-file-name-handlers)) ;; Initialize the Tramp syntax variables. We want to override initial -;; value of `tramp-file-name-regexp'. Other Tramp syntax variables -;; must be initialized as well to proper values. We do not call +;; value of `tramp-file-name-regexp'. We do not call ;; `custom-set-variable', this would load Tramp via custom.el. (tramp--with-startup - (tramp-set-syntax 'tramp-syntax (tramp-compat-tramp-syntax))) + (tramp-set-syntax 'tramp-syntax tramp-syntax)) (defun tramp-syntax-values () "Return possible values of `tramp-syntax', a list." @@ -836,9 +835,9 @@ to be set, depending on VALUE." values)) (defun tramp-lookup-syntax (alist) - "Look up a syntax string in ALIST according to `tramp-compat-tramp-syntax'. -Raise an error if `tramp-syntax' is invalid." - (or (cdr (assq (tramp-compat-tramp-syntax) alist)) + "Look up a syntax string in ALIST according to `tramp-syntax'. +Raise an error if it is invalid." + (or (cdr (assq tramp-syntax alist)) (error "Wrong `tramp-syntax' %s" tramp-syntax))) (defconst tramp-prefix-format-alist @@ -1409,8 +1408,7 @@ calling HANDLER.") ;; internal data structure. Convenience functions for internal ;; data structure. -;; The basic structure for remote file names. We use a list :type, -;; in order to be compatible with Emacs 25. +;; The basic structure for remote file names. (cl-defstruct (tramp-file-name (:type list) :named) method user domain host port localname hop) @@ -1522,7 +1520,7 @@ of `process-file', `start-file-process', or `shell-command'." (or (and (tramp-tramp-file-p name) (string-match (nth 0 tramp-file-name-structure) name) (match-string (nth 4 tramp-file-name-structure) name)) - (tramp-compat-file-local-name name))) + (file-local-name name))) ;; The localname can be quoted with "/:". Extract this. (defun tramp-unquote-file-local-name (name) @@ -1669,6 +1667,18 @@ default values are used." (put #'tramp-dissect-file-name 'tramp-suppress-trace t) +(defun tramp-ensure-dissected-file-name (vec-or-filename) + "Return a `tramp-file-name' structure for VEC-OR-FILENAME. + +VEC-OR-FILENAME may be either a string or a `tramp-file-name'. +If it's not a Tramp filename, return nil." + (cond + ((tramp-file-name-p vec-or-filename) vec-or-filename) + ((tramp-tramp-file-p vec-or-filename) + (tramp-dissect-file-name vec-or-filename)))) + +(put #'tramp-ensure-dissected-file-name 'tramp-suppress-trace t) + (defun tramp-dissect-hop-name (name &optional nodefault) "Return a `tramp-file-name' structure of `hop' part of NAME. See `tramp-dissect-file-name' for details." @@ -1839,9 +1849,7 @@ from the default one." If connection-local variables are not supported by this Emacs version, the function does nothing." (with-current-buffer (tramp-get-connection-buffer vec) - ;; `hack-connection-local-variables-apply' exists since Emacs 26.1. - (tramp-compat-funcall - 'hack-connection-local-variables-apply + (hack-connection-local-variables-apply `(:application tramp :protocol ,(tramp-file-name-method vec) :user ,(tramp-file-name-user-domain vec) @@ -1852,14 +1860,27 @@ version, the function does nothing." If connection-local variables are not supported by this Emacs version, the function does nothing." (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 + (hack-connection-local-variables-apply `(:application tramp :protocol ,(file-remote-p default-directory 'method) :user ,(file-remote-p default-directory 'user) :machine ,(file-remote-p default-directory 'host))))) +(defsubst tramp-get-default-directory (buffer) + "Return `default-directory' of BUFFER." + (buffer-local-value 'default-directory buffer)) + +(put #'tramp-get-default-directory 'tramp-suppress-trace t) + +(defsubst tramp-get-buffer-string (&optional buffer) + "Return contents of BUFFER. +If BUFFER is not a buffer or a buffer name, return the contents +of `current-buffer'." + (with-current-buffer (or buffer (current-buffer)) + (substring-no-properties (buffer-string)))) + +(put #'tramp-get-buffer-string 'tramp-suppress-trace t) + (defun tramp-debug-buffer-name (vec) "A name for the debug buffer for VEC." (let ((method (tramp-file-name-method vec)) @@ -1898,29 +1919,55 @@ The outline level is equal to the verbosity of the Tramp message." (put #'tramp-debug-outline-level 'tramp-suppress-trace t) +;; This function takes action since Emacs 28.1, when +;; `read-extended-command-predicate' is set to +;; `command-completion-default-include-p'. +(defun tramp-debug-buffer-command-completion-p (_symbol buffer) + "A predicate for Tramp interactive commands. +They are completed by \"M-x TAB\" only in Tramp debug buffers." + (with-current-buffer buffer + (string-equal (buffer-substring 1 10) ";; Emacs:"))) + +(put #'tramp-debug-buffer-command-completion-p 'tramp-suppress-trace t) + +(defun tramp-setup-debug-buffer () + "Function to setup debug buffers." + ;; (declare (completion tramp-debug-buffer-command-completion-p)) + (interactive) + (set-buffer-file-coding-system 'utf-8) + (setq buffer-undo-list t) + ;; Activate `outline-mode'. This runs `text-mode-hook' and + ;; `outline-mode-hook'. We must prevent that local processes die. + ;; Yes: I've seen `flyspell-mode', which starts "ispell". + ;; `(custom-declare-variable outline-minor-mode-prefix ...)' raises + ;; on error in `(outline-mode)', we don't want to see it in the + ;; traces. + (let ((default-directory tramp-compat-temporary-file-directory)) + (outline-mode)) + (setq-local outline-level 'tramp-debug-outline-level) + (setq-local font-lock-keywords + ;; FIXME: This `(t FOO . BAR)' representation in + ;; `font-lock-keywords' is supposed to be an internal + ;; implementation "detail". Don't abuse it here! + `(t (eval ,tramp-debug-font-lock-keywords t) + ,(eval tramp-debug-font-lock-keywords t))) + ;; Do not edit the debug buffer. + (use-local-map special-mode-map) + ;; For debugging purposes. + (local-set-key "\M-n" 'clone-buffer) + (add-hook 'clone-buffer-hook #'tramp-setup-debug-buffer nil 'local)) + +(put #'tramp-setup-debug-buffer 'tramp-suppress-trace t) + +(function-put + #'tramp-setup-debug-buffer 'completion-predicate + #'tramp-debug-buffer-command-completion-p) + (defun tramp-get-debug-buffer (vec) "Get the debug buffer for VEC." (with-current-buffer (get-buffer-create (tramp-debug-buffer-name vec)) (when (bobp) - (set-buffer-file-coding-system 'utf-8) - (setq buffer-undo-list t) - ;; Activate `outline-mode'. This runs `text-mode-hook' and - ;; `outline-mode-hook'. We must prevent that local processes - ;; die. Yes: I've seen `flyspell-mode', which starts "ispell". - ;; `(custom-declare-variable outline-minor-mode-prefix ...)' - ;; raises on error in `(outline-mode)', we don't want to see it - ;; in the traces. - (let ((default-directory tramp-compat-temporary-file-directory)) - (outline-mode)) - (setq-local outline-level 'tramp-debug-outline-level) - (setq-local font-lock-keywords - ;; FIXME: This `(t FOO . BAR)' representation in - ;; `font-lock-keywords' is supposed to be an - ;; internal implementation "detail". Don't abuse it here! - `(t (eval ,tramp-debug-font-lock-keywords t) - ,(eval tramp-debug-font-lock-keywords t))) - ;; Do not edit the debug buffer. - (use-local-map special-mode-map)) + (tramp-setup-debug-buffer)) (current-buffer))) (put #'tramp-get-debug-buffer 'tramp-suppress-trace t) @@ -1982,9 +2029,7 @@ ARGUMENTS to actually emit the message (if applicable)." (unless (bolp) (insert "\n")) ;; Timestamp. - (let ((now (current-time))) - (insert (format-time-string "%T." now)) - (insert (format "%06d " (nth 2 now)))) + (insert (format-time-string "%T.%6N ")) ;; Calling Tramp function. We suppress compat and trace ;; functions from being displayed. (let ((btn 1) btf fn) @@ -2054,12 +2099,15 @@ applicable)." ;; Append connection buffer for error messages, if exists. (when (= level 1) (ignore-errors - (with-current-buffer - (if (processp vec-or-proc) - (process-buffer vec-or-proc) - (tramp-get-connection-buffer vec-or-proc 'dont-create)) - (setq fmt-string (concat fmt-string "\n%s") - arguments (append arguments (list (buffer-string))))))) + (setq fmt-string (concat fmt-string "\n%s") + arguments + (append + arguments + `(,(tramp-get-buffer-string + (if (processp vec-or-proc) + (process-buffer vec-or-proc) + (tramp-get-connection-buffer + vec-or-proc 'dont-create)))))))) ;; Translate proc to vec. (when (processp vec-or-proc) (setq vec-or-proc (process-get vec-or-proc 'vector)))) @@ -2121,8 +2169,8 @@ an input event arrives. The other arguments are passed to `tramp-error'." (and (tramp-file-name-p vec-or-proc) (tramp-get-connection-buffer vec-or-proc)))) (vec (or (and (tramp-file-name-p vec-or-proc) vec-or-proc) - (and buf (with-current-buffer buf - (tramp-dissect-file-name default-directory)))))) + (and buf (tramp-dissect-file-name + (tramp-get-default-directory buf)))))) (unwind-protect (apply #'tramp-error vec-or-proc signal fmt-string arguments) ;; Save exit. @@ -2186,10 +2234,14 @@ the resulting error message." (defun tramp-test-message (fmt-string &rest arguments) "Emit a Tramp message according `default-directory'." - (if (tramp-tramp-file-p default-directory) - (apply #'tramp-message - (tramp-dissect-file-name default-directory) 0 fmt-string arguments) - (apply #'message fmt-string arguments))) + (cond + ((tramp-tramp-file-p default-directory) + (apply #'tramp-message + (tramp-dissect-file-name default-directory) 0 fmt-string arguments)) + ((tramp-file-name-p (car tramp-current-connection)) + (apply #'tramp-message + (car tramp-current-connection) 0 fmt-string arguments)) + (t (apply #'message fmt-string arguments)))) (put #'tramp-test-message 'tramp-suppress-trace t) @@ -2476,19 +2528,17 @@ Must be handled by the callers." file-accessible-directory-p file-attributes file-directory-p file-executable-p file-exists-p file-local-copy file-modes file-name-as-directory - file-name-directory file-name-nondirectory - file-name-sans-versions file-notify-add-watch - file-ownership-preserved-p file-readable-p - file-regular-p file-remote-p file-selinux-context - file-symlink-p file-truename file-writable-p - find-backup-file-name get-file-buffer + file-name-case-insensitive-p file-name-directory + file-name-nondirectory file-name-sans-versions + file-notify-add-watch file-ownership-preserved-p + file-readable-p file-regular-p file-remote-p + file-selinux-context file-symlink-p file-truename + file-writable-p find-backup-file-name get-file-buffer insert-directory insert-file-contents load make-directory make-directory-internal set-file-acl set-file-modes set-file-selinux-context set-file-times substitute-in-file-name unhandled-file-name-directory vc-registered - ;; Emacs 26+ only. - file-name-case-insensitive-p ;; Emacs 27+ only. file-system-info ;; Emacs 28+ only. @@ -2501,8 +2551,6 @@ Must be handled by the callers." (nth 0 args) default-directory)) ;; STRING FILE. - ;; Starting with Emacs 26.1, just the 2nd argument of - ;; `make-symbolic-link' matters. ((eq operation 'make-symbolic-link) (nth 1 args)) ;; FILE DIRECTORY resp FILE1 FILE2. ((member operation @@ -2533,17 +2581,15 @@ Must be handled by the callers." (if (bufferp (nth 0 args)) (nth 0 args) (current-buffer)))) ;; COMMAND. ((member operation - '(process-file shell-command start-file-process - ;; Emacs 26+ only. - make-nearby-temp-file temporary-file-directory + '(make-nearby-temp-file process-file shell-command + start-file-process temporary-file-directory ;; Emacs 27+ only. exec-path make-process)) default-directory) ;; PROC. ((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))) + (tramp-get-default-directory (process-buffer (nth 0 args))))) ;; VEC. ((member operation '(tramp-get-remote-gid tramp-get-remote-uid)) (tramp-make-tramp-file-name (nth 0 args))) @@ -2554,11 +2600,21 @@ Must be handled by the callers." "Return foreign file name handler if exists." (when (tramp-tramp-file-p filename) (let ((handler tramp-foreign-file-name-handler-alist) - elt res) + (vec (tramp-dissect-file-name filename)) + elt func res) (while handler (setq elt (car handler) handler (cdr handler)) - (when (funcall (car elt) filename) + ;; Previously, this function was called with FILENAME, but now + ;; it's called with the VEC. + (when (condition-case nil + (funcall (setq func (car elt)) vec) + (error + (setcar elt #'ignore) + (unless (member 'remote-file-error debug-ignored-errors) + (tramp-error + vec 'remote-file-error + "Not a valid Tramp file name function `%s'" func)))) (setq handler nil res (cdr elt)))) res))) @@ -2757,8 +2813,9 @@ remote file names." (defun tramp-register-foreign-file-name-handler (func handler &optional append) "Register (FUNC . HANDLER) in `tramp-foreign-file-name-handler-alist'. -FUNC is the function, which determines whether HANDLER is to be called. -Add operations defined in `HANDLER-alist' to `tramp-file-name-handler'." +FUNC is the function, which takes a dissected filename and determines +whether HANDLER is to be called. 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. @@ -2809,18 +2866,14 @@ Add operations defined in `HANDLER-alist' to `tramp-file-name-handler'." (defun tramp-command-completion-p (_symbol buffer) "A predicate for Tramp interactive commands. They are completed by \"M-x TAB\" only if the current buffer is remote." - (with-current-buffer buffer (tramp-tramp-file-p default-directory))) + (tramp-tramp-file-p (tramp-get-default-directory buffer))) (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 0) - (vec - (cond - ((tramp-file-name-p vec-or-filename) vec-or-filename) - ((tramp-tramp-file-p vec-or-filename) - (tramp-dissect-file-name vec-or-filename))))) + (vec (tramp-ensure-dissected-file-name vec-or-filename))) (or ;; We check this for the process related to ;; `tramp-buffer-name'; otherwise `start-file-process' ;; wouldn't run ever when `non-essential' is non-nil. @@ -3278,6 +3331,28 @@ User is always nil." (defvar tramp-handle-write-region-hook nil "Normal hook to be run at the end of `tramp-*-handle-write-region'.") +;; `directory-abbrev-apply' and `directory-abbrev-make-regexp' exists +;; since Emacs 29.1. Since this handler isn't called for older +;; Emacsen, it is save to invoke them via `tramp-compat-funcall'. +(defun tramp-handle-abbreviate-file-name (filename) + "Like `abbreviate-file-name' for Tramp files." + (let* ((case-fold-search (file-name-case-insensitive-p filename)) + (vec (tramp-dissect-file-name filename)) + (home-dir + (with-tramp-connection-property vec "home-directory" + (tramp-compat-funcall + 'directory-abbrev-apply + (expand-file-name (tramp-make-tramp-file-name vec "~")))))) + ;; If any elt of `directory-abbrev-alist' matches this name, + ;; abbreviate accordingly. + (setq filename (tramp-compat-funcall 'directory-abbrev-apply filename)) + ;; Abbreviate home directory. + (if (string-match + (tramp-compat-funcall 'directory-abbrev-make-regexp home-dir) filename) + (tramp-make-tramp-file-name + vec (concat "~" (substring filename (match-beginning 1)))) + filename))) + (defun tramp-handle-access-file (filename string) "Like `access-file' for Tramp files." (setq filename (file-truename filename)) @@ -3290,8 +3365,9 @@ User is always nil." filename) (tramp-error v 'file-error (format "%s: Permission denied, %s" string filename))) - (tramp-compat-file-missing - v (format "%s: No such file or directory, %s" string filename))))) + (tramp-error + v 'file-missing + (format "%s: No such file or directory, %s" string filename))))) (defun tramp-handle-add-name-to-file (filename newname &optional ok-if-already-exists) @@ -3325,7 +3401,7 @@ User is always nil." ;; `copy-directory' creates NEWNAME before running this check. So ;; we do it ourselves. (unless (file-exists-p directory) - (tramp-compat-file-missing (tramp-dissect-file-name directory) directory)) + (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) ;; We must do it file-wise. (tramp-run-real-handler #'copy-directory @@ -3346,7 +3422,7 @@ User is always nil." (defun tramp-handle-directory-files (directory &optional full match nosort count) "Like `directory-files' for Tramp files." (unless (file-exists-p directory) - (tramp-compat-file-missing (tramp-dissect-file-name directory) directory)) + (tramp-error (tramp-dissect-file-name directory) 'file-missing directory)) (when (file-directory-p directory) (setq directory (file-name-as-directory (expand-file-name directory))) (let ((temp (nreverse (file-name-all-completions "" directory))) @@ -3397,13 +3473,16 @@ User is always nil." ;; Do not keep "/..". (when (string-match-p "^/\\.\\.?$" localname) (setq localname "/")) - ;; Do normal `expand-file-name' (this does "/./" and "/../"). + ;; Do normal `expand-file-name' (this does "/./" and "/../"), + ;; unless there are tilde characters in file name. ;; `default-directory' is bound, because on Windows there would ;; be problems with UNC shares or Cygwin mounts. (let ((default-directory tramp-compat-temporary-file-directory)) (tramp-make-tramp-file-name - v (tramp-drop-volume-letter - (tramp-run-real-handler #'expand-file-name (list localname)))))))) + v (if (string-match-p "\\`~" localname) + localname + (tramp-drop-volume-letter + (tramp-run-real-handler #'expand-file-name (list localname))))))))) (defun tramp-handle-file-accessible-directory-p (filename) "Like `file-accessible-directory-p' for Tramp files." @@ -3412,9 +3491,7 @@ User is always nil." (defun tramp-handle-file-directory-p (filename) "Like `file-directory-p' for Tramp files." - (eq (tramp-compat-file-attribute-type - (file-attributes (file-truename filename))) - t)) + (eq (file-attribute-type (file-attributes (file-truename filename))) t)) (defun tramp-handle-file-equal-p (filename1 filename2) "Like `file-equalp-p' for Tramp files." @@ -3446,7 +3523,7 @@ User is always nil." "Like `file-local-copy' for Tramp files." (with-parsed-tramp-file-name filename nil (unless (file-exists-p filename) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (let ((tmpfile (tramp-compat-make-temp-file filename))) (copy-file filename tmpfile 'ok-if-already-exists 'keep-time) tmpfile))) @@ -3454,7 +3531,7 @@ User is always nil." (defun tramp-handle-file-modes (filename &optional flag) "Like `file-modes' for Tramp files." (when-let ((attrs (file-attributes filename)) - (mode-string (tramp-compat-file-attribute-modes attrs))) + (mode-string (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)))) @@ -3486,7 +3563,7 @@ User is always nil." (tramp-get-method-parameter v 'tramp-case-insensitive) ;; There isn't. So we must check, in case there's a connection already. - (and (file-remote-p filename nil 'connected) + (and (let ((non-essential t)) (tramp-connectable-p v)) (with-tramp-connection-property v "case-insensitive" (ignore-errors (with-tramp-progress-reporter v 5 "Checking case-insensitive" @@ -3507,16 +3584,13 @@ User is always nil." (directory-file-name (file-name-directory candidate)))) ;; Nothing found, so we must use a temporary file - ;; 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. + ;; for comparison. (unless (string-match-p "[[:lower:]]" (tramp-file-local-name candidate)) (setq tmpfile (let ((default-directory - (file-name-directory filename))) - (tramp-compat-funcall - 'make-nearby-temp-file "tramp.")) + (file-name-directory filename))) + (make-nearby-temp-file "tramp.")) candidate tmpfile)) ;; Check for the existence of the same file with ;; upper case letters. @@ -3577,9 +3651,8 @@ User is always nil." ((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)))))) + (file-attribute-modification-time (file-attributes file2)) + (file-attribute-modification-time (file-attributes file1)))))) (defun tramp-handle-file-readable-p (filename) "Like `file-readable-p' for Tramp files." @@ -3598,7 +3671,7 @@ User is always nil." ;; Sometimes, `file-attributes' does not return a proper value ;; even if `file-exists-p' does. (when-let ((attr (file-attributes filename))) - (eq ?- (aref (tramp-compat-file-attribute-modes attr) 0))))) + (eq ?- (aref (file-attribute-modes attr) 0))))) (defun tramp-handle-file-remote-p (filename &optional identification connected) "Like `file-remote-p' for Tramp files." @@ -3630,7 +3703,7 @@ User is always nil." (defun tramp-handle-file-symlink-p (filename) "Like `file-symlink-p' for Tramp files." - (let ((x (tramp-compat-file-attribute-type (file-attributes filename)))) + (let ((x (file-attribute-type (file-attributes filename)))) (and (stringp x) x))) (defun tramp-handle-file-truename (filename) @@ -3719,7 +3792,7 @@ User is always nil." (when (and (not tramp-allow-unsafe-temporary-files) (not backup-inhibited) (file-in-directory-p (car result) temporary-file-directory) - (zerop (or (tramp-compat-file-attribute-user-id + (zerop (or (file-attribute-user-id (file-attributes filename 'integer)) tramp-unknown-id-integer)) (not (with-tramp-connection-property @@ -3776,7 +3849,7 @@ User is always nil." (unwind-protect (if (not (file-exists-p filename)) (let ((tramp-verbose (if visit 0 tramp-verbose))) - (tramp-compat-file-missing v filename)) + (tramp-error v 'file-missing filename)) (with-tramp-progress-reporter v 3 (format-message "Inserting `%s'" filename) @@ -3890,16 +3963,19 @@ Return nil when there is no lockfile." (insert-file-contents-literally lockname) (buffer-string)))))) +(defvar tramp-lock-pid nil + "A random nunber local for every connection. +Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.") + (defun tramp-get-lock-pid (file) "Determine pid for lockfile of FILE." - ;; Some Tramp methods do not offer a connection process, but just a - ;; network process as a place holder. Those processes use the - ;; "lock-pid" connection property as fake pid, in fact it is the - ;; time stamp the process is created. - (let ((p (tramp-get-process (tramp-dissect-file-name file)))) - (number-to-string - (or (process-id p) - (tramp-get-connection-property p "lock-pid" (emacs-pid)))))) + ;; Not all Tramp methods use an own process. So we use a random + ;; number, which is as good as a process id. + (with-current-buffer + (tramp-get-connection-buffer (tramp-dissect-file-name file)) + (or tramp-lock-pid + (setq-local + tramp-lock-pid (number-to-string (random most-positive-fixnum)))))) (defconst tramp-lock-file-info-regexp ;; USER@HOST.PID[:BOOT_TIME] @@ -3910,9 +3986,11 @@ Return nil when there is no lockfile." "Like `file-locked-p' for Tramp files." (when-let ((info (tramp-get-lock-file file)) (match (string-match tramp-lock-file-info-regexp info))) - (or (and (string-equal (match-string 1 info) (user-login-name)) + (or ; Locked by me. + (and (string-equal (match-string 1 info) (user-login-name)) (string-equal (match-string 2 info) (system-name)) (string-equal (match-string 3 info) (tramp-get-lock-pid file))) + ; User name. (match-string 1 info)))) (defun tramp-handle-lock-file (file) @@ -3941,7 +4019,7 @@ Return nil when there is no lockfile." (when (and (not tramp-allow-unsafe-temporary-files) create-lockfiles (file-in-directory-p lockname temporary-file-directory) - (zerop (or (tramp-compat-file-attribute-user-id + (zerop (or (file-attribute-user-id (file-attributes file 'integer)) tramp-unknown-id-integer)) (not (with-tramp-connection-property @@ -3993,7 +4071,7 @@ Return nil when there is no lockfile." v 'file-error "File `%s' does not include a `.el' or `.elc' suffix" file))) (unless (or noerror (file-exists-p file)) - (tramp-compat-file-missing v file)) + (tramp-error v 'file-missing file)) (if (not (file-exists-p file)) nil (let ((signal-hook-function (unless noerror signal-hook-function)) @@ -4255,18 +4333,13 @@ substitution. SPEC-LIST is a list of char/value pairs used for p)))))) (defun tramp-handle-make-symbolic-link - (target linkname &optional ok-if-already-exists) + (_target linkname &optional _ok-if-already-exists) "Like `make-symbolic-link' for Tramp files. This is the fallback implementation for backends which do not support symbolic links." - (if (tramp-tramp-file-p (expand-file-name linkname)) - (tramp-error - (tramp-dissect-file-name (expand-file-name linkname)) 'file-error - "make-symbolic-link not supported") - ;; This is needed prior Emacs 26.1, where TARGET has also be - ;; checked for a file name handler. - (tramp-run-real-handler - #'make-symbolic-link (list target linkname ok-if-already-exists)))) + (tramp-error + (tramp-dissect-file-name (expand-file-name linkname)) 'file-error + "make-symbolic-link not supported")) (defun tramp-handle-shell-command (command &optional output-buffer error-buffer) "Like `shell-command' for Tramp files." @@ -4484,7 +4557,7 @@ BUFFER might be a list, in this case STDERR is separated." (unless time-list (let ((remote-file-name-inhibit-cache t)) (setq time-list - (or (tramp-compat-file-attribute-modification-time + (or (file-attribute-modification-time (file-attributes (buffer-file-name))) tramp-time-doesnt-exist)))) (unless (tramp-compat-time-equal-p time-list tramp-time-dont-know) @@ -4508,7 +4581,7 @@ of." t (let* ((remote-file-name-inhibit-cache t) (attr (file-attributes f)) - (modtime (tramp-compat-file-attribute-modification-time attr)) + (modtime (file-attribute-modification-time attr)) (mt (visited-file-modtime))) (cond @@ -4539,11 +4612,9 @@ of." (tmpfile (tramp-compat-make-temp-file filename)) (modes (tramp-default-file-modes filename (and (eq mustbenew 'excl) 'nofollow))) - (uid (or (tramp-compat-file-attribute-user-id - (file-attributes filename 'integer)) + (uid (or (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)) + (gid (or (file-attribute-group-id (file-attributes filename 'integer)) (tramp-get-remote-gid v 'integer)))) ;; Lock file. @@ -4579,8 +4650,7 @@ of." ;; Set file modification time. (when (or (eq visit t) (stringp visit)) (set-visited-file-modtime - (or (tramp-compat-file-attribute-modification-time - (file-attributes filename)) + (or (file-attribute-modification-time (file-attributes filename)) (current-time)))) ;; Set the ownership. @@ -4661,8 +4731,8 @@ of." (save-window-excursion (pop-to-buffer (tramp-get-connection-buffer vec)) (read-string (match-string 0))))))) - (with-current-buffer (tramp-get-connection-buffer vec) - (tramp-message vec 6 "\n%s" (buffer-string))) + (tramp-message + vec 6 "\n%s" (tramp-get-buffer-string (tramp-get-connection-buffer vec))) (tramp-message vec 3 "Sending login name `%s'" user) (tramp-send-string vec (concat user tramp-local-end-of-line))) t) @@ -4705,8 +4775,8 @@ See also `tramp-action-yn'." (unless (yes-or-no-p (match-string 0)) (kill-process proc) (throw 'tramp-action 'permission-denied)) - (with-current-buffer (tramp-get-connection-buffer vec) - (tramp-message vec 6 "\n%s" (buffer-string))) + (tramp-message + vec 6 "\n%s" (tramp-get-buffer-string (tramp-get-connection-buffer vec))) (tramp-send-string vec (concat "yes" tramp-local-end-of-line))) t) @@ -4719,8 +4789,8 @@ See also `tramp-action-yesno'." (unless (y-or-n-p (match-string 0)) (kill-process proc) (throw 'tramp-action 'permission-denied)) - (with-current-buffer (tramp-get-connection-buffer vec) - (tramp-message vec 6 "\n%s" (buffer-string))) + (tramp-message + vec 6 "\n%s" (tramp-get-buffer-string (tramp-get-connection-buffer vec))) (tramp-send-string vec (concat "y" tramp-local-end-of-line))) t) @@ -4728,15 +4798,15 @@ See also `tramp-action-yesno'." "Tell the remote host which terminal type to use. The terminal type can be configured with `tramp-terminal-type'." (tramp-message vec 5 "Setting `%s' as terminal type." tramp-terminal-type) - (with-current-buffer (tramp-get-connection-buffer vec) - (tramp-message vec 6 "\n%s" (buffer-string))) + (tramp-message + vec 6 "\n%s" (tramp-get-buffer-string (tramp-get-connection-buffer vec))) (tramp-send-string vec (concat tramp-terminal-type tramp-local-end-of-line)) t) (defun tramp-action-confirm-message (_proc vec) "Return RET in order to confirm the message." - (with-current-buffer (tramp-get-connection-buffer vec) - (tramp-message vec 6 "\n%s" (buffer-string))) + (tramp-message + vec 6 "\n%s" (tramp-get-buffer-string (tramp-get-connection-buffer vec))) (tramp-send-string vec tramp-local-end-of-line) t) @@ -5024,8 +5094,8 @@ nil." ;; The process could have timed out, for example due to session ;; timeout of sudo. The process buffer does not exist any longer then. (ignore-errors - (with-current-buffer (process-buffer proc) - (tramp-message proc 6 "\n%s" (buffer-string)))) + (tramp-message + proc 6 "\n%s" (tramp-get-buffer-string (process-buffer proc)))) (unless found (if timeout (tramp-error @@ -5247,7 +5317,7 @@ If FILENAME is remote, a file name handler is called." (let* ((dir (file-name-directory filename)) (modes (file-modes dir))) (when (and modes (not (zerop (logand modes #o2000)))) - (setq gid (tramp-compat-file-attribute-group-id (file-attributes dir))))) + (setq gid (file-attribute-group-id (file-attributes dir))))) (if-let ((handler (find-file-name-handler filename 'tramp-set-file-uid-gid))) (funcall handler #'tramp-set-file-uid-gid filename uid gid) @@ -5276,8 +5346,7 @@ ID-FORMAT valid values are `string' and `integer'." ;; `group-name' has been introduced with Emacs 27.1. ((and (fboundp 'group-name) (equal id-format 'string)) (tramp-compat-funcall 'group-name (group-gid))) - ((tramp-compat-file-attribute-group-id - (file-attributes "~/" id-format)))))) + ((file-attribute-group-id (file-attributes "~/" id-format)))))) (defun tramp-get-local-locale (&optional vec) "Determine locale, supporting UTF8 if possible. @@ -5332,31 +5401,22 @@ be granted." file-attr (or ;; Not a symlink. - (eq t (tramp-compat-file-attribute-type file-attr)) - (null (tramp-compat-file-attribute-type file-attr))) + (eq t (file-attribute-type file-attr)) + (null (file-attribute-type file-attr))) (or ;; World accessible. - (eq access - (aref (tramp-compat-file-attribute-modes file-attr) - (+ offset 6))) + (eq access (aref (file-attribute-modes file-attr) (+ offset 6))) ;; User accessible and owned by user. (and - (eq access - (aref (tramp-compat-file-attribute-modes file-attr) offset)) - (or (equal remote-uid - (tramp-compat-file-attribute-user-id file-attr)) - (equal unknown-id - (tramp-compat-file-attribute-user-id file-attr)))) + (eq access (aref (file-attribute-modes file-attr) offset)) + (or (equal remote-uid (file-attribute-user-id file-attr)) + (equal unknown-id (file-attribute-user-id file-attr)))) ;; Group accessible and owned by user's principal group. (and (eq access - (aref (tramp-compat-file-attribute-modes file-attr) - (+ offset 3))) - (or (equal remote-gid - (tramp-compat-file-attribute-group-id file-attr)) - (equal unknown-id - (tramp-compat-file-attribute-group-id - file-attr)))))))))))) + (aref (file-attribute-modes file-attr) (+ offset 3))) + (or (equal remote-gid (file-attribute-group-id file-attr)) + (equal unknown-id (file-attribute-group-id file-attr)))))))))))) (defun tramp-get-remote-uid (vec id-format) "The uid of the remote connection VEC, in ID-FORMAT. @@ -5497,7 +5557,7 @@ this file, if that variable is non-nil." (when (and (not tramp-allow-unsafe-temporary-files) auto-save-default (file-in-directory-p result temporary-file-directory) - (zerop (or (tramp-compat-file-attribute-user-id + (zerop (or (file-attribute-user-id (file-attributes filename 'integer)) tramp-unknown-id-integer)) (not (with-tramp-connection-property @@ -5533,8 +5593,7 @@ ALIST is of the form ((FROM . TO) ...)." (defun tramp-handle-make-nearby-temp-file (prefix &optional dir-flag suffix) "Like `make-nearby-temp-file' for Tramp files." - (let ((temporary-file-directory - (tramp-compat-temporary-file-directory-function))) + (let ((temporary-file-directory (temporary-file-directory))) (make-temp-file prefix dir-flag suffix))) ;;; Compatibility functions section: @@ -5557,14 +5616,12 @@ are written with verbosity of 6." (with-temp-buffer (setq result (apply - #'call-process program infile (or destination t) display args)) + #'call-process program infile (or destination t) display args) + output (tramp-get-buffer-string destination)) ;; `result' could also be an error string. (when (stringp result) (setq error result - result 1)) - (with-current-buffer - (if (bufferp destination) destination (current-buffer)) - (setq output (buffer-string)))) + result 1))) (error (setq error (error-message-string err) result 1))) @@ -5595,10 +5652,10 @@ are written with verbosity of 6." ;; `result' could also be an error string. (when (stringp result) (signal 'file-error (list result))) - (with-current-buffer (if (bufferp buffer) buffer (current-buffer)) - (if (zerop result) - (tramp-message vec 6 "%d" result) - (tramp-message vec 6 "%d\n%s" result (buffer-string))))) + (if (zerop result) + (tramp-message vec 6 "%d" result) + (tramp-message + vec 6 "%d\n%s" result (tramp-get-buffer-string buffer)))) (error (setq result 1) (tramp-message vec 6 "%d\n%s" result (error-message-string err)))) @@ -5663,7 +5720,7 @@ Invokes `password-read' if available, `read-passwd' else." (format "%s for %s " (capitalize (match-string 1)) key)))) (auth-source-creation-prompts `((secret . ,pw-prompt))) ;; Use connection-local value. - (auth-sources (with-current-buffer (process-buffer proc) auth-sources)) + (auth-sources (buffer-local-value 'auth-sources (process-buffer proc))) ;; We suspend the timers while reading the password. (stimers (with-timeout-suspend)) auth-info auth-passwd) @@ -5704,15 +5761,12 @@ Invokes `password-read' if available, `read-passwd' else." (setq auth-passwd (funcall auth-passwd))) auth-passwd) - ;; Try the password cache. Exists since Emacs 26.1. + ;; Try the password cache. (progn (setq auth-passwd (password-read pw-prompt key) tramp-password-save-function (lambda () (password-cache-add key auth-passwd))) - auth-passwd) - - ;; Else, get the password interactively w/o cache. - (read-passwd pw-prompt)) + auth-passwd)) ;; Workaround. Prior Emacs 28.1, auth-source has saved ;; empty passwords. See discussion in Bug#50399. @@ -5824,13 +5878,11 @@ name of a process or buffer, or nil to default to the current buffer." (while (tramp-accept-process-output proc 0)) (not (process-live-p proc)))))) -;; `interrupt-process-functions' exists since Emacs 26.1. -(when (boundp 'interrupt-process-functions) - (add-hook 'interrupt-process-functions #'tramp-interrupt-process) - (add-hook - 'tramp-unload-hook - (lambda () - (remove-hook 'interrupt-process-functions #'tramp-interrupt-process)))) +(add-hook 'interrupt-process-functions #'tramp-interrupt-process) +(add-hook + 'tramp-unload-hook + (lambda () + (remove-hook 'interrupt-process-functions #'tramp-interrupt-process))) (defun tramp-get-remote-null-device (vec) "Return null device on the remote host identified by VEC. @@ -5894,5 +5946,11 @@ BODY is the backend specific code." ;; 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. +;; +;; * Implement file name abbreviation for a different user. That is, +;; (abbreviate-file-name "/ssh:user1@host:/home/user2") => +;; "/ssh:user1@host:~user2". +;; +;; * Implement file name abbreviation for user and host names. ;;; tramp.el ends here diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el index 680bcf09318..6dc5da229c1 100644 --- a/lisp/net/trampver.el +++ b/lisp/net/trampver.el @@ -7,8 +7,8 @@ ;; Maintainer: Michael Albinus <michael.albinus@gmx.de> ;; Keywords: comm, processes ;; Package: tramp -;; Version: 2.5.2.28.1 -;; Package-Requires: ((emacs "25.1")) +;; Version: 2.6.0-pre +;; Package-Requires: ((emacs "26.1")) ;; Package-Type: multi ;; URL: https://www.gnu.org/software/tramp/ @@ -40,7 +40,7 @@ ;; ./configure" to change them. ;;;###tramp-autoload -(defconst tramp-version "2.5.2.28.1" +(defconst tramp-version "2.6.0-pre" "This version of Tramp.") ;;;###tramp-autoload @@ -74,9 +74,9 @@ "The repository revision of the Tramp sources.") ;; Check for Emacs version. -(let ((x (if (not (string-lessp emacs-version "25.1")) +(let ((x (if (not (string-version-lessp emacs-version "26.1")) "ok" - (format "Tramp 2.5.2.28.1 is not fit for %s" + (format "Tramp 2.6.0-pre is not fit for %s" (replace-regexp-in-string "\n" "" (emacs-version)))))) (unless (string-equal "ok" x) (error "%s" x))) diff --git a/lisp/nxml/rng-cmpct.el b/lisp/nxml/rng-cmpct.el index dd3000773fd..1476aa0e5a3 100644 --- a/lisp/nxml/rng-cmpct.el +++ b/lisp/nxml/rng-cmpct.el @@ -369,7 +369,7 @@ OVERRIDE is either nil, require or t." (while (re-search-forward "\\\\x+{\\([[:xdigit:]]+\\)}" (point-max) t) - (let* ((ch (decode-char 'ucs (string-to-number (match-string 1) 16)))) + (let* ((ch (string-to-number (match-string 1) 16))) (if (and ch (> ch 0)) (let ((begin (match-beginning 0)) (end (match-end 0))) diff --git a/lisp/nxml/xmltok.el b/lisp/nxml/xmltok.el index 6159e00c511..ecad501a644 100644 --- a/lisp/nxml/xmltok.el +++ b/lisp/nxml/xmltok.el @@ -943,7 +943,6 @@ and VALUE-END, otherwise a STRING giving the value." (let ((n (string-to-number (buffer-substring-no-properties start end) base))) (cond ((and (integerp n) (xmltok-valid-char-p n)) - (setq n (xmltok-unicode-to-char n)) (and n (string n))) (t (xmltok-add-error "Invalid character code" start end) @@ -971,11 +970,6 @@ and VALUE-END, otherwise a STRING giving the value." (t (and (> n #xFFFF) (< n #x110000))))) -(defun xmltok-unicode-to-char (n) - "Return the character corresponding to Unicode scalar value N. -Return nil if unsupported in Emacs." - (decode-char 'ucs n)) - ;;; Prolog parsing (defvar xmltok-contains-doctype nil) @@ -1766,6 +1760,10 @@ and `xmltok-namespace-attributes'." xmltok-type)) (message "Scanned end of file"))) +;;; Obsolete + +(define-obsolete-function-alias 'xmltok-unicode-to-char #'identity "29.1") + (provide 'xmltok) ;;; xmltok.el ends here diff --git a/lisp/nxml/xsd-regexp.el b/lisp/nxml/xsd-regexp.el index f07ca6657ed..d6eaf7cc4bc 100644 --- a/lisp/nxml/xsd-regexp.el +++ b/lisp/nxml/xsd-regexp.el @@ -52,9 +52,6 @@ ;; or a character translatable to such a character (i.e a character ;; for which `encode-char' will return non-nil). ;; -;; Using unify-8859-on-decoding-mode is probably a good idea here -;; (and generally with XML and other Unicode-oriented formats). -;; ;; Unfortunately, this means that this package is currently useless ;; for CJK characters, since there's no mule-unicode charset for the ;; CJK ranges of Unicode. We should devise a workaround for this @@ -290,7 +287,7 @@ and whose tail is ACCUM." (defun xsdre-compile-single-char (ch) (if (memq ch '(?. ?* ?+ ?? ?\[ ?\] ?^ ?$ ?\\)) (string ?\\ ch) - (string (decode-char 'ucs ch)))) + (string ch))) (defun xsdre-char-class-to-range-list (cc) "Return a range-list for a symbolic char-class CC." @@ -407,10 +404,6 @@ consisting of a single char alternative delimited with []." (cons last chars) (cons last (cons ?- chars)))))) (setq range-list (cdr range-list))) - (setq chars - (mapcar (lambda (c) - (decode-char 'ucs c)) - chars)) (when caret (setq chars (cons ?^ chars))) (when hyphen diff --git a/lisp/obsolete/cl-compat.el b/lisp/obsolete/cl-compat.el index 619bc06122b..0dba366192e 100644 --- a/lisp/obsolete/cl-compat.el +++ b/lisp/obsolete/cl-compat.el @@ -52,6 +52,7 @@ ;;; Keyword routines not supported by new package. (defmacro defkeyword (x &optional doc) + (declare (indent defun)) (cl-list* 'defconst x (list 'quote x) (and doc (list doc)))) (defun keyword-of (sym) diff --git a/lisp/obsolete/cl.el b/lisp/obsolete/cl.el index 9df62318572..a892ed7c76b 100644 --- a/lisp/obsolete/cl.el +++ b/lisp/obsolete/cl.el @@ -513,7 +513,8 @@ a temporary-variables list, a value-forms list, a store-variables list See `gv-define-expander', and `gv-define-setter' for better and simpler ways to define setf-methods." (declare (debug - (&define name cl-lambda-list cl-declarations-or-string def-body))) + (&define name cl-lambda-list cl-declarations-or-string def-body)) + (indent defun)) `(progn ,@(if (stringp (car body)) (list `(put ',name 'setf-documentation ,(pop body)))) @@ -554,7 +555,8 @@ You can replace this form with `gv-define-setter'. (&define name [&or [symbolp &optional stringp] [cl-lambda-list (symbolp)]] - cl-declarations-or-string def-body))) + cl-declarations-or-string def-body)) + (indent defun)) (if (and (listp arg1) (consp args)) ;; Like `gv-define-setter' but with `cl-function'. `(gv-define-expander ,name @@ -615,7 +617,8 @@ arguments from ARGLIST using FUNC. For example: You can replace this macro with `gv-letplace'." (declare (debug (&define name cl-lambda-list ;; should exclude &key - symbolp &optional stringp))) + symbolp &optional stringp)) + (indent defun)) (if (memq '&key arglist) (error "&key not allowed in define-modify-macro")) (require 'cl-macs) ;For cl--arglist-args. diff --git a/lisp/obsolete/crisp.el b/lisp/obsolete/crisp.el index 69bf3ed12bc..ccf9aaa2b6a 100644 --- a/lisp/obsolete/crisp.el +++ b/lisp/obsolete/crisp.el @@ -231,27 +231,13 @@ does not load the scroll-all package." ;; The cut and paste routines are different between XEmacs and Emacs ;; so we need to set up aliases for the functions. - -(defalias 'crisp-set-clipboard - (if (fboundp 'clipboard-kill-ring-save) - 'clipboard-kill-ring-save - 'copy-primary-selection)) - -(defalias 'crisp-kill-region - (if (fboundp 'clipboard-kill-region) - 'clipboard-kill-region - 'kill-primary-selection)) - -(defalias 'crisp-yank-clipboard - (if (fboundp 'clipboard-yank) - 'clipboard-yank - 'yank-clipboard-selection)) +(defalias 'crisp-set-clipboard 'clipboard-kill-ring-save) +(defalias 'crisp-kill-region 'clipboard-kill-region) +(defalias 'crisp-yank-clipboard 'clipboard-yank) (defun crisp-region-active () "Compatibility function to test for an active region." - (if (featurep 'xemacs) - zmacs-region-active-p - mark-active)) + mark-active) (defun crisp-version (&optional arg) "Version number of the CRiSP emulator package. diff --git a/lisp/obsolete/eieio-compat.el b/lisp/obsolete/eieio-compat.el new file mode 100644 index 00000000000..60b0638c63f --- /dev/null +++ b/lisp/obsolete/eieio-compat.el @@ -0,0 +1,277 @@ +;;; eieio-compat.el --- Compatibility with Older EIEIO versions -*- lexical-binding:t -*- + +;; Copyright (C) 1995-1996, 1998-2021 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Keywords: OO, lisp +;; Package: eieio + +;; 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: + +;; Backward compatibility definition of old EIEIO functions in +;; terms of newer equivalent. + +;; The main elements are the old EIEIO `defmethod' and `defgeneric' which are +;; now implemented on top of cl-generic. The differences we have to +;; accommodate are: +;; - EIEIO's :static methods (turned into a new `eieio--static' specializer). +;; - EIEIO's support for `call-next-method' and `next-method-p' instead of +;; `cl-next-method-p' and `cl-call-next-method' (simple matter of renaming). +;; - Different errors are signaled. +;; - EIEIO's defgeneric does not reset the function. +;; - EIEIO's no-next-method and no-applicable-method can't be aliases of +;; cl-generic's namesakes since they have different calling conventions, +;; which means that packages that (defmethod no-next-method ..) don't work. +;; - EIEIO's `call-next-method' and `next-method-p' had dynamic scope whereas +;; cl-generic's `cl-next-method-p' and `cl-call-next-method' are lexically +;; scoped. + +;;; Code: + +(require 'eieio-core) +(require 'cl-generic) + +(put 'eieio--defalias 'byte-hunk-handler + #'byte-compile-file-form-defalias) ;;(get 'defalias 'byte-hunk-handler) +;;;###autoload +(defun eieio--defalias (name body) + "Like `defalias', but with less side-effects. +More specifically, it has no side-effects at all when the new function +definition is the same (`eq') as the old one." + (cl-assert (not (symbolp body))) + (while (and (fboundp name) (symbolp (symbol-function name))) + ;; Follow aliases, so methods applied to obsolete aliases still work. + (setq name (symbol-function name))) + (unless (and (fboundp name) + (eq (symbol-function name) body)) + (defalias name body))) + +;;;###autoload +(defmacro defgeneric (method args &optional doc-string) + "Create a generic function METHOD. +DOC-STRING is the base documentation for this class. A generic +function has no body, as its purpose is to decide which method body +is appropriate to use. Uses `defmethod' to create methods, and calls +`defgeneric' for you. With this implementation the ARGS are +currently ignored. You can use `defgeneric' to apply specialized +top level documentation to a method." + (declare (doc-string 3) (obsolete cl-defgeneric "25.1") + (indent defun)) + `(eieio--defalias ',method + (eieio--defgeneric-init-form + ',method + ,(if doc-string (help-add-fundoc-usage doc-string args))))) + +;;;###autoload +(defmacro defmethod (method &rest args) + "Create a new METHOD through `defgeneric' with ARGS. + +The optional second argument KEY is a specifier that +modifies how the method is called, including: + :before - Method will be called before the :primary + :primary - The default if not specified + :after - Method will be called after the :primary + :static - First arg could be an object or class +The next argument is the ARGLIST. The ARGLIST specifies the arguments +to the method as with `defun'. The first argument can have a type +specifier, such as: + ((VARNAME CLASS) ARG2 ...) +where VARNAME is the name of the local variable for the method being +created. The CLASS is a class symbol for a class made with `defclass'. +A DOCSTRING comes after the ARGLIST, and is optional. +All the rest of the args are the BODY of the method. A method will +return the value of the last form in the BODY. + +Summary: + + (defmethod mymethod [:before | :primary | :after | :static] + ((typearg class-name) arg2 &optional opt &rest rest) + \"doc-string\" + body)" + (declare (doc-string 3) (obsolete cl-defmethod "25.1") + (indent defun) + (debug + (&define ; this means we are defining something + [&name sexp] ;Allow (setf ...) additionally to symbols. + ;; ^^ This is the methods symbol + [ &optional symbolp ] ; this is key :before etc + cl-generic-method-args ; arguments + [ &optional stringp ] ; documentation string + def-body ; part to be debugged + ))) + (let* ((key (if (keywordp (car args)) (pop args))) + (params (car args)) + (arg1 (car params)) + (fargs (if (consp arg1) + (cons (car arg1) (cdr params)) + params)) + (class (if (consp arg1) (nth 1 arg1))) + (code `(lambda ,fargs ,@(cdr args)))) + `(progn + ;; Make sure there is a generic and the byte-compiler sees it. + (defgeneric ,method ,args) + (eieio--defmethod ',method ',key ',class #',code)))) + +(defun eieio--generic-static-symbol-specializers (tag &rest _) + (cl-assert (or (null tag) (eieio--class-p tag))) + (when (eieio--class-p tag) + (let ((superclasses (eieio--generic-subclass-specializers tag)) + (specializers ())) + (dolist (superclass superclasses) + (push superclass specializers) + (push `(eieio--static ,(cadr superclass)) specializers)) + (nreverse specializers)))) + +(cl-generic-define-generalizer eieio--generic-static-symbol-generalizer + ;; Give it a slightly higher priority than `subclass' so that the + ;; interleaved list comes before subclass's non-interleaved list. + 61 (lambda (name &rest _) `(and (symbolp ,name) (cl--find-class ,name))) + #'eieio--generic-static-symbol-specializers) +(cl-generic-define-generalizer eieio--generic-static-object-generalizer + ;; Give it a slightly higher priority than `class' so that the + ;; interleaved list comes before the class's non-interleaved list. + 51 #'cl--generic-struct-tag + (lambda (tag &rest _) + (and (symbolp tag) (setq tag (cl--find-class tag)) + (eieio--class-p tag) + (let ((superclasses (eieio--class-precedence-list tag)) + (specializers ())) + (dolist (superclass superclasses) + (setq superclass (eieio--class-name superclass)) + (push superclass specializers) + (push `(eieio--static ,superclass) specializers)) + (nreverse specializers))))) + +(cl-defmethod cl-generic-generalizers ((_specializer (head eieio--static))) + (list eieio--generic-static-symbol-generalizer + eieio--generic-static-object-generalizer)) + +;;;###autoload +(defun eieio--defgeneric-init-form (method doc-string) + (if doc-string (put method 'function-documentation doc-string)) + (if (memq method '(no-next-method no-applicable-method)) + (symbol-function method) + (let ((generic (cl-generic-ensure-function method))) + (or (symbol-function (cl--generic-name generic)) + (cl--generic-make-function generic))))) + +;;;###autoload +(defun eieio--defmethod (method kind argclass code) + (setq kind (intern (downcase (symbol-name kind)))) + (let* ((specializer (if (not (eq kind :static)) + (or argclass t) + (setq kind nil) + `(eieio--static ,argclass))) + (uses-cnm (not (memq kind '(:before :after)))) + (specializers `((arg ,specializer))) + (code + ;; Backward compatibility for `no-next-method' and + ;; `no-applicable-method', which have slightly different calling + ;; convention than their cl-generic counterpart. + (pcase method + ('no-next-method + (setq method 'cl-no-next-method) + (setq specializers `(generic method ,@specializers)) + (lambda (_generic _method &rest args) (apply code args))) + ('no-applicable-method + (setq method 'cl-no-applicable-method) + (setq specializers `(generic ,@specializers)) + (lambda (generic arg &rest args) + (apply code arg (cl--generic-name generic) (cons arg args)))) + (_ code)))) + (cl-generic-define-method + method (unless (memq kind '(nil :primary)) (list kind)) + specializers uses-cnm + (if uses-cnm + (let* ((docstring (documentation code 'raw)) + (args (help-function-arglist code 'preserve-names)) + (doc-only (if docstring + (let ((split (help-split-fundoc docstring nil))) + (if split (cdr split) docstring))))) + (lambda (cnm &rest args) + (:documentation + (help-add-fundoc-usage doc-only (cons 'cl-cnm args))) + (cl-letf (((symbol-function 'call-next-method) cnm) + ((symbol-function 'next-method-p) + (lambda () (cl--generic-isnot-nnm-p cnm)))) + (apply code args)))) + code)) + ;; The old EIEIO code did not signal an error when there are methods + ;; applicable but only of the before/after kind. So if we add a :before + ;; or :after, make sure there's a matching dummy primary. + (when (and (memq kind '(:before :after)) + ;; FIXME: Use `cl-find-method'? + (not (cl-find-method method () + (mapcar (lambda (arg) + (if (consp arg) (nth 1 arg) t)) + specializers)))) + (cl-generic-define-method method () specializers t + (lambda (cnm &rest args) + (if (cl--generic-isnot-nnm-p cnm) + (apply cnm args))))) + method)) + +;; Compatibility with code which tries to catch `no-method-definition' errors. +(push 'no-method-definition (get 'cl-no-applicable-method 'error-conditions)) + +(defun generic-p (fname) (not (null (cl--generic fname)))) + +(defun no-next-method (&rest args) + (declare (obsolete cl-no-next-method "25.1")) + (apply #'cl-no-next-method 'unknown nil args)) + +(defun no-applicable-method (object method &rest args) + (declare (obsolete cl-no-applicable-method "25.1")) + (apply #'cl-no-applicable-method method object args)) + +(define-obsolete-function-alias 'call-next-method 'cl-call-next-method "25.1") +(defun next-method-p () + (declare (obsolete cl-next-method-p "25.1")) + ;; EIEIO's `next-method-p' just returned nil when called in an + ;; invalid context. + (message "next-method-p called outside of a primary or around method") + nil) + +;;;###autoload +(defun eieio-defmethod (method args) + "Obsolete work part of an old version of the `defmethod' macro." + (declare (obsolete cl-defmethod "24.1")) + (eval `(defmethod ,method ,@args)) + method) + +;;;###autoload +(defun eieio-defgeneric (method doc-string) + "Obsolete work part of an old version of the `defgeneric' macro." + (declare (obsolete cl-defgeneric "24.1")) + (eval `(defgeneric ,method (x) ,@(if doc-string `(,doc-string)))) + ;; Return the method + 'method) + +;;;###autoload +(defun eieio-defclass (cname superclasses slots options) + (declare (obsolete eieio-defclass-internal "25.1")) + (eval `(defclass ,cname ,superclasses ,slots ,@options))) + + +;; Local Variables: +;; generated-autoload-file: "eieio-loaddefs.el" +;; End: + +(provide 'eieio-compat) + +;;; eieio-compat.el ends here diff --git a/lisp/obsolete/eudcb-ph.el b/lisp/obsolete/eudcb-ph.el index 187879ce2f7..51a6780d903 100644 --- a/lisp/obsolete/eudcb-ph.el +++ b/lisp/obsolete/eudcb-ph.el @@ -176,9 +176,7 @@ SERVER is either a string naming the server or a list (NAME PORT)." (setq eudc-ph-process-buffer (get-buffer-create (format " *PH-%s*" host))) (with-current-buffer eudc-ph-process-buffer (erase-buffer) - (setq eudc-ph-read-point (point)) - (and (featurep 'xemacs) (featurep 'mule) - (set-buffer-file-coding-system 'binary t))) + (setq eudc-ph-read-point (point))) (setq process (open-network-stream "ph" eudc-ph-process-buffer host port)) (if (null process) (throw 'done nil)) diff --git a/lisp/obsolete/fast-lock.el b/lisp/obsolete/fast-lock.el index 960233d5627..1dee7120c0e 100644 --- a/lisp/obsolete/fast-lock.el +++ b/lisp/obsolete/fast-lock.el @@ -283,10 +283,7 @@ If a number, only buffers greater than this size have processing messages." (other :tag "always" t) (integer :tag "size"))) -(defvar fast-lock-save-faces - (when (featurep 'xemacs) - ;; XEmacs uses extents for everything, so we have to pick the right ones. - font-lock-face-list) +(defvar fast-lock-save-faces nil "Faces that will be saved in a Font Lock cache file. If nil, means information for all faces will be saved.") @@ -707,35 +704,7 @@ See `fast-lock-get-face-properties'." (while regions (add-text-properties (nth 0 regions) (nth 1 regions) plist) (setq regions (nthcdr 2 regions)))))))) - -;; Functions for XEmacs: - -(unless (boundp 'font-lock-syntactic-keywords) - (defvar font-lock-syntactic-keywords nil)) - -(unless (boundp 'font-lock-inhibit-thing-lock) - (defvar font-lock-inhibit-thing-lock nil)) - -(unless (fboundp 'font-lock-compile-keywords) - (defalias 'font-lock-compile-keywords #'identity)) - -(unless (fboundp 'font-lock-eval-keywords) - (defun font-lock-eval-keywords (keywords) - (if (symbolp keywords) - (font-lock-eval-keywords (if (fboundp keywords) - (funcall keywords) - (eval keywords t))) - keywords))) - -(unless (fboundp 'font-lock-value-in-major-mode) - (defun font-lock-value-in-major-mode (alist) - (if (consp alist) - (cdr (or (assq major-mode alist) (assq t alist))) - alist))) - -(unless (fboundp 'current-message) - (defun current-message () - "")) + ;; Install ourselves: diff --git a/lisp/obsolete/iswitchb.el b/lisp/obsolete/iswitchb.el index a630baf3543..f1e4414e93f 100644 --- a/lisp/obsolete/iswitchb.el +++ b/lisp/obsolete/iswitchb.el @@ -467,9 +467,7 @@ interfere with other minibuffer usage.") (switch-to-buffer-other-window . iswitchb-buffer-other-window) (switch-to-buffer-other-frame . iswitchb-buffer-other-frame) (display-buffer . iswitchb-display-buffer))) - (if (fboundp 'command-remapping) - (define-key map (vector 'remap (car b)) (cdr b)) - (substitute-key-definition (car b) (cdr b) map global-map))) + (define-key map (vector 'remap (car b)) (cdr b))) map) "Global keymap for `iswitchb-mode'.") @@ -977,17 +975,7 @@ Return the modified list with the last element prepended to it." (set-buffer buf)) (with-output-to-temp-buffer temp-buf - (if (featurep 'xemacs) - - ;; XEmacs extents are put on by default, doesn't seem to be - ;; any way of switching them off. - (display-completion-list (or iswitchb-matches iswitchb-buflist) - :help-string "iswitchb " - :activate-callback - (lambda (_x _y _z) - (message "doesn't work yet, sorry!"))) - ;; else running Emacs - (display-completion-list (or iswitchb-matches iswitchb-buflist)))) + (display-completion-list (or iswitchb-matches iswitchb-buflist))) (setq iswitchb-common-match-inserted nil)))) ;;; KILL CURRENT BUFFER @@ -1326,9 +1314,7 @@ This is an example function which can be hooked on to "Return non-nil if we should ignore case when matching. See the variable `iswitchb-case' for details." (if iswitchb-case - (if (featurep 'xemacs) - (isearch-no-upper-case-p iswitchb-text) - (isearch-no-upper-case-p iswitchb-text t)))) + (isearch-no-upper-case-p iswitchb-text t))) ;;;###autoload (define-minor-mode iswitchb-mode diff --git a/lisp/obsolete/otodo-mode.el b/lisp/obsolete/otodo-mode.el index 47f5089452f..a71d2b82e4c 100644 --- a/lisp/obsolete/otodo-mode.el +++ b/lisp/obsolete/otodo-mode.el @@ -908,8 +908,7 @@ If INCLUDE-SEP is non-nil, return point after the separator." ;;;###autoload (define-derived-mode todo-mode nil "TODO" "Major mode for editing TODO lists." - (when (featurep 'xemacs) - (easy-menu-add todo-menu))) + nil) (with-suppressed-warnings ((lexical date entry)) (defvar date) diff --git a/lisp/obsolete/pgg-parse.el b/lisp/obsolete/pgg-parse.el index 2c76365a415..3e4c216abef 100644 --- a/lisp/obsolete/pgg-parse.el +++ b/lisp/obsolete/pgg-parse.el @@ -496,8 +496,7 @@ (defun pgg-parse-armor (string) (with-temp-buffer (buffer-disable-undo) - (unless (featurep 'xemacs) - (set-buffer-multibyte nil)) + (set-buffer-multibyte nil) (insert string) (pgg-decode-armor-region (point-min)(point)))) diff --git a/lisp/obsolete/pgg.el b/lisp/obsolete/pgg.el index 5ed59933f23..127e1dc15c0 100644 --- a/lisp/obsolete/pgg.el +++ b/lisp/obsolete/pgg.el @@ -376,8 +376,7 @@ signer's public key from `pgg-default-keyserver-address'." (if (null signature) nil (with-temp-buffer (buffer-disable-undo) - (unless (featurep 'xemacs) - (set-buffer-multibyte nil)) + (set-buffer-multibyte nil) (insert-file-contents signature) (cdr (assq 2 (pgg-decode-armor-region (point-min)(point-max))))))) diff --git a/lisp/obsolete/tpu-edt.el b/lisp/obsolete/tpu-edt.el index e0e89c390ea..b59fb8c868c 100644 --- a/lisp/obsolete/tpu-edt.el +++ b/lisp/obsolete/tpu-edt.el @@ -650,12 +650,8 @@ GOLD is the ASCII 7-bit escape sequence <ESC>OP.") (setq tpu-mark-flag (if transient-mark-mode "" (if (tpu-mark) " @" " "))) (force-mode-line-update)) -(cond ((featurep 'xemacs) - (add-hook 'zmacs-deactivate-region-hook 'tpu-update-mode-line) - (add-hook 'zmacs-activate-region-hook 'tpu-update-mode-line)) - (t - (add-hook 'activate-mark-hook 'tpu-update-mode-line) - (add-hook 'deactivate-mark-hook 'tpu-update-mode-line))) +(add-hook 'activate-mark-hook 'tpu-update-mode-line) +(add-hook 'deactivate-mark-hook 'tpu-update-mode-line) ;;; @@ -727,15 +723,13 @@ Otherwise sets the tpu-match markers to nil and returns nil." "TPU-edt version of the mark function. Return the appropriate value of the mark for the current version of Emacs." - (cond ((featurep 'xemacs) (mark (not zmacs-regions))) - (t (and mark-active (mark (not transient-mark-mode)))))) + (and mark-active (mark (not transient-mark-mode)))) (defun tpu-set-mark (pos) "TPU-edt version of the `set-mark' function. Sets the mark at POS and activates the region according to the current version of Emacs." - (set-mark pos) - (when (featurep 'xemacs) (when pos (zmacs-activate-region)))) + (set-mark pos)) (defun tpu-string-prompt (prompt history-symbol) "Read a string with PROMPT." @@ -2306,17 +2300,14 @@ Accepts a prefix argument for the number of tpu-pan-columns to scroll." ;;; (defun tpu-load-xkeys (file) "Load the TPU-edt X-windows key definitions FILE. -If FILE is nil, try to load a default file. The default file names are -`~/.tpu-lucid-keys' for XEmacs, and `~/.tpu-keys' for Emacs." +If FILE is nil, try to load a default file. The default file name is +`~/.tpu-keys'." (interactive "fX key definition file: ") (cond (file (setq file (expand-file-name file))) (tpu-xkeys-file (setq file (expand-file-name tpu-xkeys-file))) - ((featurep 'xemacs) - (setq file (convert-standard-filename - (expand-file-name "~/.tpu-lucid-keys")))) - (t + (t (setq file (convert-standard-filename (expand-file-name "~/.tpu-keys"))) (and (not (file-exists-p file)) diff --git a/lisp/obsolete/tpu-mapper.el b/lisp/obsolete/tpu-mapper.el index 5ae0a6558d5..02ba3632504 100644 --- a/lisp/obsolete/tpu-mapper.el +++ b/lisp/obsolete/tpu-mapper.el @@ -46,24 +46,14 @@ ;;; (defun tpu-map-key (ident descrip func gold-func) (interactive) - (if (featurep 'xemacs) - (progn - (setq tpu-key-seq (read-key-sequence - (format "Press %s%s: " ident descrip)) - tpu-key (format "[%s]" (event-key (aref tpu-key-seq 0)))) - (unless (equal tpu-key tpu-return) - (set-buffer "Keys") - (insert (format"(global-set-key %s %s)\n" tpu-key func)) - (set-buffer "Gold-Keys") - (insert (format "(define-key tpu-gold-map %s %s)\n" tpu-key gold-func)))) - (message "Press %s%s: " ident descrip) - (setq tpu-key-seq (read-event) - tpu-key (format "[%s]" tpu-key-seq)) - (unless (equal tpu-key tpu-return) - (set-buffer "Keys") - (insert (format"(define-key tpu-global-map %s %s)\n" tpu-key func)) - (set-buffer "Gold-Keys") - (insert (format "(define-key tpu-gold-map %s %s)\n" tpu-key gold-func)))) + (message "Press %s%s: " ident descrip) + (setq tpu-key-seq (read-event) + tpu-key (format "[%s]" tpu-key-seq)) + (unless (equal tpu-key tpu-return) + (set-buffer "Keys") + (insert (format"(define-key tpu-global-map %s %s)\n" tpu-key func)) + (set-buffer "Gold-Keys") + (insert (format "(define-key tpu-gold-map %s %s)\n" tpu-key gold-func))) (set-buffer "Directions") tpu-key) @@ -103,8 +93,7 @@ your local X guru can try to figure out why the key is being ignored." ;; Make sure the window is big enough to display the instructions - (if (featurep 'xemacs) (set-screen-size (selected-screen) 80 36) - (set-frame-size (selected-frame) 80 36)) + (set-frame-size (selected-frame) 80 36) ;; Create buffers - Directions, Keys, Gold-Keys @@ -162,14 +151,9 @@ your local X guru can try to figure out why the key is being ignored." ;; Save <CR> for future reference - (cond - ((featurep 'xemacs) - (setq tpu-return-seq (read-key-sequence "Hit carriage-return <CR> to continue ")) - (setq tpu-return (concat "[" (format "%s" (event-key (aref tpu-return-seq 0))) "]"))) - (t - (message "Hit carriage-return <CR> to continue ") - (setq tpu-return-seq (read-event)) - (setq tpu-return (concat "[" (format "%s" tpu-return-seq) "]")))) + (message "Hit carriage-return <CR> to continue ") + (setq tpu-return-seq (read-event)) + (setq tpu-return (concat "[" (format "%s" tpu-return-seq) "]")) ;; Build the keymap file @@ -308,24 +292,14 @@ your local X guru can try to figure out why the key is being ignored." ;; ") - (cond ((featurep 'xemacs) - (insert (format "(setq tpu-help-enter \"%s\")\n" tpu-enter-seq)) - (insert (format "(setq tpu-help-return \"%s\")\n" tpu-return-seq)) - (insert "(setq tpu-help-N \"[#<keypress-event N>]\")\n") - (insert "(setq tpu-help-n \"[#<keypress-event n>]\")\n") - (insert "(setq tpu-help-P \"[#<keypress-event P>]\")\n") - (insert "(setq tpu-help-p \"[#<keypress-event p>]\")\n")) - (t - (insert (format "(setq tpu-help-enter \"%s\")\n" tpu-enter)))) + (insert (format "(setq tpu-help-enter \"%s\")\n" tpu-enter)) (append-to-buffer "Keys" 1 (point)) (set-buffer "Keys") ;; Save the key mapping program - (let ((file - (convert-standard-filename - (if (featurep 'xemacs) "~/.tpu-lucid-keys" "~/.tpu-keys")))) + (let ((file (convert-standard-filename "~/.tpu-keys"))) (set-visited-file-name (read-file-name (format "Save key mapping to file (default %s): " file) "" file))) (save-buffer) diff --git a/lisp/obsolete/vc-arch.el b/lisp/obsolete/vc-arch.el index fbbd2d4ecfe..1dffd36f0ea 100644 --- a/lisp/obsolete/vc-arch.el +++ b/lisp/obsolete/vc-arch.el @@ -83,8 +83,6 @@ If nil, use the value of `vc-diff-switches'. If t, use no switches." (repeat :tag "Argument List" :value ("") string)) :version "23.1") -(define-obsolete-variable-alias 'vc-arch-command 'vc-arch-program "23.1") - (defcustom vc-arch-program (let ((candidates '("tla" "baz"))) (while (and candidates (not (executable-find (car candidates)))) diff --git a/lisp/org/org-capture.el b/lisp/org/org-capture.el index a9350c58d52..1756b34fc5b 100644 --- a/lisp/org/org-capture.el +++ b/lisp/org/org-capture.el @@ -1815,10 +1815,13 @@ by their respective `org-store-link-plist' properties if present." ;; Load history list for current prompt. (setq org-capture--prompt-history (gethash prompt org-capture--prompt-history-table)) - (push (org-completing-read - (concat (or prompt "Enter string") - (and default (format " [%s]" default)) - ": ") + (push (org-completing-read + ;; `format-prompt' is new in Emacs 28.1. + (if (fboundp 'format-prompt) + (format-prompt (or prompt "Enter string") default) + (concat (or prompt "Enter string") + (and default (format " [%s]" default)) + ": ")) completions nil nil nil 'org-capture--prompt-history default) strings) diff --git a/lisp/org/org-clock.el b/lisp/org/org-clock.el index 143ed4f123a..12a4c2b7b71 100644 --- a/lisp/org/org-clock.el +++ b/lisp/org/org-clock.el @@ -219,8 +219,7 @@ Emacs initialization file." (const :tag "Clock and history" t) (const :tag "No persistence" nil))) -(defcustom org-clock-persist-file (convert-standard-filename - (concat user-emacs-directory "org-clock-save.el")) +(defcustom org-clock-persist-file (locate-user-emacs-file "org-clock-save.el") "File to save clock data to." :group 'org-clock :type 'string) diff --git a/lisp/org/org-compat.el b/lisp/org/org-compat.el index d230ee2b11f..b140df76223 100644 --- a/lisp/org/org-compat.el +++ b/lisp/org/org-compat.el @@ -170,8 +170,7 @@ extension beyond end of line was not controllable." (defsubst file-attribute-modification-time (attributes) "The modification time in ATTRIBUTES returned by `file-attributes'. This is the time of the last change to the file's contents, and -is a list of integers (HIGH LOW USEC PSEC) in the same style -as (current-time)." +is a Lisp timestamp in the same style as `current-time'." (nth 5 attributes))) (unless (fboundp 'file-attribute-size) diff --git a/lisp/org/org-id.el b/lisp/org/org-id.el index 56783d10833..bd7e73905f3 100644 --- a/lisp/org/org-id.el +++ b/lisp/org/org-id.el @@ -196,8 +196,7 @@ the link." :group 'org-id :type 'boolean) -(defcustom org-id-locations-file (convert-standard-filename - (concat user-emacs-directory ".org-id-locations")) +(defcustom org-id-locations-file (locate-user-emacs-file ".org-id-locations") "The file for remembering in which file an ID was defined. This variable is only relevant when `org-id-track-globally' is set." :group 'org-id diff --git a/lisp/org/org-refile.el b/lisp/org/org-refile.el index 678759e10db..73eaad6bf52 100644 --- a/lisp/org/org-refile.el +++ b/lisp/org/org-refile.el @@ -640,11 +640,13 @@ this function appends the default value from org-refile-target-table)) (completion-ignore-case t) cdef - (prompt (concat prompt - (or (and (car org-refile-history) - (concat " (default " (car org-refile-history) ")")) - (and (assoc cbnex tbl) (setq cdef cbnex) - (concat " (default " cbnex ")"))) ": ")) + (prompt (let ((default (or (car org-refile-history) + (and (assoc cbnex tbl) (setq cdef cbnex) + cbnex)))) + ;; `format-prompt' is new in Emacs 28.1. + (if (fboundp 'format-prompt) + (format-prompt prompt default) + (concat prompt " (default " default ": ")))) pa answ parent-target child parent old-hist) (setq old-hist org-refile-history) (setq answ (funcall cfunc prompt tbl nil (not new-nodes) diff --git a/lisp/outline.el b/lisp/outline.el index 52a94b4d9f4..5e3d4e0e002 100644 --- a/lisp/outline.el +++ b/lisp/outline.el @@ -35,6 +35,8 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) + (defgroup outlines nil "Support for hierarchical outlining." :prefix "outline-" @@ -219,7 +221,7 @@ in the file it applies to.") (defvar outline-font-lock-keywords '( ;; Highlight headings according to the level. - (eval . (list (concat "^\\(?:" outline-regexp "\\).+") + (eval . (list (concat "^\\(?:" outline-regexp "\\).*") 0 '(if outline-minor-mode (if outline-minor-mode-cycle (if outline-minor-mode-highlight @@ -272,6 +274,25 @@ in the file it applies to.") (defvar outline-font-lock-faces [outline-1 outline-2 outline-3 outline-4 outline-5 outline-6 outline-7 outline-8]) + +(defcustom outline-minor-mode-use-buttons nil + "If non-nil, use clickable buttons on the headings. +Note that this feature is not meant to be used in editing +buffers (yet) -- that will be amended in a future version. + +The `outline-minor-mode-buttons' variable specifies how the +buttons should look." + :type 'boolean + :safe #'booleanp + :version "29.1") + +(defcustom outline-minor-mode-buttons + '(("▶️" "🔽" outline--valid-emoji-p) + ("▶" "▼" outline--valid-char-p)) + "List of close/open pairs to use if using buttons." + :type 'sexp + :version "29.1") + (defvar outline-level #'outline-level "Function of no args to compute a header's nesting level in an outline. @@ -356,8 +377,8 @@ When point is on a heading line, then typing `TAB' cycles between `hide all', a heading line cycles the whole buffer (`outline-cycle-buffer'). Typing these keys anywhere outside heading lines uses their default bindings." :type 'boolean + :safe #'booleanp :version "28.1") -;;;###autoload(put 'outline-minor-mode-cycle 'safe-local-variable 'booleanp) (defcustom outline-minor-mode-highlight nil "Highlight headings in `outline-minor-mode' using font-lock keywords. @@ -371,8 +392,8 @@ faces to major mode's faces." (const :tag "Overwrite major mode faces" override) (const :tag "Append outline faces to major mode faces" append) (const :tag "Highlight separately from major mode faces" t)) + :safe #'symbolp :version "28.1") -;;;###autoload(put 'outline-minor-mode-highlight 'safe-local-variable 'symbolp) (defun outline-minor-mode-highlight-buffer () ;; Fallback to overlays when font-lock is unsupported. @@ -388,6 +409,8 @@ faces to major mode's faces." (goto-char (match-beginning 0)) (not (get-text-property (point) 'face)))) (overlay-put overlay 'face (outline-font-lock-face))) + (when outline-minor-mode-use-buttons + (outline--insert-open-button)) (when outline-minor-mode-cycle (overlay-put overlay 'keymap outline-minor-mode-cycle-map))) (goto-char (match-end 0)))))) @@ -807,6 +830,7 @@ If FLAG is nil then text is shown, while if FLAG is t the text is hidden." (overlay-put o 'isearch-open-invisible (or outline-isearch-open-invisible-function #'outline-isearch-open-invisible)))) + (outline--fix-up-all-buttons from to) ;; Seems only used by lazy-lock. I.e. obsolete. (run-hooks 'outline-view-change-hook)) @@ -923,11 +947,82 @@ Note that this does not hide the lines preceding the first heading line." (define-obsolete-function-alias 'show-all #'outline-show-all "25.1") -(defun outline-hide-subtree () - "Hide everything after this heading at deeper levels." - (interactive) +(defun outline-hide-subtree (&optional event) + "Hide everything after this heading at deeper levels. +If non-nil, EVENT should be a mouse event." + (interactive (list last-nonmenu-event)) + (when (mouse-event-p event) + (mouse-set-point event)) + (when (and outline-minor-mode-use-buttons outline-minor-mode) + (outline--insert-close-button)) (outline-flag-subtree t)) +(defun outline--make-button (type) + (cl-loop for (close open test) in outline-minor-mode-buttons + when (and (funcall test close) (funcall test open)) + return (concat (if (eq type 'close) + close + open) + " " (buffer-substring (point) (1+ (point)))))) + +(defun outline--valid-emoji-p (string) + (when-let ((font (and (display-multi-font-p) + (car (internal-char-font nil ?😀))))) + (font-has-char-p font (aref string 0)))) + +(defun outline--valid-char-p (string) + (char-displayable-p (aref string 0))) + +(defun outline--make-button-overlay (type) + (let ((o (seq-find (lambda (o) + (overlay-get o 'outline-button)) + (overlays-at (point))))) + (unless o + (setq o (make-overlay (point) (1+ (point)))) + (overlay-put o 'follow-link 'mouse-face) + (overlay-put o 'mouse-face 'highlight) + (overlay-put o 'outline-button t)) + (overlay-put o 'display (outline--make-button type)) + o)) + +(defun outline--insert-open-button () + (save-excursion + (beginning-of-line) + (let ((o (outline--make-button-overlay 'open))) + (overlay-put o 'help-echo "Click to hide") + (overlay-put o 'keymap + (define-keymap + :parent outline-minor-mode-cycle-map + "RET" #'outline-hide-subtree + "<mouse-2>" #'outline-hide-subtree))))) + +(defun outline--insert-close-button () + (save-excursion + (beginning-of-line) + (let ((o (outline--make-button-overlay 'close))) + (overlay-put o 'help-echo "Click to show") + (overlay-put o 'keymap + (define-keymap + :parent outline-minor-mode-cycle-map + "RET" #'outline-show-subtree + "<mouse-2>" #'outline-show-subtree))))) + +(defun outline--fix-up-all-buttons (&optional from to) + (when from + (save-excursion + (goto-char from) + (setq from (line-beginning-position)))) + (when outline-minor-mode-use-buttons + (outline-map-region + (lambda () + ;; `outline--cycle-state' will fail if we're in a totally + ;; collapsed buffer -- but in that case, we're not in a + ;; `show-all' situation. + (if (eq (ignore-errors (outline--cycle-state)) 'show-all) + (outline--insert-open-button) + (outline--insert-close-button))) + (or from (point-min)) (or to (point-max))))) + (define-obsolete-function-alias 'hide-subtree #'outline-hide-subtree "25.1") (defun outline-hide-leaves () @@ -943,9 +1038,13 @@ Note that this does not hide the lines preceding the first heading line." (define-obsolete-function-alias 'hide-leaves #'outline-hide-leaves "25.1") -(defun outline-show-subtree () +(defun outline-show-subtree (&optional event) "Show everything after this heading at deeper levels." - (interactive) + (interactive (list last-nonmenu-event)) + (when (mouse-event-p event) + (mouse-set-point event)) + (when (and outline-minor-mode-use-buttons outline-minor-mode) + (outline--insert-open-button)) (outline-flag-subtree nil)) (define-obsolete-function-alias 'show-subtree #'outline-show-subtree "25.1") @@ -1295,7 +1394,8 @@ Return either 'hide-all, 'headings-only, or 'show-all." (t (outline-show-all) (setq outline--cycle-buffer-state 'show-all) - (message "Show all"))))) + (message "Show all"))) + (outline--fix-up-all-buttons))) (defvar outline-navigation-repeat-map (let ((map (make-sparse-keymap))) diff --git a/lisp/paren.el b/lisp/paren.el index ce6aa9ae13b..7e7cf6c262a 100644 --- a/lisp/paren.el +++ b/lisp/paren.el @@ -88,6 +88,14 @@ is not highlighted, the cursor being regarded as adequate to mark its position." :type 'boolean) +(defcustom show-paren-context-when-offscreen nil + "If non-nil, show context in the echo area when the openparen is offscreen. +The context is usually the line that contains the openparen, +except if the openparen is on its own line, in which case the +context includes the previous nonblank line." + :type 'boolean + :version "29.1") + (defvar show-paren--idle-timer nil) (defvar show-paren--overlay (let ((ol (make-overlay (point) (point) nil t))) (delete-overlay ol) ol) @@ -312,6 +320,19 @@ It is the default value of `show-paren-data-function'." (current-buffer)) (move-overlay show-paren--overlay there-beg there-end (current-buffer))) + ;; If `show-paren-open-line-when-offscreen' is t and point + ;; is at a close paren, show the line that contains the + ;; openparen in the echo area. + (let ((openparen (min here-beg there-beg))) + (if (and show-paren-context-when-offscreen + (< there-beg here-beg) + (not (pos-visible-in-window-p openparen))) + (let ((open-paren-line-string + (blink-paren-open-paren-line-string openparen)) + (message-log-max nil)) + (minibuffer-message + "Matches %s" + (substring-no-properties open-paren-line-string))))) ;; Always set the overlay face, since it varies. (overlay-put show-paren--overlay 'priority show-paren-priority) (overlay-put show-paren--overlay 'face face)))))) diff --git a/lisp/pcomplete.el b/lisp/pcomplete.el index 64acc416c23..1636e218821 100644 --- a/lisp/pcomplete.el +++ b/lisp/pcomplete.el @@ -680,8 +680,8 @@ user actually typed in." (match-string which arg) (throw 'pcompleted nil)))) -(defalias 'pcomplete-match-beginning 'match-beginning) -(defalias 'pcomplete-match-end 'match-end) +(define-obsolete-function-alias 'pcomplete-match-beginning #'match-beginning "29.1") +(define-obsolete-function-alias 'pcomplete-match-end #'match-end "29.1") (defsubst pcomplete--test (pred arg) "Perform a programmable completion predicate match." @@ -1006,7 +1006,7 @@ Arguments NO-GANGING and ARGS-FOLLOW are currently ignored." ((eq arg-char ?*) (pcomplete-executables)) ((eq arg-char ??) nil) ((eq arg-char ?.) (pcomplete-entries)) - ((eq arg-char ?\() (eval result)))))) + ((eq arg-char ?\() (eval result t)))))) (setq index (1+ index)))))))) (defun pcomplete--here (&optional form stub paring form-only) @@ -1040,7 +1040,7 @@ See the documentation for `pcomplete-here'." (funcall form) ;; Old calling convention, might still be used by files ;; byte-compiled with the older code. - (eval form))))) + (eval form t))))) (defmacro pcomplete-here* (&optional form stub form-only) @@ -1062,9 +1062,9 @@ See the documentation for `pcomplete-here'." pcomplete-window-restore-timer nil)) (define-obsolete-function-alias 'pcomplete-event-matches-key-specifier-p - 'eq "27.1") + #'eq "27.1") -(define-obsolete-function-alias 'pcomplete-read-event 'read-event "27.1") +(define-obsolete-function-alias 'pcomplete-read-event #'read-event "27.1") (defun pcomplete-show-completions (completions) "List in help buffer sorted COMPLETIONS. @@ -1244,7 +1244,7 @@ If specific documentation can't be given, be generic." (fboundp 'Info-goto-node)) (listp pcomplete-help))) (if (listp pcomplete-help) - (message "%s" (eval pcomplete-help)) + (message "%s" (eval pcomplete-help t)) (save-window-excursion (info)) (declare-function Info-goto-node "info" (nodename &optional fork strict-case)) diff --git a/lisp/pixel-scroll.el b/lisp/pixel-scroll.el index 249484cf581..fa0185b16e9 100644 --- a/lisp/pixel-scroll.el +++ b/lisp/pixel-scroll.el @@ -67,6 +67,8 @@ ;;; Code: (require 'mwheel) +(require 'subr-x) +(require 'ring) (defvar pixel-wait 0 "Idle time on each step of pixel scroll specified in second. @@ -90,6 +92,73 @@ is always with pixel resolution.") (defvar pixel-last-scroll-time 0 "Time when the last scrolling was made, in second since the epoch.") +(defvar mwheel-coalesce-scroll-events) + +(defvar pixel-scroll-precision-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [wheel-down] #'pixel-scroll-precision) + (define-key map [wheel-up] #'pixel-scroll-precision) + (define-key map [touch-end] #'pixel-scroll-start-momentum) + map) + "The key map used by `pixel-scroll-precision-mode'.") + +(defcustom pixel-scroll-precision-use-momentum nil + "If non-nil, continue to scroll the display after wheel movement stops. +This is only effective if supported by your mouse or touchpad." + :group 'mouse + :type 'boolean + :version "29.1") + +(defcustom pixel-scroll-precision-momentum-tick 0.01 + "Number of seconds between each momentum scroll." + :group 'mouse + :type 'float + :version "29.1") + +(defcustom pixel-scroll-precision-momentum-seconds 1.75 + "The maximum duration in seconds of momentum scrolling." + :group 'mouse + :type 'float + :version "29.1") + +(defcustom pixel-scroll-precision-momentum-min-velocity 10.0 + "The minimum scrolled pixels per second before momentum scrolling starts." + :group 'mouse + :type 'float + :version "29.1") + +(defcustom pixel-scroll-precision-initial-velocity-factor 0.25 + "Factor applied to the initial velocity before momentum scrolling begins." + :group 'mouse + :type 'float + :version "29.1") + +(defcustom pixel-scroll-precision-large-scroll-height nil + "Pixels that must be scrolled before an animation is performed. +Nil means to not interpolate such scrolls." + :group 'mouse + :type '(choice (const :tag "Do not interpolate large scrolls" nil) + number) + :version "29.1") + +(defcustom pixel-scroll-precision-interpolation-total-time 0.1 + "The total time in seconds to spend interpolating a large scroll." + :group 'mouse + :type 'float + :version "29.1") + +(defcustom pixel-scroll-precision-interpolation-factor 4.0 + "A factor to apply to the distance of an interpolated scroll." + :group 'mouse + :type 'float + :version "29.1") + +(defcustom pixel-scroll-precision-interpolation-between-scroll 0.001 + "The number of seconds between each step of an interpolated scroll." + :group 'mouse + :type 'float + :version "29.1") + (defun pixel-scroll-in-rush-p () "Return non-nil if next scroll should be non-smooth. When scrolling request is delivered soon after the previous one, @@ -323,28 +392,44 @@ returns nil." (setq pos-list (cdr pos-list)))) visible-pos)) -(defun pixel-point-at-unseen-line () - "Return the character position of line above the selected window. -The returned value is the position of the first character on the -unseen line just above the scope of current window." - (let* ((pos0 (window-start)) +(defun pixel-point-and-height-at-unseen-line () + "Return the position and pixel height of line above the selected window. +The returned value is a cons of the position of the first +character on the unseen line just above the scope of current +window, and the pixel height of that line." + (let* ((pos0 (save-excursion + (goto-char (window-start)) + (unless (bobp) + (beginning-of-visual-line)) + (point))) (vscroll0 (window-vscroll nil t)) + (line-height nil) (pos (save-excursion (goto-char pos0) (if (bobp) (point-min) - ;; When there's an overlay string at window-start, - ;; (beginning-of-visual-line 0) stays put. - (let ((ppos (point)) - (tem (beginning-of-visual-line 0))) - (if (eq tem ppos) - (vertical-motion -1)) - (point)))))) + (vertical-motion -1) + (setq line-height + (cdr (window-text-pixel-size nil (point) pos0))) + (point))))) ;; restore initial position (set-window-start nil pos0 t) (set-window-vscroll nil vscroll0 t) - pos)) + (when (and line-height + (> (car (posn-x-y (posn-at-point pos0))) + (line-number-display-width t))) + (setq line-height (- line-height + (save-excursion + (goto-char pos0) + (line-pixel-height))))) + (cons pos line-height))) + +(defun pixel-point-at-unseen-line () + "Return the character position of line above the selected window. +The returned value is the position of the first character on the +unseen line just above the scope of current window." + (car (pixel-point-and-height-at-unseen-line))) (defun pixel-scroll-down-and-set-window-vscroll (vscroll) "Scroll down a line and set VSCROLL in pixels. @@ -354,5 +439,299 @@ Otherwise, redisplay will reset the window's vscroll." (set-window-start nil (pixel-point-at-unseen-line) t) (set-window-vscroll nil vscroll t)) +(defun pixel-scroll-precision-scroll-down-page (delta) + "Scroll the current window down by DELTA pixels. +Note that this function doesn't work if DELTA is larger than +the height of the current window." + (let* ((desired-pos (posn-at-x-y 0 (+ delta + (window-tab-line-height) + (window-header-line-height)))) + (desired-start (posn-point desired-pos)) + (current-vs (window-vscroll nil t)) + (start-posn (unless (eq desired-start (window-start)) + (posn-at-point desired-start))) + (desired-vscroll (if start-posn + (- delta (cdr (posn-x-y start-posn))) + (+ current-vs delta))) + (edges (window-edges nil t)) + (usable-height (- (nth 3 edges) + (nth 1 edges))) + (next-pos (save-excursion + (goto-char desired-start) + (when (zerop (vertical-motion (1+ scroll-margin))) + (signal 'end-of-buffer nil)) + (point))) + (scroll-preserve-screen-position nil) + (auto-window-vscroll nil)) + (when (and (or (< (point) next-pos)) + (let ((pos-visibility (pos-visible-in-window-p next-pos nil t))) + (and pos-visibility + (or (eq (length pos-visibility) 2) + (when-let* ((posn (posn-at-point next-pos))) + (> (cdr (posn-object-width-height posn)) + usable-height)))))) + (goto-char next-pos)) + (set-window-start nil (if (zerop (window-hscroll)) + desired-start + (save-excursion + (goto-char desired-start) + (beginning-of-visual-line) + (point))) + t) + (set-window-vscroll nil desired-vscroll t))) + +(defun pixel-scroll-precision-scroll-down (delta) + "Scroll the current window down by DELTA pixels." + (let ((max-height (- (window-text-height nil t) + (frame-char-height)))) + (while (> delta max-height) + (pixel-scroll-precision-scroll-down-page max-height) + (setq delta (- delta max-height))) + (pixel-scroll-precision-scroll-down-page delta))) + +(defun pixel-scroll-precision-scroll-up-page (delta) + "Scroll the current window up by DELTA pixels. +Note that this function doesn't work if DELTA is larger than +the height of the current window." + (let* ((edges (window-edges nil t nil t)) + (max-y (- (nth 3 edges) + (nth 1 edges))) + (usable-height max-y) + (posn (posn-at-x-y 0 (+ (window-tab-line-height) + (window-header-line-height) + (- max-y delta)))) + (point (posn-point posn)) + (up-point (save-excursion + (goto-char point) + (vertical-motion (- (1+ scroll-margin))) + (point)))) + (when (> (point) up-point) + (when (let ((pos-visible (pos-visible-in-window-p up-point nil t))) + (or (eq (length pos-visible) 2) + (when-let* ((posn (posn-at-point up-point)) + (edges (window-edges nil t)) + (usable-height (- (nth 3 edges) + (nth 1 edges)))) + (> (cdr (posn-object-width-height posn)) + usable-height)))) + (goto-char up-point))) + (let ((current-vscroll (window-vscroll nil t))) + (if (<= delta current-vscroll) + (set-window-vscroll nil (- current-vscroll delta) t) + (setq delta (- delta current-vscroll)) + (set-window-vscroll nil 0 t) + (while (> delta 0) + (let ((position (pixel-point-and-height-at-unseen-line))) + (unless (cdr position) + (signal 'beginning-of-buffer nil)) + (set-window-start nil (car position) t) + ;; If the line above is taller than the window height (i.e. there's + ;; a very tall image), keep point on it. + (when (> (cdr position) usable-height) + (goto-char (car position))) + (setq delta (- delta (cdr position))))) + (when (< delta 0) + (set-window-vscroll nil (- delta) t)))))) + +(defun pixel-scroll-precision-interpolate (delta) + "Interpolate a scroll of DELTA pixels. +This results in the window being scrolled by DELTA pixels with an +animation." + (let ((percentage 0) + (total-time pixel-scroll-precision-interpolation-total-time) + (factor pixel-scroll-precision-interpolation-factor) + (last-time (float-time)) + (time-elapsed 0.0) + (between-scroll pixel-scroll-precision-interpolation-between-scroll) + (rem (window-parameter nil 'interpolated-scroll-remainder)) + (time (window-parameter nil 'interpolated-scroll-remainder-time))) + (when (and rem time + (< (- (float-time) time) 1.0) + (eq (< delta 0) (< rem 0))) + (setq delta (+ delta rem))) + (if (or (null rem) + (eq (< delta 0) (< rem 0))) + (while-no-input + (unwind-protect + (while (< percentage 1) + (redisplay t) + (sleep-for between-scroll) + (setq time-elapsed (+ time-elapsed + (- (float-time) last-time)) + percentage (/ time-elapsed total-time)) + (let ((throw-on-input nil)) + (if (< delta 0) + (pixel-scroll-precision-scroll-down + (ceiling (abs (* (* delta factor) + (/ between-scroll total-time))))) + (pixel-scroll-precision-scroll-up + (ceiling (* (* delta factor) + (/ between-scroll total-time)))))) + (setq last-time (float-time))) + (if (< percentage 1) + (progn + (set-window-parameter nil 'interpolated-scroll-remainder + (* delta (- 1 percentage))) + (set-window-parameter nil 'interpolated-scroll-remainder-time + (float-time))) + (set-window-parameter nil + 'interpolated-scroll-remainder + nil) + (set-window-parameter nil + 'interpolated-scroll-remainder-time + nil)))) + (set-window-parameter nil + 'interpolated-scroll-remainder + nil) + (set-window-parameter nil + 'interpolated-scroll-remainder-time + nil)))) + +(defun pixel-scroll-precision-scroll-up (delta) + "Scroll the current window up by DELTA pixels." + (let ((max-height (- (window-text-height nil t) + (frame-char-height)))) + (while (> delta max-height) + (pixel-scroll-precision-scroll-up-page max-height) + (setq delta (- delta max-height))) + (pixel-scroll-precision-scroll-up-page delta))) + +;; FIXME: This doesn't _always_ work when there's an image above the +;; current line that is taller than the window, and scrolling can +;; sometimes be jumpy in that case. +(defun pixel-scroll-precision (event) + "Scroll the display vertically by pixels according to EVENT. +Move the display up or down by the pixel deltas in EVENT to +scroll the display according to the user's turning the mouse +wheel." + (interactive "e") + (let ((window (mwheel-event-window event))) + (if (and (nth 4 event)) + (let ((delta (round (cdr (nth 4 event))))) + (unless (zerop delta) + (if (> (abs delta) (window-text-height window t)) + (mwheel-scroll event nil) + (with-selected-window window + (if (and pixel-scroll-precision-large-scroll-height + (> (abs delta) + pixel-scroll-precision-large-scroll-height) + (let* ((kin-state (pixel-scroll-kinetic-state)) + (ring (aref kin-state 0)) + (time (aref kin-state 1))) + (or (null time) + (> (- (float-time) time) 1.0) + (and (consp ring) + (ring-empty-p ring))))) + (progn + (let ((kin-state (pixel-scroll-kinetic-state))) + (aset kin-state 0 (make-ring 10)) + (aset kin-state 1 nil)) + (pixel-scroll-precision-interpolate delta)) + (condition-case nil + (progn + (if (< delta 0) + (pixel-scroll-precision-scroll-down (- delta)) + (pixel-scroll-precision-scroll-up delta)) + (pixel-scroll-accumulate-velocity delta)) + ;; Do not ding at buffer limits. Show a message instead. + (beginning-of-buffer + (message (error-message-string '(beginning-of-buffer)))) + (end-of-buffer + (message (error-message-string '(end-of-buffer)))))))))) + (mwheel-scroll event nil)))) + +(defun pixel-scroll-kinetic-state () + "Return the kinetic scroll state of the current window. +It is a vector of the form [ VELOCITY TIME ]." + (or (window-parameter nil 'kinetic-state) + (set-window-parameter nil 'kinetic-state + (vector (make-ring 10) nil)))) + +(defun pixel-scroll-accumulate-velocity (delta) + "Accumulate DELTA into the current window's kinetic scroll state." + (let* ((state (pixel-scroll-kinetic-state)) + (ring (aref state 0)) + (time (aref state 1))) + (when (or (and time (> (- (float-time) time) 0.5)) + (and (not (ring-empty-p ring)) + (not (eq (< delta 0) + (< (cdr (ring-ref ring 0)) + 0))))) + (aset state 0 (make-ring 10))) + (ring-insert (aref state 0) + (cons (aset state 1 (float-time)) + delta)))) + +(defun pixel-scroll-calculate-velocity (state) + "Calculate velocity from the kinetic state vector STATE." + (let* ((ring (aref state 0)) + (elts (ring-elements ring)) + (total 0)) + (dolist (tem elts) + (setq total (+ total (cdr tem)))) + (/ total (* (- (float-time) (caar elts)) + 100)))) + +(defun pixel-scroll-start-momentum (event) + "Start kinetic scrolling for the touch event EVENT." + (interactive "e") + (when pixel-scroll-precision-use-momentum + (let ((window (mwheel-event-window event)) + (state nil)) + (with-selected-window window + (setq state (pixel-scroll-kinetic-state)) + (when (and (aref state 1) + (listp (aref state 0))) + (while-no-input + (unwind-protect (progn + (aset state 0 (pixel-scroll-calculate-velocity state)) + (when (> (abs (aref state 0)) + pixel-scroll-precision-momentum-min-velocity) + (let* ((velocity (* (aref state 0) + pixel-scroll-precision-initial-velocity-factor)) + (original-velocity velocity) + (time-spent 0)) + (if (> velocity 0) + (while (and (> velocity 0) + (<= time-spent + pixel-scroll-precision-momentum-seconds)) + (when (> (round velocity) 0) + (pixel-scroll-precision-scroll-up (round velocity))) + (setq velocity (- velocity + (/ original-velocity + (/ pixel-scroll-precision-momentum-seconds + pixel-scroll-precision-momentum-tick)))) + (redisplay t) + (sit-for pixel-scroll-precision-momentum-tick) + (setq time-spent (+ time-spent + pixel-scroll-precision-momentum-tick)))) + (while (and (< velocity 0) + (<= time-spent + pixel-scroll-precision-momentum-seconds)) + (when (> (round (abs velocity)) 0) + (pixel-scroll-precision-scroll-down (round + (abs velocity)))) + (setq velocity (+ velocity + (/ (abs original-velocity) + (/ pixel-scroll-precision-momentum-seconds + pixel-scroll-precision-momentum-tick)))) + (redisplay t) + (sit-for pixel-scroll-precision-momentum-tick) + (setq time-spent (+ time-spent + pixel-scroll-precision-momentum-tick)))))) + (aset state 0 (make-ring 10)) + (aset state 1 nil)))))))) + +;;;###autoload +(define-minor-mode pixel-scroll-precision-mode + "Toggle pixel scrolling. +When enabled, this minor mode allows to scroll the display +precisely, according to the turning of the mouse wheel." + :global t + :group 'mouse + :keymap pixel-scroll-precision-mode-map + (setq mwheel-coalesce-scroll-events + (not pixel-scroll-precision-mode))) + (provide 'pixel-scroll) ;;; pixel-scroll.el ends here diff --git a/lisp/play/animate.el b/lisp/play/animate.el index 7eb1b277179..54ee9dc84eb 100644 --- a/lisp/play/animate.el +++ b/lisp/play/animate.el @@ -93,9 +93,17 @@ (unless (eolp) (delete-char 1)) (insert-char char 1)) -(defcustom animate-n-steps 10 +(defcustom animate-n-steps 20 "Number of steps `animate-string' will place a char before its last position." - :type 'integer) + :type 'natnum + :version "29.1") + +(defcustom animate-total-added-delay 0.5 + "Total number of seconds to wait in between steps. +This is added to the total time it takes to run `animate-string' +to ensure that the animation is not too fast to be seen." + :type 'float + :version "29.1") (defvar animation-buffer-name nil "String naming the default buffer for animations. @@ -130,7 +138,7 @@ in the current window." ;; Make sure buffer is displayed starting at the beginning. (set-window-start nil 1) ;; Display it, and wait just a little while. - (sit-for .05) + (sit-for (/ (float animate-total-added-delay) (max animate-n-steps 1))) ;; Now undo the changes we made in the buffer. (setq list-to-undo buffer-undo-list) (while list-to-undo diff --git a/lisp/play/snake.el b/lisp/play/snake.el index 29effa23460..dbdecde973d 100644 --- a/lisp/play/snake.el +++ b/lisp/play/snake.el @@ -160,31 +160,28 @@ and then start moving it leftwards.") ;; ;;;;;;;;;;;;; keymaps ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar snake-mode-map - (let ((map (make-sparse-keymap 'snake-mode-map))) - - (define-key map "n" 'snake-start-game) - (define-key map "q" 'snake-end-game) - (define-key map "p" 'snake-pause-game) - - (define-key map [left] 'snake-move-left) - (define-key map [right] 'snake-move-right) - (define-key map [up] 'snake-move-up) - (define-key map [down] 'snake-move-down) - - (define-key map "\C-b" 'snake-move-left) - (define-key map "\C-f" 'snake-move-right) - (define-key map "\C-p" 'snake-move-up) - (define-key map "\C-n" 'snake-move-down) - map) - "Keymap for Snake games.") - -(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.") +(defvar-keymap snake-mode-map + :doc "Keymap for Snake games." + :name 'snake-mode-map + "n" #'snake-start-game + "q" #'snake-end-game + "p" #'snake-pause-game + + "<left>" #'snake-move-left + "<right>" #'snake-move-right + "<up>" #'snake-move-up + "<down>" #'snake-move-down + + "C-b" #'snake-move-left + "C-f" #'snake-move-right + "C-p" #'snake-move-up + "C-n" #'snake-move-down) + +(defvar-keymap snake-null-map + :doc "Keymap for finished Snake games." + :name 'snake-null-map + "n" #'snake-start-game + "q" #'quit-window) (defconst snake--menu-def '("Snake" diff --git a/lisp/play/tetris.el b/lisp/play/tetris.el index 3d6ddd5307f..693bfe49354 100644 --- a/lisp/play/tetris.el +++ b/lisp/play/tetris.el @@ -236,26 +236,24 @@ each one of its four blocks.") ;; ;;;;;;;;;;;;; keymaps ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar tetris-mode-map - (let ((map (make-sparse-keymap 'tetris-mode-map))) - (define-key map "n" 'tetris-start-game) - (define-key map "q" 'tetris-end-game) - (define-key map "p" 'tetris-pause-game) - - (define-key map " " 'tetris-move-bottom) - (define-key map [left] 'tetris-move-left) - (define-key map [right] 'tetris-move-right) - (define-key map [up] 'tetris-rotate-prev) - (define-key map [down] 'tetris-move-down) - map) - "Keymap for Tetris games.") - -(defvar tetris-null-map - (let ((map (make-sparse-keymap 'tetris-null-map))) - (define-key map "n" 'tetris-start-game) - (define-key map "q" 'quit-window) - map) - "Keymap for finished Tetris games.") +(defvar-keymap tetris-mode-map + :doc "Keymap for Tetris games." + :name 'tetris-mode-map + "n" #'tetris-start-game + "q" #'tetris-end-game + "p" #'tetris-pause-game + + "SPC" #'tetris-move-bottom + "<left>" #'tetris-move-left + "<right>" #'tetris-move-right + "<up>" #'tetris-rotate-prev + "<down>" #'tetris-move-down) + +(defvar-keymap tetris-null-map + :doc "Keymap for finished Tetris games." + :name 'tetris-null-map + "n" #'tetris-start-game + "q" #'quit-window) (defconst tetris--menu-def '("Tetris" diff --git a/lisp/proced.el b/lisp/proced.el index 3b754c24c5f..9e9793abece 100644 --- a/lisp/proced.el +++ b/lisp/proced.el @@ -658,6 +658,7 @@ After displaying or updating a Proced buffer, Proced runs the normal hook `proced-post-display-hook'. \\{proced-mode-map}" + :interactive nil (abbrev-mode 0) (auto-fill-mode 0) (setq buffer-read-only t @@ -721,7 +722,7 @@ Proced buffers." With prefix ARG, update this buffer automatically if ARG is positive, otherwise do not update. Sets the variable `proced-auto-update-flag'. The time interval for updates is specified via `proced-auto-update-interval'." - (interactive (list (or current-prefix-arg 'toggle))) + (interactive (list (or current-prefix-arg 'toggle)) proced-mode) (setq proced-auto-update-flag (cond ((eq arg 'toggle) (not proced-auto-update-flag)) (arg (> (prefix-numeric-value arg) 0)) @@ -733,19 +734,19 @@ The time interval for updates is specified via `proced-auto-update-interval'." (defun proced-mark (&optional count) "Mark the current (or next COUNT) processes." - (interactive "p") + (interactive "p" proced-mode) (proced-do-mark t count)) (defun proced-unmark (&optional count) "Unmark the current (or next COUNT) processes." - (interactive "p") + (interactive "p" proced-mode) (proced-do-mark nil count)) (defun proced-unmark-backward (&optional count) "Unmark the previous (or COUNT previous) processes." ;; Analogous to `dired-unmark-backward', ;; but `ibuffer-unmark-backward' behaves different. - (interactive "p") + (interactive "p" proced-mode) (proced-do-mark nil (- (or count 1)))) (defun proced-do-mark (mark &optional count) @@ -762,7 +763,7 @@ The time interval for updates is specified via `proced-auto-update-interval'." (defun proced-toggle-marks () "Toggle marks: marked processes become unmarked, and vice versa." - (interactive) + (interactive nil proced-mode) (let ((mark-re (proced-marker-regexp)) buffer-read-only) (save-excursion @@ -788,14 +789,14 @@ Otherwise move one line forward after inserting the mark." "Mark all processes. If `transient-mark-mode' is turned on and the region is active, mark the region." - (interactive) + (interactive nil proced-mode) (proced-do-mark-all t)) (defun proced-unmark-all () "Unmark all processes. If `transient-mark-mode' is turned on and the region is active, unmark the region." - (interactive) + (interactive nil proced-mode) (proced-do-mark-all nil)) (defun proced-do-mark-all (mark) @@ -830,14 +831,14 @@ mark the region." (defun proced-mark-children (ppid &optional omit-ppid) "Mark child processes of process PPID. Also mark process PPID unless prefix OMIT-PPID is non-nil." - (interactive (list (proced-pid-at-point) current-prefix-arg)) + (interactive (list (proced-pid-at-point) current-prefix-arg) proced-mode) (proced-mark-process-alist (proced-filter-children proced-process-alist ppid omit-ppid))) (defun proced-mark-parents (cpid &optional omit-cpid) "Mark parent processes of process CPID. Also mark CPID unless prefix OMIT-CPID is non-nil." - (interactive (list (proced-pid-at-point) current-prefix-arg)) + (interactive (list (proced-pid-at-point) current-prefix-arg) proced-mode) (proced-mark-process-alist (proced-filter-parents proced-process-alist cpid omit-cpid))) @@ -870,7 +871,7 @@ If `transient-mark-mode' is turned on and the region is active, omit the processes in region. If QUIET is non-nil suppress status message. Returns count of omitted lines." - (interactive "P") + (interactive "P" proced-mode) (let ((mark-re (proced-marker-regexp)) (count 0) buffer-read-only) @@ -947,7 +948,8 @@ Set variable `proced-filter' to SCHEME. Revert listing." (interactive (let ((scheme (completing-read "Filter: " proced-filter-alist nil t))) - (list (if (string= "" scheme) nil (intern scheme))))) + (list (if (string= "" scheme) nil (intern scheme)))) + proced-mode) ;; only update if necessary (unless (eq proced-filter scheme) (setq proced-filter scheme) @@ -1057,7 +1059,7 @@ Each parent process is followed by its child processes. The process tree inherits the chosen sorting order of the process listing, that is, child processes of the same parent process are sorted using the selected sorting order." - (interactive (list (or current-prefix-arg 'toggle))) + (interactive (list (or current-prefix-arg 'toggle)) proced-mode) (setq proced-tree-flag (cond ((eq arg 'toggle) (not proced-tree-flag)) (arg (> (prefix-numeric-value arg) 0)) @@ -1140,7 +1142,7 @@ This command refines an already existing process listing generated initially based on the value of the variable `proced-filter'. It does not change this variable. It does not revert the listing. If you frequently need a certain refinement, consider defining a new filter in `proced-filter-alist'." - (interactive (list last-input-event)) + (interactive (list last-input-event) proced-mode) (if event (posn-set-point (event-end event))) (let ((key (get-text-property (point) 'proced-key)) (pid (get-text-property (point) 'proced-pid))) @@ -1269,7 +1271,8 @@ in the mode line, using \"+\" or \"-\" for ascending or descending order." nil t))) (list (if (string= "" scheme) nil (intern scheme)) ;; like 'toggle in `define-derived-mode' - (or current-prefix-arg 'no-arg)))) + (or current-prefix-arg 'no-arg))) + proced-mode) (setq proced-descend ;; If `proced-sort-interactive' is called repeatedly for the same @@ -1290,37 +1293,37 @@ in the mode line, using \"+\" or \"-\" for ascending or descending order." (defun proced-sort-pcpu (&optional arg) "Sort Proced buffer by percentage CPU time (%CPU). Prefix ARG controls sort order, see `proced-sort-interactive'." - (interactive (list (or current-prefix-arg 'no-arg))) + (interactive (list (or current-prefix-arg 'no-arg)) proced-mode) (proced-sort-interactive 'pcpu arg)) (defun proced-sort-pmem (&optional arg) "Sort Proced buffer by percentage memory usage (%MEM). Prefix ARG controls sort order, see `proced-sort-interactive'." - (interactive (list (or current-prefix-arg 'no-arg))) + (interactive (list (or current-prefix-arg 'no-arg)) proced-mode) (proced-sort-interactive 'pmem arg)) (defun proced-sort-pid (&optional arg) "Sort Proced buffer by PID. Prefix ARG controls sort order, see `proced-sort-interactive'." - (interactive (list (or current-prefix-arg 'no-arg))) + (interactive (list (or current-prefix-arg 'no-arg)) proced-mode) (proced-sort-interactive 'pid arg)) (defun proced-sort-start (&optional arg) "Sort Proced buffer by time the command started (START). Prefix ARG controls sort order, see `proced-sort-interactive'." - (interactive (list (or current-prefix-arg 'no-arg))) + (interactive (list (or current-prefix-arg 'no-arg)) proced-mode) (proced-sort-interactive 'start arg)) (defun proced-sort-time (&optional arg) "Sort Proced buffer by CPU time (TIME). Prefix ARG controls sort order, see `proced-sort-interactive'." - (interactive (list (or current-prefix-arg 'no-arg))) + (interactive (list (or current-prefix-arg 'no-arg)) proced-mode) (proced-sort-interactive 'time arg)) (defun proced-sort-user (&optional arg) "Sort Proced buffer by USER. Prefix ARG controls sort order, see `proced-sort-interactive'." - (interactive (list (or current-prefix-arg 'no-arg))) + (interactive (list (or current-prefix-arg 'no-arg)) proced-mode) (proced-sort-interactive 'user arg)) (defun proced-sort-header (event &optional arg) @@ -1329,7 +1332,7 @@ EVENT is a mouse event with starting position in the header line. It is converted to the corresponding attribute key. This command updates the variable `proced-sort'. Prefix ARG controls sort order, see `proced-sort-interactive'." - (interactive (list last-input-event (or last-prefix-arg 'no-arg))) + (interactive (list last-input-event (or last-prefix-arg 'no-arg)) proced-mode) (let* ((start (event-start event)) (obj (posn-object start)) col key) @@ -1535,7 +1538,8 @@ With prefix REVERT non-nil revert listing." (let ((scheme (completing-read "Format: " proced-format-alist nil t))) (list (if (string= "" scheme) nil (intern scheme)) - current-prefix-arg))) + current-prefix-arg)) + proced-mode) ;; only update if necessary (when (or (not (eq proced-format scheme)) revert) (setq proced-format scheme) @@ -1567,7 +1571,7 @@ Suppress status information if QUIET is nil. After updating a displayed Proced buffer run the normal hook `proced-post-display-hook'." ;; This is the main function that generates and updates the process listing. - (interactive "P") + (interactive "P" proced-mode) (setq revert (or revert (not proced-process-alist))) (or quiet (message (if revert "Updating process information..." "Updating process display..."))) @@ -1773,11 +1777,12 @@ supported but discouraged. It will be removed in a future version of Emacs." `(:annotation-function ,(lambda (s) (cdr (assoc s proced-signal-list)))))) (proced-with-processes-buffer process-alist - (list (completing-read (concat "Send signal [" pnum - "] (default TERM): ") + (list (completing-read (format-prompt "Send signal [%s]" + "TERM" pnum) proced-signal-list nil nil nil nil "TERM") - process-alist)))) + process-alist))) + proced-mode) (unless (and signal process-alist) ;; Discouraged usage (supported for backward compatibility): @@ -1798,8 +1803,8 @@ supported but discouraged. It will be removed in a future version of Emacs." `(:annotation-function ,(lambda (s) (cdr (assoc s proced-signal-list)))))) (proced-with-processes-buffer process-alist - (setq signal (completing-read (concat "Send signal [" pnum - "] (default TERM): ") + (setq signal (completing-read (format-prompt "Send signal [%s]" + "TERM" pnum) proced-signal-list nil nil nil nil "TERM")))))) @@ -1862,7 +1867,8 @@ the normal hook `proced-after-send-signal-hook'." (let ((process-alist (proced-marked-processes))) (proced-with-processes-buffer process-alist (list (read-number "New priority: ") - process-alist)))) + process-alist))) + proced-mode) (if (numberp priority) (setq priority (number-to-string priority))) (let (failures) @@ -1894,7 +1900,7 @@ the normal hook `proced-after-send-signal-hook'." "Pop up a buffer with error log output from Proced. A group of errors from a single command ends with a formfeed. Thus, use \\[backward-page] to find the beginning of a group of errors." - (interactive) + (interactive nil proced-mode) (if (get-buffer proced-log-buffer) (save-selected-window ;; move `proced-log-buffer' to the front of the buffer list @@ -1946,7 +1952,7 @@ STRING is an overall summary of the failures." (defun proced-help () "Provide help for the Proced user." - (interactive) + (interactive nil proced-mode) (proced-why) (if (eq last-command 'proced-help) (describe-mode) @@ -1956,7 +1962,7 @@ STRING is an overall summary of the failures." "Undo in a Proced buffer. This doesn't recover killed processes, it just undoes changes in the Proced buffer. You can use it to recover marks." - (interactive) + (interactive nil proced-mode) (let (buffer-read-only) (undo)) (message "Change in Proced buffer undone. diff --git a/lisp/progmodes/bug-reference.el b/lisp/progmodes/bug-reference.el index d7b12db2211..d7092a37d44 100644 --- a/lisp/progmodes/bug-reference.el +++ b/lisp/progmodes/bug-reference.el @@ -269,9 +269,9 @@ via the internet it might also be http.") ;; pull/17 page if 17 is a PR. Explicit user/project#17 links to ;; possibly different projects are also supported. (cl-defmethod bug-reference--build-forge-setup-entry - (host-domain (_forge-type (eql github)) protocol) + (host-domain (_forge-type (eql 'github)) protocol) `(,(concat "[/@]" (regexp-quote host-domain) - "[/:]\\([.A-Za-z0-9_/-]+\\)\\.git") + "[/:]\\([.A-Za-z0-9_/-]+?\\)\\(?:\\.git\\)?/?\\'") "\\(\\([.A-Za-z0-9_/-]+\\)?\\(?:#\\)\\([0-9]+\\)\\)\\>" ,(lambda (groups) (let ((ns-project (nth 1 groups))) @@ -285,9 +285,9 @@ via the internet it might also be http.") ;; namespace/project#18 or namespace/project!17 references to possibly ;; different projects are also supported. (cl-defmethod bug-reference--build-forge-setup-entry - (host-domain (_forge-type (eql gitlab)) protocol) + (host-domain (_forge-type (eql 'gitlab)) protocol) `(,(concat "[/@]" (regexp-quote host-domain) - "[/:]\\([.A-Za-z0-9_/-]+\\)\\.git") + "[/:]\\([.A-Za-z0-9_/-]+?\\)\\(?:\\.git\\)?/?\\'") "\\(\\([.A-Za-z0-9_/-]+\\)?\\([#!]\\)\\([0-9]+\\)\\)\\>" ,(lambda (groups) (let ((ns-project (nth 1 groups))) @@ -302,9 +302,9 @@ via the internet it might also be http.") ;; Gitea: The systematics is exactly as for Github projects. (cl-defmethod bug-reference--build-forge-setup-entry - (host-domain (_forge-type (eql gitea)) protocol) + (host-domain (_forge-type (eql 'gitea)) protocol) `(,(concat "[/@]" (regexp-quote host-domain) - "[/:]\\([.A-Za-z0-9_/-]+\\)\\.git") + "[/:]\\([.A-Za-z0-9_/-]+?\\)\\(?:\\.git\\)?/?\\'") "\\(\\([.A-Za-z0-9_/-]+\\)?\\(?:#\\)\\([0-9]+\\)\\)\\>" ,(lambda (groups) (let ((ns-project (nth 1 groups))) @@ -323,7 +323,7 @@ via the internet it might also be http.") ;; repo without tracker, or a repo with a tracker using a different ;; name, etc. So we can only try to make a good guess. (cl-defmethod bug-reference--build-forge-setup-entry - (host-domain (_forge-type (eql sourcehut)) protocol) + (host-domain (_forge-type (eql 'sourcehut)) protocol) `(,(concat "[/@]\\(?:git\\|hg\\)." (regexp-quote host-domain) "[/:]\\(~[.A-Za-z0-9_/-]+\\)") "\\(\\(~[.A-Za-z0-9_/-]+\\)?\\(?:#\\)\\([0-9]+\\)\\)\\>" diff --git a/lisp/progmodes/cc-cmds.el b/lisp/progmodes/cc-cmds.el index a9a52636b78..50249728048 100644 --- a/lisp/progmodes/cc-cmds.el +++ b/lisp/progmodes/cc-cmds.el @@ -1896,16 +1896,18 @@ defun." (if (< arg 0) (c-while-widening-to-decl-block (< (setq arg (- (c-forward-to-nth-EOF-\;-or-} (- arg) where))) 0))) - ;; Move forward to the next opening brace.... - (when (and (= arg 0) - (progn - (c-while-widening-to-decl-block - (not (c-syntactic-re-search-forward "{" nil 'eob))) - (eq (char-before) ?{))) - (backward-char) - ;; ... and backward to the function header. - (c-beginning-of-decl-1) - t)) + (prog1 + ;; Move forward to the next opening brace.... + (when (and (= arg 0) + (progn + (c-while-widening-to-decl-block + (not (c-syntactic-re-search-forward "{" nil 'eob))) + (eq (char-before) ?{))) + (backward-char) + ;; ... and backward to the function header. + (c-beginning-of-decl-1) + t) + (c-keep-region-active))) ;; Move backward to the opening brace of a function, making successively ;; larger portions of the buffer visible as necessary. @@ -3413,7 +3415,8 @@ to call `c-scan-conditionals' directly instead." (interactive "p") (let ((new-point (c-scan-conditionals count target-depth with-else))) (push-mark) - (goto-char new-point))) + (goto-char new-point)) + (c-keep-region-active)) (defun c-scan-conditionals (count &optional target-depth with-else) "Scan forward across COUNT preprocessor conditionals. diff --git a/lisp/progmodes/cc-engine.el b/lisp/progmodes/cc-engine.el index db1f46621da..d37a50997ad 100644 --- a/lisp/progmodes/cc-engine.el +++ b/lisp/progmodes/cc-engine.el @@ -165,12 +165,16 @@ (defvar c-doc-line-join-end-ch) (defvar c-syntactic-context) (defvar c-syntactic-element) +(defvar c-new-id-start) +(defvar c-new-id-end) +(defvar c-new-id-is-type) (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) (cc-bytecomp-defun c-remove-string-fences) +(cc-bytecomp-defun c-fontify-new-found-type) ;; Make declarations for all the `c-lang-defvar' variables in cc-langs. @@ -6808,26 +6812,47 @@ comment at the start of cc-engine.el for more info." (defvar c-found-types nil) (make-variable-buffer-local 'c-found-types) +;; Dynamically bound variable that instructs `c-forward-type' to +;; record the ranges of types that only are found. Behaves otherwise +;; like `c-record-type-identifiers'. Also when this variable is non-nil, +;; `c-fontify-new-found-type' doesn't get called (yet) for the purported +;; type. +(defvar c-record-found-types nil) + (defsubst c-clear-found-types () ;; Clears `c-found-types'. (setq c-found-types (make-hash-table :test #'equal :weakness nil))) -(defun c-add-type (from to) - ;; Add the given region as a type in `c-found-types'. If the region - ;; doesn't match an existing type but there is a type which is equal - ;; to the given one except that the last character is missing, then - ;; the shorter type is removed. That's done to avoid adding all - ;; prefixes of a type as it's being entered and font locked. This - ;; doesn't cover cases like when characters are removed from a type - ;; or added in the middle. We'd need the position of point when the - ;; font locking is invoked to solve this well. +(defun c-add-type-1 (from to) + ;; Add the given region as a type in `c-found-types'. Prepare occurrences + ;; of this new type for fontification throughout the buffer. ;; ;; This function might do hidden buffer changes. (let ((type (c-syntactic-content from to c-recognize-<>-arglists))) (unless (gethash type c-found-types) - (remhash (substring type 0 -1) c-found-types) - (puthash type t c-found-types)))) + (puthash type t c-found-types) + (when (and (not c-record-found-types) ; Only call `c-fontify-new-fount-type' + ; when we haven't "bound" c-found-types + ; to itself in c-forward-<>-arglist. + (eq (string-match c-symbol-key type) 0) + (eq (match-end 0) (length type))) + (c-fontify-new-found-type type))))) + +(defun c-add-type (from to) + ;; Add the given region as a type in `c-found-types'. Also perform the + ;; actions of `c-add-type-1'. If the region is or overlaps an identifier + ;; which might be being typed in, don't record it. This is tested by + ;; checking `c-new-id-start' and `c-new-id-end'. That's done to avoid + ;; adding all prefixes of a type as it's being entered and font locked. + ;; This is a bit rough and ready, but now covers adding characters into the + ;; middle of an identifer. + ;; + ;; This function might do hidden buffer changes. + (if (and c-new-id-start c-new-id-end + (<= from c-new-id-end) (>= to c-new-id-start)) + (setq c-new-id-is-type t) + (c-add-type-1 from to))) (defun c-unfind-type (name) ;; Remove the "NAME" from c-found-types, if present. @@ -8210,11 +8235,6 @@ multi-line strings (but not C++, for example)." (setq c-record-ref-identifiers (cons range c-record-ref-identifiers)))))) -;; Dynamically bound variable that instructs `c-forward-type' to -;; record the ranges of types that only are found. Behaves otherwise -;; like `c-record-type-identifiers'. -(defvar c-record-found-types nil) - (defmacro c-forward-keyword-prefixed-id (type) ;; Used internally in `c-forward-keyword-clause' to move forward ;; over a type (if TYPE is 'type) or a name (otherwise) which @@ -8444,6 +8464,11 @@ multi-line strings (but not C++, for example)." (c-forward-<>-arglist-recur all-types))) (progn (when (consp c-record-found-types) + (let ((cur c-record-found-types)) + (while (consp (car-safe cur)) + (c-fontify-new-found-type + (buffer-substring-no-properties (caar cur) (cdar cur))) + (setq cur (cdr cur)))) (setq c-record-type-identifiers ;; `nconc' doesn't mind that the tail of ;; `c-record-found-types' is t. @@ -9169,6 +9194,12 @@ multi-line strings (but not C++, for example)." (when (and (eq res t) (consp c-record-found-types)) + ;; Cause the confirmed types to get fontified. + (let ((cur c-record-found-types)) + (while (consp (car-safe cur)) + (c-fontify-new-found-type + (buffer-substring-no-properties (caar cur) (cdar cur))) + (setq cur (cdr cur)))) ;; Merge in the ranges of any types found by the second ;; `c-forward-type'. (setq c-record-type-identifiers @@ -12092,7 +12123,10 @@ comment at the start of cc-engine.el for more info." (and (c-major-mode-is 'pike-mode) c-decl-block-key))) (while (eq braceassignp 'dontknow) - (cond ((eq (char-after) ?\;) + (cond ((or (eq (char-after) ?\;) + (save-excursion + (progn (c-backward-syntactic-ws) + (c-at-vsemi-p)))) (setq braceassignp nil)) ((and class-key (looking-at class-key)) @@ -14016,7 +14050,8 @@ comment at the start of cc-engine.el for more info." ;; clause - we assume only C++ needs it. (c-syntactic-skip-backward "^;,=" lim t)) (setq placeholder (point)) - (memq (char-before) '(?, ?= ?<))) + (and (memq (char-before) '(?, ?= ?<)) + (not (c-crosses-statement-barrier-p (point) indent-point)))) (cond ;; CASE 5D.6: Something like C++11's "using foo = <type-exp>" diff --git a/lisp/progmodes/cc-fonts.el b/lisp/progmodes/cc-fonts.el index bc0ae6cc95a..967464ac14d 100644 --- a/lisp/progmodes/cc-fonts.el +++ b/lisp/progmodes/cc-fonts.el @@ -93,10 +93,15 @@ (cc-bytecomp-defvar c-preprocessor-face-name) (cc-bytecomp-defvar c-reference-face-name) (cc-bytecomp-defvar c-block-comment-flag) +(cc-bytecomp-defvar c-type-finder-pos) +(cc-bytecomp-defvar c-inhibit-type-finder) +(cc-bytecomp-defvar c-type-finder-timer) (cc-bytecomp-defun c-fontify-recorded-types-and-refs) (cc-bytecomp-defun c-font-lock-declarators) (cc-bytecomp-defun c-font-lock-objc-method) (cc-bytecomp-defun c-font-lock-invalid-string) +(cc-bytecomp-defun c-before-context-fl-expand-region) +(cc-bytecomp-defun c-font-lock-fontify-region) ;; Note that font-lock in XEmacs doesn't expand face names as @@ -919,13 +924,6 @@ casts and declarations are fontified. Used on level 2 and higher." ;; This function does hidden buffer changes. ;;(message "c-font-lock-complex-decl-prepare %s %s" (point) limit) - - ;; Clear the list of found types if we start from the start of the - ;; buffer, to make it easier to get rid of misspelled types and - ;; variables that have gotten recognized as types in malformed code. - (when (bobp) - (c-clear-found-types)) - (c-skip-comments-and-strings limit) (when (< (point) limit) @@ -1605,6 +1603,175 @@ casts and declarations are fontified. Used on level 2 and higher." nil)))) +(defun c-find-types-background (start limit) + ;; Find any "found types" between START and LIMIT. Allow any such types to + ;; be entered into `c-found-types' by the action of `c-forward-name' or + ;; `c-forward-type' called from this function. This process also causes + ;; occurrences of the type to be prepared for fontification throughout the + ;; buffer. + ;; + ;; Return POINT at the end of the function. This should be at or after + ;; LIMIT, and not later than the next decl-spot after LIMIT. + ;; + ;; This function is called from the timer `c-type-finder-timer'. It may do + ;; hidden buffer changes. + (save-excursion + (save-restriction + (widen) + (goto-char start) + ;; If we're in a (possibly large) literal, skip over it. + (let ((lit-bounds (nth 2 (c-full-pp-to-literal (point))))) + (if lit-bounds + (goto-char (cdr lit-bounds)))) + (when (< (point) limit) + (let (;; o - 'decl if we're in an arglist containing declarations + ;; (but if `c-recognize-paren-inits' is set it might also be + ;; an initializer arglist); + ;; o - '<> if the arglist is of angle bracket type; + ;; o - 'arglist if it's some other arglist; + ;; o - nil, if not in an arglist at all. This includes the + ;; parenthesized condition which follows "if", "while", etc. + context + ;; A list of starting positions of possible type declarations, or of + ;; the typedef preceding one, if any. + last-cast-end + ;; The result from `c-forward-decl-or-cast-1'. + decl-or-cast + ;; The maximum of the end positions of all the checked type + ;; decl expressions in the successfully identified + ;; declarations. The position might be either before or + ;; after the syntactic whitespace following the last token + ;; in the type decl expression. + (max-type-decl-end 0) + ;; Same as `max-type-decl-*', but used when we're before + ;; `token-pos'. + (max-type-decl-end-before-token 0) + ) + (goto-char start) + (c-find-decl-spots + limit + c-decl-start-re + nil ; (eval c-maybe-decl-faces) + + (lambda (match-pos inside-macro &optional toplev) + ;; Note to maintainers: don't use `limit' inside this lambda form; + ;; c-find-decl-spots sometimes narrows to less than `limit'. + (if (and c-macro-with-semi-re + (looking-at c-macro-with-semi-re)) + ;; Don't do anything more if we're looking at something that + ;; can't start a declaration. + t + + ;; Set `context' and `c-restricted-<>-arglists'. Look for + ;; "<" for the sake of C++-style template arglists. + ;; "Ignore "(" when it's part of a control flow construct + ;; (e.g. "for ("). + (let ((got-context + (c-get-fontification-context + match-pos + (< match-pos (if inside-macro + max-type-decl-end-before-token + max-type-decl-end)) + toplev))) + (setq context (car got-context) + c-restricted-<>-arglists (cdr got-context))) + + ;; In QT, "more" is an irritating keyword that expands to nothing. + ;; We skip over it to prevent recognition of "more slots: <symbol>" + ;; as a bitfield declaration. + (when (and (c-major-mode-is 'c++-mode) + (looking-at + (concat "\\(more\\)\\([^" c-symbol-chars "]\\|$\\)"))) + (goto-char (match-end 1)) + (c-forward-syntactic-ws)) + + ;; Now analyze the construct. This analysis will cause + ;; `c-forward-name' and `c-forward-type' to call `c-add-type', + ;; triggering the desired recognition and fontification of + ;; these found types. + (when (not (eq context 'not-decl)) + (setq decl-or-cast + (c-forward-decl-or-cast-1 + match-pos context last-cast-end)) + + (cond + ((eq decl-or-cast 'cast) + ;; Save the position after the previous cast so we can feed + ;; it to `c-forward-decl-or-cast-1' in the next round. That + ;; helps it discover cast chains like "(a) (b) c". + (setq last-cast-end (point)) + nil) + (decl-or-cast + ;; We've found a declaration. + + ;; Set `max-type-decl-end' or `max-type-decl-end-before-token' + ;; under the assumption that we're after the first type decl + ;; expression in the declaration now. That's not really true; + ;; we could also be after a parenthesized initializer + ;; expression in C++, but this is only used as a last resort + ;; to slant ambiguous expression/declarations, and overall + ;; it's worth the risk to occasionally fontify an expression + ;; as a declaration in an initializer expression compared to + ;; getting ambiguous things in normal function prototypes + ;; fontified as expressions. + (if inside-macro + (when (> (point) max-type-decl-end-before-token) + (setq max-type-decl-end-before-token (point))) + (when (> (point) max-type-decl-end) + (setq max-type-decl-end (point))))) + (t t)))))))) + (point)))) + +(defun c-type-finder-timer-func () + ;; A CC Mode idle timer function for finding "found types". It triggers + ;; every `c-type-finder-repeat-time' seconds and processes buffer chunks of + ;; size around `c-type-finder-chunk-size' characters, and runs for (a little + ;; over) `c-type-finder-time-slot' seconds. The types it finds are inserted + ;; into `c-found-types', and their occurrences throughout the buffer are + ;; prepared for fontification. + (when (and c-type-finder-time-slot + (boundp 'font-lock-support-mode) + (eq font-lock-support-mode 'jit-lock-mode)) + (if c-inhibit-type-finder ; No processing immediately after a GC operation. + (setq c-inhibit-type-finder nil) + (let* ((stop-time (+ (float-time) c-type-finder-time-slot)) + (buf-list (buffer-list))) + ;; One CC Mode buffer needing processing each time around this loop. + (while (and buf-list + (< (float-time) stop-time)) + ;; Cdr through BUF-LIST to find the next buffer needing processing. + (while (and buf-list + (not (with-current-buffer (car buf-list) c-type-finder-pos))) + (setq buf-list (cdr buf-list))) + (when buf-list + (with-current-buffer (car buf-list) + ;; (message "%s" (current-buffer)) ; Useful diagnostic. + (save-restriction + (widen) + ;; Process one `c-type-finder-chunk-size' chunk each time + ;; around this loop. + (while (and c-type-finder-pos + (< (float-time) stop-time)) + ;; Process one chunk per iteration. + (save-match-data + (c-save-buffer-state + (case-fold-search + (beg (marker-position c-type-finder-pos)) + (end (min (+ beg c-type-finder-chunk-size) (point-max))) + (region (c-before-context-fl-expand-region beg end))) + (setq beg (car region) + end (cdr region)) + (setq beg (max (c-find-types-background beg end) end)) + (move-marker c-type-finder-pos + (if (save-excursion (goto-char beg) (eobp)) + nil + beg)) + (when (not (marker-position c-type-finder-pos)) + (setq c-type-finder-pos nil)))))))))))) + ;; Set the timer to run again. + (setq c-type-finder-timer + (run-at-time c-type-finder-repeat-time nil #'c-type-finder-timer-func))) + (defun c-font-lock-enum-body (limit) ;; Fontify the identifiers of each enum we find by searching forward. ;; @@ -2255,6 +2422,47 @@ higher." ;; defvar will install its default value later on. (makunbound def-var))) +;; `c-re-redisplay-timer' is a timer which, when triggered, causes a +;; redisplay. +(defvar c-re-redisplay-timer nil) + +(defun c-force-redisplay (start end) + ;; Force redisplay immediately. This assumes `font-lock-support-mode' is + ;; 'jit-lock-mode. Set the variable `c-re-redisplay-timer' to nil. + (save-excursion (c-font-lock-fontify-region start end)) + (jit-lock-force-redisplay (copy-marker start) (copy-marker end)) + (setq c-re-redisplay-timer nil)) + +(defun c-fontify-new-found-type (type) + ;; Cause the fontification of TYPE, a string, wherever it occurs in the + ;; buffer. If TYPE is currently displayed in a window, cause redisplay to + ;; happen "instantaneously". These actions are done only when jit-lock-mode + ;; is active. + (when (and font-lock-mode + (boundp 'font-lock-support-mode) + (eq font-lock-support-mode 'jit-lock-mode)) + (c-save-buffer-state + ((window-boundaries + (mapcar (lambda (win) + (cons (window-start win) + (window-end win))) + (get-buffer-window-list (current-buffer) 'no-mini t))) + (target-re (concat "\\_<" type "\\_>"))) + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (while (re-search-forward target-re nil t) + (put-text-property (match-beginning 0) (match-end 0) + 'fontified nil) + (dolist (win-boundary window-boundaries) + (when (and (< (match-beginning 0) (cdr win-boundary)) + (> (match-end 0) (car win-boundary)) + (not c-re-redisplay-timer)) + (setq c-re-redisplay-timer + (run-with-timer 0 nil #'c-force-redisplay + (match-beginning 0) (match-end 0))))))))))) + ;;; C. diff --git a/lisp/progmodes/cc-mode.el b/lisp/progmodes/cc-mode.el index c9b7a95df60..f9435c9ceee 100644 --- a/lisp/progmodes/cc-mode.el +++ b/lisp/progmodes/cc-mode.el @@ -129,6 +129,16 @@ ; ' (require 'cc-fonts) ;) +(defvar c-type-finder-timer nil) +;; The variable which holds the repeating idle timer which triggers off the +;; background type finding search. + +(defvar c-inhibit-type-finder nil) +;; When non-nil (set by `c-post-gc-hook') don't perform the type finding +;; activities the next time `c-type-finder-timer' triggers. This ensures +;; keyboard/mouse input will be dealt with when garbage collection is taking a +;; large portion of CPU time. + ;; The following three really belong to cc-fonts.el, but they are required ;; even when cc-fonts.el hasn't been loaded (this happens in XEmacs when ;; font-lock-mode is nil). @@ -179,6 +189,18 @@ (when c-buffer-is-cc-mode (save-restriction (widen) + (let ((lst (buffer-list))) + (catch 'found + (dolist (b lst) + (if (and (not (eq b (current-buffer))) + (with-current-buffer b + c-buffer-is-cc-mode)) + (throw 'found nil))) + (remove-hook 'post-command-hook 'c-post-command) + (remove-hook 'post-gc-hook 'c-post-gc-hook) + (and c-type-finder-timer + (progn (cancel-timer c-type-finder-timer) + (setq c-type-finder-timer nil))))) (c-save-buffer-state () (c-clear-char-properties (point-min) (point-max) 'category) (c-clear-char-properties (point-min) (point-max) 'syntax-table) @@ -574,6 +596,12 @@ preferably use the `c-mode-menu' language constant directly." ;; currently no such text property. (make-variable-buffer-local 'c-max-syn-tab-mkr) +;; `c-type-finder-pos' is a marker marking the current place in a CC Mode +;; buffer which is due to be searched next for "found types", or nil if the +;; searching is complete. +(defvar c-type-finder-pos nil) +(make-variable-buffer-local 'c-type-finder-pos) + (defun c-basic-common-init (mode default-style) "Initialize the syntax handling routines and the line breaking/filling code. Intended to be used by other packages that embed CC Mode. @@ -745,6 +773,19 @@ that requires a literal mode spec at compile time." ;; would do since font-lock uses a(n implicit) depth of 0) so we don't need ;; c-after-font-lock-init. (add-hook 'after-change-functions 'c-after-change nil t) + (add-hook 'post-command-hook 'c-post-command) + (setq c-type-finder-pos + (save-restriction + (widen) + (move-marker (make-marker) (point-min)))) + + ;; Install the functionality for seeking "found types" at mode startup: + (or c-type-finder-timer + (setq c-type-finder-timer + (run-at-time + c-type-finder-repeat-time nil #'c-type-finder-timer-func))) + (add-hook 'post-gc-hook #'c-post-gc-hook) + (when (boundp 'font-lock-extend-after-change-region-function) (set (make-local-variable 'font-lock-extend-after-change-region-function) 'c-extend-after-change-region))) ; Currently (2009-05) used by all @@ -1950,6 +1991,46 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") ;; confused by already processed single quotes. (narrow-to-region (point) (point-max)))))) +;; The next two variables record the bounds of an identifier currently being +;; typed in. These are used to prevent such a partial identifier being +;; recorded as a found type by c-add-type. +(defvar c-new-id-start nil) +(make-variable-buffer-local 'c-new-id-start) +(defvar c-new-id-end nil) +(make-variable-buffer-local 'c-new-id-end) +;; The next variable, when non-nil, records that the previous two variables +;; define a type. +(defvar c-new-id-is-type nil) +(make-variable-buffer-local 'c-new-id-is-type) + +(defun c-update-new-id (end) + ;; Note the bounds of any identifier that END is in or just after, in + ;; `c-new-id-start' and `c-new-id-end'. Otherwise set these variables to + ;; nil. + (save-excursion + (goto-char end) + (let ((id-beg (c-on-identifier))) + (setq c-new-id-start id-beg + c-new-id-end (and id-beg + (progn (c-end-of-current-token) (point))))))) + + +(defun c-post-command () + ;; If point was inside of a new identifier and no longer is, record that + ;; fact. + (when (and c-buffer-is-cc-mode + c-new-id-start c-new-id-end + (or (> (point) c-new-id-end) + (< (point) c-new-id-start))) + (when c-new-id-is-type + (c-add-type-1 c-new-id-start c-new-id-end)) + (setq c-new-id-start nil + c-new-id-end nil + c-new-id-is-type nil))) + +(defun c-post-gc-hook (&optional _stats) ; For XEmacs. + (setq c-inhibit-type-finder t)) + (defun c-before-change (beg end) ;; Function to be put on `before-change-functions'. Primarily, this calls ;; the language dependent `c-get-state-before-change-functions'. It is @@ -1969,11 +2050,16 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") (unless (c-called-from-text-property-change-p) (save-restriction (widen) + ;; Clear the list of found types if we make a change at the start of the + ;; buffer, to make it easier to get rid of misspelled types and + ;; variables that have gotten recognized as types in malformed code. + (when (eq beg (point-min)) + (c-clear-found-types)) (if c-just-done-before-change - ;; We have two consecutive calls to `before-change-functions' without - ;; an intervening `after-change-functions'. An example of this is bug - ;; #38691. To protect CC Mode, assume that the entire buffer has - ;; changed. + ;; We have two consecutive calls to `before-change-functions' + ;; without an intervening `after-change-functions'. An example of + ;; this is bug #38691. To protect CC Mode, assume that the entire + ;; buffer has changed. (setq beg (point-min) end (point-max) c-just-done-before-change 'whole-buffer) @@ -2151,6 +2237,7 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") c->-as-paren-syntax) (c-clear-char-property-with-value beg end 'syntax-table nil))) + (c-update-new-id end) (c-trim-found-types beg end old-len) ; maybe we don't ; need all of these. (c-invalidate-sws-region-after beg end old-len) @@ -2549,17 +2636,24 @@ This function is called from `c-common-init', once per mode initialization." At the time of call, point is just after the newly inserted CHAR. -When CHAR is \", t will be returned unless the \" is marked with -a string fence syntax-table text property. For other characters, -the default value of `electric-pair-inhibit-predicate' is called -and its value returned. +When CHAR is \" and not within a comment, t will be returned if +the quotes on the current line are already balanced (i.e. if the +last \" is not marked with a string fence syntax-table text +property). For other cases, the default value of +`electric-pair-inhibit-predicate' is called and its value +returned. This function is the appropriate value of `electric-pair-inhibit-predicate' for CC Mode modes, which mark invalid strings with such a syntax table text property on the opening \" and the next unescaped end of line." - (if (eq char ?\") - (not (equal (get-text-property (1- (point)) 'c-fl-syn-tab) '(15))) + (if (and (eq char ?\") + (not (memq (cadr (c-semi-pp-to-literal (1- (point)))) '(c c++)))) + (let ((last-quote (save-match-data + (save-excursion + (goto-char (c-point 'eoll)) + (search-backward "\""))))) + (not (equal (c-get-char-property last-quote 'c-fl-syn-tab) '(15)))) (funcall (default-value 'electric-pair-inhibit-predicate) char))) diff --git a/lisp/progmodes/cc-styles.el b/lisp/progmodes/cc-styles.el index c6b6be5b399..4d518838d11 100644 --- a/lisp/progmodes/cc-styles.el +++ b/lisp/progmodes/cc-styles.el @@ -444,17 +444,19 @@ STYLE using `c-set-style' if the optional SET-P flag is non-nil." defstr)) (prompt (concat symname " offset " defstr)) (keymap (make-sparse-keymap)) - (minibuffer-completion-table obarray) - (minibuffer-completion-predicate 'fboundp) offset input) ;; In principle completing-read is used here, but SPC is unbound ;; to make it less annoying to enter lists. (set-keymap-parent keymap minibuffer-local-completion-map) (define-key keymap " " 'self-insert-command) (while (not offset) - (setq input (read-from-minibuffer prompt nil keymap t - 'c-read-offset-history - (format "%s" oldoff))) + (minibuffer-with-setup-hook + (lambda () + (setq-local minibuffer-completion-table obarray) + (setq-local minibuffer-completion-predicate 'fboundp)) + (setq input (read-from-minibuffer prompt nil keymap t + 'c-read-offset-history + (format "%s" oldoff)))) (if (c-valid-offset input) (setq offset input) ;; error, but don't signal one, keep trying diff --git a/lisp/progmodes/cc-vars.el b/lisp/progmodes/cc-vars.el index d843c783ed0..40a43c32ed9 100644 --- a/lisp/progmodes/cc-vars.el +++ b/lisp/progmodes/cc-vars.el @@ -179,7 +179,7 @@ STYLE stands for the choice where the value is taken from some style setting. PREAMBLE is optionally prepended to FOO; that is, if FOO contains :tag or :value, the respective two-element list component is ignored." - (declare (debug (symbolp form stringp &rest))) + (declare (debug (symbolp form stringp &rest)) (indent defun)) (let* ((expanded-doc (concat doc " This is a style variable. Apart from the valid values described @@ -1524,6 +1524,39 @@ working due to this change." :type 'boolean :group 'c) +(defcustom c-type-finder-time-slot 0.05 + "The length in seconds of a background type search time slot. + +In CC Mode modes, \"found types\" wouldn't always get cleanly +fontified without the background searching for them which happens +in the seconds after starting Emacs or initializing the major +mode. + +This background searching can be disabled by setting this option +to nil." + :type '(choice (const :tag "disabled" nil) + number) + :group 'c) + +(defcustom c-type-finder-repeat-time 0.1 + "The interval, in seconds, at which background type searches occur. + +This interval must be greater than `c-type-finder-time-slot'." + :type 'number + :group 'c) + +(defcustom c-type-finder-chunk-size 1000 + "The size, in characters, of a chunk for background type search. + +Chunks of this size are searched atomically for \"found types\" +just after starting Emacs or initializing the major mode. + +This chunk size is a balance between efficiency (with larger +values) and responsiveness of the keyboard (with smaller values). +See also `c-type-finder-time-slot'." + :type 'integer + :group 'c) + (define-widget 'c-extra-types-widget 'radio "Internal CC Mode widget for the `*-font-lock-extra-types' variables." :args '((const :tag "none" nil) diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el index ac26f5e9341..6e3589df7ad 100644 --- a/lisp/progmodes/compile.el +++ b/lisp/progmodes/compile.el @@ -346,12 +346,9 @@ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1)) ;; PROGRAM:SOURCE-FILE-NAME:LINENO: MESSAGE ;; which is used for non-interactive programs other than ;; compilers (e.g. the "jade:" entry in compilation.txt). - (? (| (regexp "[[:alpha:]][-[:alnum:].]+: ?") - ;; FIXME: This pattern was added for handling messages - ;; from Ruby, but it is unclear whether it is actually - ;; used since the gcc-include rule above seems to cover - ;; it. - (regexp "[ \t]+\\(?:in \\|from\\)"))) + (? (| (: alpha (+ (in ?. ?- alnum)) ":" (? " ")) + ;; Skip indentation generated by GCC's -fanalyzer. + (: (+ " ") "|"))) ;; File name group. (group-n 1 @@ -2228,6 +2225,7 @@ The parent is always `compilation-mode' and the customizable `compilation-...' variables are also set from the name of the mode you have chosen, by replacing the first word, e.g., `compilation-scroll-output' from `grep-scroll-output' if that variable exists." + (declare (indent defun)) (let ((mode-name (replace-regexp-in-string "-mode\\'" "" (symbol-name mode)))) `(define-derived-mode ,mode compilation-mode ,name ,doc diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el index 1afeb60ac5f..fe9612a09a9 100644 --- a/lisp/progmodes/cperl-mode.el +++ b/lisp/progmodes/cperl-mode.el @@ -1019,15 +1019,9 @@ Unless KEEP, removes the old indentation." (define-key map [(control ?c) (control ?h) ?v] ;;(concat (char-to-string help-char) "v") ; does not work 'cperl-get-help)) - (substitute-key-definition - 'indent-sexp 'cperl-indent-exp - map global-map) - (substitute-key-definition - 'indent-region 'cperl-indent-region - map global-map) - (substitute-key-definition - 'indent-for-comment 'cperl-indent-for-comment - map global-map) + (define-key map [remap indent-sexp] #'cperl-indent-exp) + (define-key map [remap indent-region] #'cperl-indent-region) + (define-key map [remap indent-for-comment] #'cperl-indent-for-comment) map) "Keymap used in CPerl mode.") @@ -5951,7 +5945,7 @@ default function." (eval cperl--basic-identifier-rx))) (0+ blank) "(") ;; '("\\<for\\(each\\)?\\([ \t]+\\(state\\|my\\|local\\|our\\)\\)?[ \t]*\\(\\$[a-zA-Z_][a-zA-Z_0-9]*\\)[ \t]*(" - 4 font-lock-variable-name-face) + 1 font-lock-variable-name-face) ;; Avoid $!, and s!!, qq!! etc. when not fontifying syntactically '("\\(?:^\\|[^smywqrx$]\\)\\(!\\)" 1 font-lock-negation-char-face) '("\\[\\(\\^\\)" 1 font-lock-negation-char-face prepend))) diff --git a/lisp/progmodes/cpp.el b/lisp/progmodes/cpp.el index d800365e66d..baee72b332d 100644 --- a/lisp/progmodes/cpp.el +++ b/lisp/progmodes/cpp.el @@ -702,11 +702,8 @@ BRANCH should be either nil (false branch), t (true branch) or `both'." (x-popup-menu cpp-button-event (list prompt (cons prompt cpp-face-default-list))) (let ((name (car (rassq default cpp-face-default-list)))) - (cdr (assoc (completing-read (if name - (concat prompt - " (default " name "): ") - (concat prompt ": ")) - cpp-face-default-list nil t) + (cdr (assoc (completing-read (format-prompt "%s" name prompt) + cpp-face-default-list nil t) cpp-face-all-list)))) default)) diff --git a/lisp/progmodes/ebrowse.el b/lisp/progmodes/ebrowse.el index ab0329d7eec..0713370da3c 100644 --- a/lisp/progmodes/ebrowse.el +++ b/lisp/progmodes/ebrowse.el @@ -1330,9 +1330,9 @@ Pop to member buffer if no prefix ARG, to tree buffer otherwise." "Set the indentation width of the tree display." (interactive) (let ((width (string-to-number (read-string - (concat "Indentation (default " - (int-to-string ebrowse--indentation) - "): ") + (format-prompt + "Indentation" + (int-to-string ebrowse--indentation)) nil nil ebrowse--indentation)))) (when (cl-plusp width) (setq-local ebrowse--indentation width) @@ -4045,23 +4045,27 @@ NUMBER-OF-STATIC-VARIABLES:" (defvar ebrowse-global-map nil "Keymap for Ebrowse commands.") - (defvar ebrowse-global-prefix-key "\C-c\C-m" "Prefix key for Ebrowse commands.") - -(defvar ebrowse-global-submap-4 nil - "Keymap used for `ebrowse-global-prefix' followed by `4'.") - - -(defvar ebrowse-global-submap-5 nil - "Keymap used for `ebrowse-global-prefix' followed by `5'.") - +(defvar-keymap ebrowse-global-submap-4 + :doc "Keymap used for `ebrowse-global-prefix' followed by `4'." + "." #'ebrowse-tags-find-definition-other-window + "f" #'ebrowse-tags-find-definition-other-window + "v" #'ebrowse-tags-find-declaration-other-window + "F" #'ebrowse-tags-view-definition-other-window + "V" #'ebrowse-tags-view-declaration-other-window) + +(defvar-keymap ebrowse-global-submap-5 + :doc "Keymap used for `ebrowse-global-prefix' followed by `5'." + "." #'ebrowse-tags-find-definition-other-frame + "f" #'ebrowse-tags-find-definition-other-frame + "v" #'ebrowse-tags-find-declaration-other-frame + "F" #'ebrowse-tags-view-definition-other-frame + "V" #'ebrowse-tags-view-declaration-other-frame) (unless ebrowse-global-map (setq ebrowse-global-map (make-sparse-keymap)) - (setq ebrowse-global-submap-4 (make-sparse-keymap)) - (setq ebrowse-global-submap-5 (make-sparse-keymap)) (define-key ebrowse-global-map "a" 'ebrowse-tags-apropos) (define-key ebrowse-global-map "b" 'ebrowse-pop-to-browser-buffer) (define-key ebrowse-global-map "-" 'ebrowse-back-in-position-stack) @@ -4082,17 +4086,7 @@ NUMBER-OF-STATIC-VARIABLES:" (define-key ebrowse-global-map " " 'ebrowse-electric-buffer-list) (define-key ebrowse-global-map "\t" 'ebrowse-tags-complete-symbol) (define-key ebrowse-global-map "4" ebrowse-global-submap-4) - (define-key ebrowse-global-submap-4 "." 'ebrowse-tags-find-definition-other-window) - (define-key ebrowse-global-submap-4 "f" 'ebrowse-tags-find-definition-other-window) - (define-key ebrowse-global-submap-4 "v" 'ebrowse-tags-find-declaration-other-window) - (define-key ebrowse-global-submap-4 "F" 'ebrowse-tags-view-definition-other-window) - (define-key ebrowse-global-submap-4 "V" 'ebrowse-tags-view-declaration-other-window) (define-key ebrowse-global-map "5" ebrowse-global-submap-5) - (define-key ebrowse-global-submap-5 "." 'ebrowse-tags-find-definition-other-frame) - (define-key ebrowse-global-submap-5 "f" 'ebrowse-tags-find-definition-other-frame) - (define-key ebrowse-global-submap-5 "v" 'ebrowse-tags-find-declaration-other-frame) - (define-key ebrowse-global-submap-5 "F" 'ebrowse-tags-view-definition-other-frame) - (define-key ebrowse-global-submap-5 "V" 'ebrowse-tags-view-declaration-other-frame) (define-key global-map ebrowse-global-prefix-key ebrowse-global-map)) diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index 9522055670d..efb5df8ebfb 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -45,15 +45,13 @@ It has `lisp-mode-abbrev-table' as its parent." table) "Syntax table used in `emacs-lisp-mode'.") -(defvar emacs-lisp-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map lisp-mode-shared-map) - (define-key map "\e\t" 'completion-at-point) - (define-key map "\e\C-x" 'eval-defun) - (define-key map "\e\C-q" 'indent-pp-sexp) - map) - "Keymap for Emacs Lisp mode. -All commands in `lisp-mode-shared-map' are inherited by this map.") +(defvar-keymap emacs-lisp-mode-map + :doc "Keymap for Emacs Lisp mode. +All commands in `lisp-mode-shared-map' are inherited by this map." + :parent lisp-mode-shared-map + "M-TAB" #'completion-at-point + "C-M-x" #'eval-defun + "C-M-q" #'indent-pp-sexp) (easy-menu-define emacs-lisp-mode-menu emacs-lisp-mode-map "Menu for Emacs Lisp mode." @@ -270,10 +268,8 @@ Comments in the form will be lost." (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)) +(defvar-keymap elisp--dynlex-modeline-map + "<mode-line> <mouse-1>" #'elisp-enable-lexical-binding) ;;;###autoload (define-derived-mode emacs-lisp-mode lisp-data-mode @@ -636,7 +632,8 @@ functions are annotated with \"<f>\" via the :company-kind #'elisp--company-kind :company-doc-buffer #'elisp--company-doc-buffer :company-docsig #'elisp--company-doc-string - :company-location #'elisp--company-location)) + :company-location #'elisp--company-location + :company-deprecated #'elisp--company-deprecated)) (quoted (list nil (elisp--completion-local-symbols) ;; Don't include all symbols (bug#16646). @@ -652,7 +649,8 @@ functions are annotated with \"<f>\" via the :company-kind #'elisp--company-kind :company-doc-buffer #'elisp--company-doc-buffer :company-docsig #'elisp--company-doc-string - :company-location #'elisp--company-location)) + :company-location #'elisp--company-location + :company-deprecated #'elisp--company-deprecated)) (t (list nil (completion-table-merge elisp--local-variables-completion-table @@ -667,7 +665,8 @@ functions are annotated with \"<f>\" via the 'variable)) :company-doc-buffer #'elisp--company-doc-buffer :company-docsig #'elisp--company-doc-string - :company-location #'elisp--company-location))) + :company-location #'elisp--company-location + :company-deprecated #'elisp--company-deprecated))) ;; Looks like a funcall position. Let's double check. (save-excursion (goto-char (1- beg)) @@ -714,13 +713,15 @@ functions are annotated with \"<f>\" via the :company-kind (lambda (_) 'variable) :company-doc-buffer #'elisp--company-doc-buffer :company-docsig #'elisp--company-doc-string - :company-location #'elisp--company-location)) + :company-location #'elisp--company-location + :company-deprecated #'elisp--company-deprecated)) (_ (list nil (elisp--completion-local-symbols) :predicate #'elisp--shorthand-aware-fboundp :company-kind #'elisp--company-kind :company-doc-buffer #'elisp--company-doc-buffer :company-docsig #'elisp--company-doc-string :company-location #'elisp--company-location + :company-deprecated #'elisp--company-deprecated )))))))) (nconc (list beg end) (if (null (car table-etc)) @@ -743,6 +744,11 @@ functions are annotated with \"<f>\" via the ((facep sym) 'color) (t 'text)))) +(defun elisp--company-deprecated (str) + (let ((sym (intern-soft str))) + (or (get sym 'byte-obsolete-variable) + (get sym 'byte-obsolete-info)))) + (defun lisp-completion-at-point (&optional _predicate) (declare (obsolete elisp-completion-at-point "25.1")) (elisp-completion-at-point)) @@ -1190,16 +1196,14 @@ namespace but with lower confidence." ;;; Elisp Interaction mode -(defvar lisp-interaction-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map lisp-mode-shared-map) - (define-key map "\e\C-x" 'eval-defun) - (define-key map "\e\C-q" 'indent-pp-sexp) - (define-key map "\e\t" 'completion-at-point) - (define-key map "\n" 'eval-print-last-sexp) - map) - "Keymap for Lisp Interaction mode. -All commands in `lisp-mode-shared-map' are inherited by this map.") +(defvar-keymap lisp-interaction-mode-map + :doc "Keymap for Lisp Interaction mode. +All commands in `lisp-mode-shared-map' are inherited by this map." + :parent lisp-mode-shared-map + "C-M-x" #'eval-defun + "C-M-q" #'indent-pp-sexp + "M-TAB" #'completion-at-point + "C-j" #'eval-print-last-sexp) (easy-menu-define lisp-interaction-mode-menu lisp-interaction-mode-map "Menu for Lisp Interaction mode." diff --git a/lisp/progmodes/erts-mode.el b/lisp/progmodes/erts-mode.el new file mode 100644 index 00000000000..a12c964c250 --- /dev/null +++ b/lisp/progmodes/erts-mode.el @@ -0,0 +1,225 @@ +;;; erts-mode.el --- major mode to edit erts files -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; Keywords: 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: + +;;; Code: + +(eval-when-compile (require 'cl-lib)) +(require 'ert) + +(defgroup erts-mode nil + "Major mode for editing Emacs test files." + :group 'lisp) + +(defface erts-mode-specification-name + '((((class color) + (background dark)) + :foreground "green") + (((class color) + (background light)) + :foreground "cornflower blue") + (t + :bold t)) + "Face used for displaying specification names." + :group 'erts-mode) + +(defface erts-mode-specification-value + '((((class color) + (background dark)) + :foreground "DeepSkyBlue1") + (((class color) + (background light)) + :foreground "blue") + (t + :bold t)) + "Face used for displaying specificaton values." + :group 'erts-mode) + +(defface erts-mode-start-test + '((t :inherit font-lock-keyword-face)) + "Face used for displaying specificaton test start markers." + :group 'erts-mode) + +(defface erts-mode-end-test + '((t :inherit font-lock-comment-face)) + "Face used for displaying specificaton test start markers." + :group 'erts-mode) + +(defvar erts-mode-map + (let ((map (make-keymap))) + (set-keymap-parent map prog-mode-map) + (define-key map "\C-c\C-r" 'erts-tag-region) + (define-key map "\C-c\C-c" 'erts-run-test) + map)) + +(defvar erts-mode-font-lock-keywords + ;; Specifications. + `((erts-mode--match-not-in-test + ("^\\([^ \t\n:]+:\\)[ \t]*\\(.*\\(\n[ \t].*\\)*\\)\n?" + (progn (goto-char (match-beginning 0)) (match-end 0)) nil + (1 'erts-mode-specification-name) + (2 'erts-mode-specification-value))) + ("^=-=$" 0 'erts-mode-start-test) + ("^=-=-=$" 0 'erts-mode-end-test))) + +(defun erts-mode--match-not-in-test (_limit) + (when (erts-mode--in-test-p (point)) + (erts-mode--end-of-test)) + (let ((start (point))) + (goto-char + (if (re-search-forward "^=-=$" nil t) + (match-beginning 0) + (point-max))) + (if (< (point) start) + nil + ;; Here we disregard LIMIT so that we may extend the area again. + (set-match-data (list start (point))) + (point)))) + +(defun erts-mode--end-of-test () + (search-forward "^=-=-=\n" nil t)) + +(defun erts-mode--in-test-p (point) + "Say whether POINT is in a test." + (save-excursion + (goto-char point) + (beginning-of-line) + (if (looking-at "=-=\\(-=\\)?$") + t + (let ((test-start (save-excursion + (re-search-backward "^=-=\n" nil t)))) + ;; Before the first test. + (and test-start + (let ((test-end (re-search-backward "^=-=-=\n" nil t))) + (or (null test-end) + ;; Between tests. + (> test-start test-end)))))))) + +;;;###autoload +(define-derived-mode erts-mode prog-mode "erts" + "Major mode for editing erts (Emacs testing) files. +This mode mainly provides some font locking. + +\\{erts-mode-map}" + (setq-local font-lock-defaults '(erts-mode-font-lock-keywords t))) + +(defun erts-tag-region (start end name) + "Tag the region between START and END as a test. +Interactively, this is the region. + +NAME should be a string appropriate for output by ert if the test fails. +If NAME is nil or the empty string, a name will be auto-generated." + (interactive "r\nsTest name: " erts-mode) + ;; Automatically make a name. + (when (zerop (length name)) + (save-excursion + (goto-char (point-min)) + (let ((names nil)) + (while (re-search-forward "^Name:[ \t]*\\(.*\\)" nil t) + (let ((name (match-string 1))) + (unless (erts-mode--in-test-p (point)) + (push name names)))) + (setq name + (cl-loop with base = (file-name-sans-extension (buffer-name)) + for i from 1 + for name = (format "%s%d" base i) + unless (member name names) + return name))))) + (save-excursion + (goto-char end) + (unless (bolp) + (insert "\n")) + (insert "=-=-=\n") + (goto-char start) + (insert "Name: " name "\n\n") + (insert "=-=\n"))) + +(defun erts-mode--preceding-spec (name) + (save-excursion + ;; Find the name, but skip if it's in a test. + (while (and (re-search-backward (format "^%s:" name) nil t) + (erts-mode--in-test-p (point)))) + (and (not (erts-mode--in-test-p (point))) + (re-search-forward "^=-=$" nil t) + (progn + (goto-char (match-beginning 0)) + (cdr (assq (intern (downcase name)) + (ert--erts-specifications (point)))))))) + +(defun erts-run-test (test-function &optional verbose) + "Run the current test. +If the current erts file doesn't define a test function, the user +will be prompted for one. + +If VERBOSE (interactively, the prefix), display a diff of the +expected results and the actual results in a separate buffer." + (interactive + (list (or (erts-mode--preceding-spec "Code") + (read-string "Transformation function: ")) + current-prefix-arg) + erts-mode) + (save-excursion + (erts-mode--goto-start-of-test) + (condition-case arg + (ert-test--erts-test + (list (cons 'dummy t) + (cons 'code (car (read-from-string test-function))) + (cons 'point-char (erts-mode--preceding-spec "Point-Char"))) + (buffer-file-name)) + (:success (message "Test successful")) + (ert-test-failed + (if (not verbose) + (message "Test failure; result: \n%s" + (substring-no-properties (cadr (cadr arg)))) + (message "Test failure") + (let (expected got) + (unwind-protect + (progn + (with-current-buffer + (setq expected (generate-new-buffer "erts expected")) + (insert (nth 1 (cadr arg)))) + (with-current-buffer + (setq got (generate-new-buffer "erts results")) + (insert (nth 2 (cadr arg)))) + (diff-buffers expected got)) + (kill-buffer expected) + (kill-buffer got)))))))) + +(defun erts-mode--goto-start-of-test () + (if (not (erts-mode--in-test-p (point))) + (re-search-forward "^=-=\n" nil t) + (re-search-backward "^=-=\n" nil t) + (let ((potential-start (match-end 0))) + ;; See if we're in a two-clause ("before" and "after") test or not. + (if-let ((start (and (save-excursion (re-search-backward "^=-=\n" nil t)) + (match-end 0)))) + (let ((end (save-excursion (re-search-backward "^=-=-=\n" nil t)))) + (if (or (not end) + (> start end)) + ;; We are, so go to the real start. + (goto-char start) + (goto-char potential-start))) + (goto-char potential-start))))) + +(provide 'erts-mode) + +;;; erts-mode.el ends here diff --git a/lisp/progmodes/etags.el b/lisp/progmodes/etags.el index f53b09d9e8c..d7dbaa06505 100644 --- a/lisp/progmodes/etags.el +++ b/lisp/progmodes/etags.el @@ -145,7 +145,9 @@ Otherwise, `find-tag-default' is used." :type '(choice (const nil) function)) (define-obsolete-variable-alias 'find-tag-marker-ring-length - 'xref-marker-ring-length "25.1") + 'tags-location-ring-length "25.1") + +(defvar tags-location-ring-length 16) (defcustom tags-tag-face 'default "Face for tags in the output of `tags-apropos'." @@ -180,10 +182,11 @@ Example value: (sexp :tag "Tags to search"))) :version "21.1") -(defvaralias 'find-tag-marker-ring 'xref--marker-ring) +;; Obsolete variable kept for compatibility. We don't use it in any way. +(defvar find-tag-marker-ring (make-ring 16)) (make-obsolete-variable 'find-tag-marker-ring - "use `xref-push-marker-stack' or `xref-pop-marker-stack' instead." + "use `xref-push-marker-stack' or `xref-go-back' instead." "25.1") (defvar default-tags-table-function nil @@ -191,7 +194,7 @@ Example value: This function receives no arguments and should return the default tags table file to use for the current buffer.") -(defvar tags-location-ring (make-ring xref-marker-ring-length) +(defvar tags-location-ring (make-ring tags-location-ring-length) "Ring of markers which are locations visited by \\[find-tag]. Pop back to the last location with \\[negative-argument] \\[find-tag].") @@ -292,7 +295,7 @@ file the tag was in." (or (locate-dominating-file default-directory "TAGS") default-directory))) (list (read-file-name - "Visit tags table (default TAGS): " + (format-prompt "Visit tags table" "TAGS") ;; default to TAGS from default-directory up to root. default-tag-dir (expand-file-name "TAGS" default-tag-dir) @@ -625,7 +628,7 @@ Returns t if it visits a tags table, or nil if there are no more in the list." (car list)) ;; Finally, prompt the user for a file name. (expand-file-name - (read-file-name "Visit tags table (default TAGS): " + (read-file-name (format-prompt "Visit tags table" "TAGS") default-directory "TAGS" t)))))) @@ -731,13 +734,13 @@ Returns t if it visits a tags table, or nil if there are no more in the list." (interactive) ;; Clear out the markers we are throwing away. (let ((i 0)) - (while (< i xref-marker-ring-length) + (while (< i tags-location-ring-length) (if (aref (cddr tags-location-ring) i) (set-marker (aref (cddr tags-location-ring) i) nil)) (setq i (1+ i)))) (xref-clear-marker-stack) (setq tags-file-name nil - tags-location-ring (make-ring xref-marker-ring-length) + tags-location-ring (make-ring tags-location-ring-length) tags-table-list nil tags-table-computed-list nil tags-table-computed-list-for nil @@ -1068,7 +1071,7 @@ See documentation of variable `tags-file-name'." regexp next-p t)) ;;;###autoload -(defalias 'pop-tag-mark 'xref-pop-marker-stack) +(defalias 'pop-tag-mark 'xref-go-back) (defvar tag-lines-already-matched nil @@ -1989,7 +1992,8 @@ see the doc of that variable if you want to add names to the list." (setq set-list (delete (car set-list) set-list))) (goto-char (point-min)) (insert-before-markers - "Type `t' to select a tags table or set of tags tables:\n\n") + (substitute-command-keys + "Type \\`t' to select a tags table or set of tags tables:\n\n")) (if desired-point (goto-char desired-point)) (set-window-start (selected-window) 1 t)) diff --git a/lisp/progmodes/f90.el b/lisp/progmodes/f90.el index f9e6101e7ab..eb6da20ff7f 100644 --- a/lisp/progmodes/f90.el +++ b/lisp/progmodes/f90.el @@ -345,6 +345,7 @@ The options are `downcase-word', `upcase-word', `capitalize-word' and nil." ;; there are spaces. "contiguous" "submodule" "concurrent" "codimension" "sync all" "sync memory" "critical" "image_index" "error stop" + "impure" )) "\\_>") "Regexp used by the function `f90-change-keywords'.") @@ -646,7 +647,7 @@ do\\([ \t]*while\\)?\\|select[ \t]*\\(?:case\\|type\\)\\|where\\|\ forall\\|block\\|critical\\)\\)\\_>" (2 font-lock-constant-face nil t) (3 font-lock-keyword-face)) ;; Implicit declaration. - '("\\_<\\(implicit\\)[ \t]*\\(real\\|integer\\|c\\(haracter\\|omplex\\)\ + '("\\_<\\(implicit\\)[ \t]+\\(real\\|integer\\|c\\(haracter\\|omplex\\)\ \\|enumerator\\|procedure\\|\ logical\\|double[ \t]*precision\\|type[ \t]*(\\(?:\\sw\\|\\s_\\)+)\\|none\\)[ \t]*" (1 font-lock-keyword-face) (2 font-lock-type-face)) @@ -656,8 +657,10 @@ logical\\|double[ \t]*precision\\|type[ \t]*(\\(?:\\sw\\|\\s_\\)+)\\|none\\)[ \t '("\\(&\\)[ \t]*\\(!\\|$\\)" (1 font-lock-keyword-face)) "\\_<\\(then\\|continue\\|format\\|include\\|\\(?:error[ \t]+\\)?stop\\|\ return\\)\\_>" - '("\\_<\\(exit\\|cycle\\)[ \t]*\\(\\(?:\\sw\\|\\s_\\)+\\)?\\_>" + '("\\_<\\(exit\\|cycle\\)[ \t]+\\(\\(?:\\sw\\|\\s_\\)+\\)?\\_>" (1 font-lock-keyword-face) (2 font-lock-constant-face nil t)) + '("\\_<\\(exit\\|cycle\\)\\_>" + (1 font-lock-keyword-face)) '("\\_<\\(case\\)[ \t]*\\(default\\|(\\)" . 1) ;; F2003 "class default". '("\\_<\\(class\\)[ \t]*default" . 1) diff --git a/lisp/progmodes/gdb-mi.el b/lisp/progmodes/gdb-mi.el index 66adc4e9ef8..409ff940d96 100644 --- a/lisp/progmodes/gdb-mi.el +++ b/lisp/progmodes/gdb-mi.el @@ -1266,7 +1266,7 @@ Used by Speedbar." :version "22.1") (define-key gud-minor-mode-map "\C-c\C-w" 'gud-watch) -(define-key global-map (vconcat gud-key-prefix "\C-w") 'gud-watch) +(keymap-set gud-global-map "C-w" 'gud-watch) (declare-function tooltip-identifier-from-point "tooltip" (point)) @@ -1612,6 +1612,7 @@ this trigger is subscribed to `gdb-buf-publisher' and called with ;; Used to display windows with thread-bound buffers (defmacro def-gdb-preempt-display-buffer (name buffer &optional doc split-horizontal) + (declare (indent defun)) `(defun ,name (&optional thread) ,(when doc doc) (message "%s" thread) @@ -3012,6 +3013,7 @@ calling `gdb-current-context-command'). Triggers defined by this command are meant to be used as a trigger argument when describing buffer types with `gdb-set-buffer-rules'." + (declare (indent defun)) `(defun ,trigger-name (&optional signal) (when (or (not ,signal-list) @@ -3032,6 +3034,7 @@ Erase current buffer and evaluate CUSTOM-DEFUN. Then call `gdb-update-buffer-name'. If NOPRESERVE is non-nil, window point is not restored after CUSTOM-DEFUN." + (declare (indent defun)) `(defun ,handler-name () (let* ((inhibit-read-only t) ,@(unless nopreserve @@ -3055,6 +3058,7 @@ See `def-gdb-auto-update-trigger'. HANDLER-NAME handler uses customization of CUSTOM-DEFUN. See `def-gdb-auto-update-handler'." + (declare (indent defun)) `(progn (def-gdb-auto-update-trigger ,trigger-name ,gdb-command @@ -3473,6 +3477,7 @@ corresponding to the mode line clicked." CUSTOM-DEFUN may use locally bound `thread' variable, which will be the value of `gdb-thread' property of the current line. If `gdb-thread' is nil, error is signaled." + (declare (indent defun)) `(defun ,name (&optional event) ,(when doc doc) (interactive (list last-input-event)) @@ -3488,6 +3493,7 @@ If `gdb-thread' is nil, error is signaled." &optional doc) "Define a NAME which will call BUFFER-COMMAND with id of thread on the current line." + (declare (indent defun)) `(def-gdb-thread-buffer-command ,name (,buffer-command (gdb-mi--field thread 'id)) ,doc)) @@ -3543,6 +3549,7 @@ on the current line." "Define a NAME which will execute GUD-COMMAND with `gdb-thread-number' locally bound to id of thread on the current line." + (declare (indent defun)) `(def-gdb-thread-buffer-command ,name (if gdb-non-stop (let ((gdb-thread-number (gdb-mi--field thread 'id)) @@ -3711,6 +3718,7 @@ in `gdb-memory-format'." (defmacro def-gdb-set-positive-number (name variable echo-string &optional doc) "Define a function NAME which reads new VAR value from minibuffer." + (declare (indent defun)) `(defun ,name (event) ,(when doc doc) (interactive "e") @@ -3739,6 +3747,7 @@ in `gdb-memory-format'." "Define a function NAME to switch memory buffer to use FORMAT. DOC is an optional documentation string." + (declare (indent defun)) `(defun ,name () ,(when doc doc) (interactive) (customize-set-variable 'gdb-memory-format ,format) @@ -3808,6 +3817,7 @@ DOC is an optional documentation string." "Define a function NAME to switch memory unit size to UNIT-SIZE. DOC is an optional documentation string." + (declare (indent defun)) `(defun ,name () ,(when doc doc) (interactive) (customize-set-variable 'gdb-memory-unit ,unit-size) @@ -3832,6 +3842,7 @@ The defined function switches Memory buffer to show address stored in ADDRESS-VAR variable. DOC is an optional documentation string." + (declare (indent defun)) `(defun ,name ,(when doc doc) (interactive) diff --git a/lisp/progmodes/grep.el b/lisp/progmodes/grep.el index 9be3af79f9d..70c55c01dd7 100644 --- a/lisp/progmodes/grep.el +++ b/lisp/progmodes/grep.el @@ -1057,11 +1057,9 @@ REGEXP is used as a string in the prompt." default-extension (car grep-files-history) (car (car grep-files-aliases)))) - (files (completing-read - (concat "Search for \"" regexp - "\" in files matching wildcard" - (if default (concat " (default " default ")")) - ": ") + (files (completing-read + (format-prompt "Search for \"%s\" in files matching wildcard" + default regexp) #'read-file-name-internal nil nil nil 'grep-files-history (delete-dups diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el index 2061d414802..d5bd2655174 100644 --- a/lisp/progmodes/gud.el +++ b/lisp/progmodes/gud.el @@ -90,8 +90,10 @@ pdb (Python), and jdb." "Prefix of all GUD commands valid in C buffers." :type 'key-sequence) -(global-set-key (vconcat gud-key-prefix "\C-l") #'gud-refresh) -;; (define-key ctl-x-map " " 'gud-break); backward compatibility hack +(defvar-keymap gud-global-map + "C-l" #'gud-refresh) + +(global-set-key gud-key-prefix gud-global-map) (defvar gud-marker-filter nil) (put 'gud-marker-filter 'permanent-local t) @@ -433,7 +435,7 @@ we're in the GUD buffer)." ;; Unused lexical warning if cmd does not use "arg". cmd)))) ,(if key `(local-set-key ,(concat "\C-c" key) #',func)) - ,(if key `(global-set-key (vconcat gud-key-prefix ,key) #',func)))) + ,(if key `(define-key gud-global-map ,key #',func)))) ;; Where gud-display-frame should put the debugging arrow; a cons of ;; (filename . line-number). This is set by the marker-filter, which scans @@ -3539,8 +3541,8 @@ Treats actions as defuns." #'gdb-script-end-of-defun) (setq-local font-lock-defaults '(gdb-script-font-lock-keywords nil nil ((?_ . "w")) nil - (font-lock-syntactic-face-function - . gdb-script-font-lock-syntactic-face))) + (font-lock-syntactic-face-function + . gdb-script-font-lock-syntactic-face))) ;; Recognize docstrings. (setq-local syntax-propertize-function gdb-script-syntax-propertize-function) diff --git a/lisp/progmodes/hideif.el b/lisp/progmodes/hideif.el index a18a67249ae..538ec4df804 100644 --- a/lisp/progmodes/hideif.el +++ b/lisp/progmodes/hideif.el @@ -181,30 +181,24 @@ Effective only if `hide-ifdef-expand-reinclusion-guard' is t." :type 'regexp :version "25.1") -(defvar hide-ifdef-mode-submap +(defvar-keymap hide-ifdef-mode-submap + :doc "Keymap used by `hide-ifdef-mode' under `hide-ifdef-mode-prefix-key'." ;; Set up the submap that goes after the prefix key. - (let ((map (make-sparse-keymap))) - (define-key map "d" 'hide-ifdef-define) - (define-key map "u" 'hide-ifdef-undef) - (define-key map "D" 'hide-ifdef-set-define-alist) - (define-key map "U" 'hide-ifdef-use-define-alist) - - (define-key map "h" 'hide-ifdefs) - (define-key map "s" 'show-ifdefs) - (define-key map "\C-d" 'hide-ifdef-block) - (define-key map "\C-s" 'show-ifdef-block) - (define-key map "e" 'hif-evaluate-macro) - (define-key map "C" 'hif-clear-all-ifdef-defined) - - (define-key map "\C-q" 'hide-ifdef-toggle-read-only) - (define-key map "\C-w" 'hide-ifdef-toggle-shadowing) - (substitute-key-definition - 'read-only-mode 'hide-ifdef-toggle-outside-read-only map) - ;; `toggle-read-only' is obsoleted by `read-only-mode'. - (substitute-key-definition - 'toggle-read-only 'hide-ifdef-toggle-outside-read-only map) - map) - "Keymap used by `hide-ifdef-mode' under `hide-ifdef-mode-prefix-key'.") + "d" #'hide-ifdef-define + "u" #'hide-ifdef-undef + "D" #'hide-ifdef-set-define-alist + "U" #'hide-ifdef-use-define-alist + "h" #'hide-ifdefs + "s" #'show-ifdefs + "C-d" #'hide-ifdef-block + "C-s" #'show-ifdef-block + "e" #'hif-evaluate-macro + "C" #'hif-clear-all-ifdef-defined + "C-q" #'hide-ifdef-toggle-read-only + "C-w" #'hide-ifdef-toggle-shadowing + "<remap> <read-only-mode>" #'hide-ifdef-toggle-outside-read-only + ;; `toggle-read-only' is obsoleted by `read-only-mode'. + "<remap> <toggle-read-only>" #'hide-ifdef-toggle-outside-read-only) (defcustom hide-ifdef-mode-prefix-key "\C-c@" "Prefix key for all Hide-Ifdef mode commands." @@ -2456,7 +2450,7 @@ This allows #ifdef VAR to be hidden." (t nil)))) (var (read-minibuffer "Define what? " default)) - (val (read-from-minibuffer (format "Set %s to? (default 1): " var) + (val (read-from-minibuffer (format-prompt "Set %s to?" "1" var) nil nil t nil "1"))) (list var val))) (hif-set-var var (or val 1)) diff --git a/lisp/progmodes/idlw-shell.el b/lisp/progmodes/idlw-shell.el index 5a31ad35087..ded3a9c463c 100644 --- a/lisp/progmodes/idlw-shell.el +++ b/lisp/progmodes/idlw-shell.el @@ -817,7 +817,7 @@ IDL has currently stepped.") Command history, searching of previous commands, command line editing are available via the comint-mode key bindings, by default - mostly on the key `C-c'. Command history is also available with + mostly on the key \\`C-c'. Command history is also available with the arrow keys UP and DOWN. 2. Completion @@ -1327,7 +1327,7 @@ See also the variable `idlwave-shell-input-mode-spells'." Characters are sent one by one, without newlines. The loop is blocking and intercepts all input events to Emacs. You can use this command to interact with the IDL command GET_KBRD. -The loop can be aborted by typing `C-g'. The loop also exits automatically +The loop can be aborted by typing \\[keyboard-quit]. The loop also exits automatically when the IDL prompt gets displayed again after the current IDL command." (interactive) @@ -1342,7 +1342,8 @@ when the IDL prompt gets displayed again after the current IDL command." (funcall errf "No IDL program seems to be waiting for input")) ;; OK, start the loop - (message "Character mode on: Sending single chars (`C-g' to exit)") + (message (substitute-command-keys + "Character mode on: Sending single chars (\\[keyboard-quit] to exit)")) (message (catch 'exit (while t diff --git a/lisp/progmodes/js.el b/lisp/progmodes/js.el index 845ca8609d7..9303f1ecb91 100644 --- a/lisp/progmodes/js.el +++ b/lisp/progmodes/js.el @@ -33,7 +33,7 @@ ;; The main features of this JavaScript mode are syntactic ;; highlighting (enabled with `font-lock-mode' or ;; `global-font-lock-mode'), automatic indentation and filling of -;; comments, C preprocessor fontification, and MozRepl integration. +;; comments, and C preprocessor fontification. ;; ;; General Remarks: ;; @@ -51,7 +51,6 @@ (require 'cc-fonts)) (require 'newcomment) (require 'imenu) -(require 'moz nil t) (require 'json) (require 'prog-mode) @@ -59,12 +58,9 @@ (require 'cl-lib) (require 'ido)) -(defvar inferior-moz-buffer) -(defvar moz-repl-name) (defvar ido-cur-list) (defvar electric-layout-rules) (declare-function ido-mode "ido" (&optional arg)) -(declare-function inferior-moz-process "ext:mozrepl" ()) ;;; Constants @@ -95,7 +91,7 @@ name.") (defconst js--plain-method-re (concat "^\\s-*?\\(" js--dotted-name-re "\\)\\.prototype" - "\\.\\(" js--name-re "\\)\\s-*?=\\s-*?\\(function\\)\\_>") + "\\.\\(" js--name-re "\\)\\s-*?=\\s-*?\\(\\(:?async[ \t\n]+\\)function\\)\\_>") "Regexp matching an explicit JavaScript prototype \"method\" declaration. Group 1 is a (possibly-dotted) class name, group 2 is a method name, and group 3 is the `function' keyword.") @@ -485,25 +481,22 @@ seldom use, either globally or on a per-buffer basis." (list 'const x)) js--available-frameworks))) -(defcustom js-js-switch-tabs - (and (memq system-type '(darwin)) t) +(defvar js-js-switch-tabs (and (memq system-type '(darwin)) t) "Whether `js-mode' should display tabs while selecting them. This is useful only if the windowing system has a good mechanism -for preventing Firefox from stealing the keyboard focus." - :type 'boolean) +for preventing Firefox from stealing the keyboard focus.") +(make-obsolete-variable 'js-js-switch-tabs "MozRepl no longer exists" "28.1") -(defcustom js-js-tmpdir - (locate-user-emacs-file "js/js") +(defvar js-js-tmpdir (locate-user-emacs-file "js/js") "Temporary directory used by `js-mode' to communicate with Mozilla. -This directory must be readable and writable by both Mozilla and Emacs." - :type 'directory - :version "28.1") +This directory must be readable and writable by both Mozilla and Emacs.") +(make-obsolete-variable 'js-js-tmpdir "MozRepl no longer exists" "28.1") -(defcustom js-js-timeout 5 +(defvar js-js-timeout 5 "Reply timeout for executing commands in Mozilla via `js-mode'. The value is given in seconds. Increase this value if you are -getting timeout messages." - :type 'integer) +getting timeout messages.") +(make-obsolete-variable 'js-js-timeout "MozRepl no longer exists" "28.1") (defcustom js-indent-first-init nil "Non-nil means specially indent the first variable declaration's initializer. @@ -671,18 +664,7 @@ This variable is like `sgml-attribute-offset'." (defvar js-mode-map (let ((keymap (make-sparse-keymap))) - (define-key keymap [(control ?c) (meta ?:)] #'js-eval) - (define-key keymap [(control ?c) (control ?j)] #'js-set-js-context) - (define-key keymap [(control meta ?x)] #'js-eval-defun) (define-key keymap [(meta ?.)] #'js-find-symbol) - (easy-menu-define nil keymap "JavaScript Menu" - '("JavaScript" - ["Select New Mozilla Context..." js-set-js-context - (fboundp #'inferior-moz-process)] - ["Evaluate Expression in Mozilla Context..." js-eval - (fboundp #'inferior-moz-process)] - ["Send Current Function to Mozilla..." js-eval-defun - (fboundp #'inferior-moz-process)])) keymap) "Keymap for `js-mode'.") @@ -932,9 +914,10 @@ This puts point at the `function' keyword. If this is a syntactically-correct non-expression function, return the name of the function, or t if the name could not be determined. Otherwise, return nil." - (cl-assert (looking-at "\\_<function\\_>")) + (unless (looking-at "\\(\\_<async\\_>[ \t\n]+\\)?\\_<function\\_>") + (error "Invalid position")) (let ((name t)) - (forward-word-strictly) + (goto-char (match-end 0)) (forward-comment most-positive-fixnum) (when (eq (char-after) ?*) (forward-char) @@ -970,14 +953,17 @@ If POS is not in a function prologue, return nil." (goto-char (match-end 0)))) (skip-syntax-backward "w_") - (and (or (looking-at "\\_<function\\_>") - (js--re-search-backward "\\_<function\\_>" nil t)) - - (save-match-data (goto-char (match-beginning 0)) - (js--forward-function-decl)) - - (<= pos (point)) - (or prologue-begin (match-beginning 0)))))) + (let ((start nil)) + (and (or (looking-at "\\_<function\\_>") + (js--re-search-backward "\\_<function\\_>" nil t)) + (progn + (setq start (match-beginning 0)) + (goto-char start) + (when (looking-back "\\_<async\\_>[ \t\n]+" (- (point) 30)) + (setq start (match-beginning 0))) + (js--forward-function-decl)) + (<= pos (point)) + (or prologue-begin start)))))) (defun js--beginning-of-defun-raw () "Helper function for `js-beginning-of-defun'. @@ -1247,7 +1233,6 @@ LIMIT defaults to point." ;; Regular function declaration ((and (looking-at "\\_<function\\_>") (setq name (js--forward-function-decl))) - (when (eq name t) (setq name (js--guess-function-name orig-match-end)) (if name @@ -1259,6 +1244,11 @@ LIMIT defaults to point." (cl-assert (eq (char-after) ?{)) (forward-char) + (save-excursion + (goto-char orig-match-start) + (when (looking-back "\\_<async\\_>[ \t\n]+" + (- (point) 30)) + (setq orig-match-start (match-beginning 0)))) (make-js--pitem :paren-depth orig-depth :h-begin orig-match-start @@ -3308,10 +3298,7 @@ marker." (setf (car bounds) (point)))) (buffer-substring (car bounds) (cdr bounds))))) -(defvar find-tag-marker-ring) ; etags - -;; etags loads ring. -(declare-function ring-insert "ring" (ring item)) +(declare-function xref-push-marker-stack "xref" (&optional m)) (defun js-find-symbol (&optional arg) "Read a JavaScript symbol and jump to it. @@ -3319,7 +3306,7 @@ With a prefix argument, restrict symbols to those from the current buffer. Pushes a mark onto the tag ring just like `find-tag'." (interactive "P") - (require 'etags) + (require 'xref) (let (symbols marker) (if (not arg) (setq symbols (js--get-all-known-symbols)) @@ -3331,1111 +3318,11 @@ current buffer. Pushes a mark onto the tag ring just like symbols "Jump to: " (js--guess-symbol-at-point)))) - (ring-insert find-tag-marker-ring (point-marker)) + (xref-push-marker-stack) (switch-to-buffer (marker-buffer marker)) (push-mark) (goto-char marker))) -;;; MozRepl integration - -(define-error 'js-moz-bad-rpc "Mozilla RPC Error") ;; '(timeout error)) -(define-error 'js-js-error "JavaScript Error") ;; '(js-error error)) - -(defun js--wait-for-matching-output - (process regexp timeout &optional start) - "Wait TIMEOUT seconds for PROCESS to output a match for REGEXP. -On timeout, return nil. On success, return t with match data -set. If START is non-nil, look for output starting from START. -Otherwise, use the current value of `process-mark'." - (with-current-buffer (process-buffer process) - (cl-loop with start-pos = (or start - (marker-position (process-mark process))) - with end-time = (time-add nil timeout) - for time-left = (float-time (time-subtract end-time nil)) - do (goto-char (point-max)) - if (looking-back regexp start-pos) return t - while (> time-left 0) - do (accept-process-output process time-left nil t) - do (goto-char (process-mark process)) - finally do (signal - 'js-moz-bad-rpc - (list (format "Timed out waiting for output matching %S" regexp)))))) - -(cl-defstruct js--js-handle - ;; Integer, mirrors the value we see in JS - (id nil :read-only t) - - ;; Process to which this thing belongs - (process nil :read-only t)) - -(defun js--js-handle-expired-p (x) - (not (eq (js--js-handle-process x) - (inferior-moz-process)))) - -(defvar js--js-references nil - "Maps Elisp JavaScript proxy objects to their JavaScript IDs.") - -(defvar js--js-process nil - "The most recent MozRepl process object.") - -(defvar js--js-gc-idle-timer nil - "Idle timer for cleaning up JS object references.") - -(defvar js--js-last-gcs-done nil) - -(defconst js--moz-interactor - (replace-regexp-in-string - "[ \n]+" " " - ; */" Make Emacs happy -"(function(repl) { - repl.defineInteractor('js', { - onStart: function onStart(repl) { - if(!repl._jsObjects) { - repl._jsObjects = {}; - repl._jsLastID = 0; - repl._jsGC = this._jsGC; - } - this._input = ''; - }, - - _jsGC: function _jsGC(ids_in_use) { - var objects = this._jsObjects; - var keys = []; - var num_freed = 0; - - for(var pn in objects) { - keys.push(Number(pn)); - } - - keys.sort(function(x, y) x - y); - ids_in_use.sort(function(x, y) x - y); - var i = 0; - var j = 0; - - while(i < ids_in_use.length && j < keys.length) { - var id = ids_in_use[i++]; - while(j < keys.length && keys[j] !== id) { - var k_id = keys[j++]; - delete objects[k_id]; - ++num_freed; - } - ++j; - } - - while(j < keys.length) { - var k_id = keys[j++]; - delete objects[k_id]; - ++num_freed; - } - - return num_freed; - }, - - _mkArray: function _mkArray() { - var result = []; - for(var i = 0; i < arguments.length; ++i) { - result.push(arguments[i]); - } - return result; - }, - - _parsePropDescriptor: function _parsePropDescriptor(parts) { - if(typeof parts === 'string') { - parts = [ parts ]; - } - - var obj = parts[0]; - var start = 1; - - if(typeof obj === 'string') { - obj = window; - start = 0; - } else if(parts.length < 2) { - throw new Error('expected at least 2 arguments'); - } - - for(var i = start; i < parts.length - 1; ++i) { - obj = obj[parts[i]]; - } - - return [obj, parts[parts.length - 1]]; - }, - - _getProp: function _getProp(/*...*/) { - if(arguments.length === 0) { - throw new Error('no arguments supplied to getprop'); - } - - if(arguments.length === 1 && - (typeof arguments[0]) !== 'string') - { - return arguments[0]; - } - - var [obj, propname] = this._parsePropDescriptor(arguments); - return obj[propname]; - }, - - _putProp: function _putProp(properties, value) { - var [obj, propname] = this._parsePropDescriptor(properties); - obj[propname] = value; - }, - - _delProp: function _delProp(propname) { - var [obj, propname] = this._parsePropDescriptor(arguments); - delete obj[propname]; - }, - - _typeOf: function _typeOf(thing) { - return typeof thing; - }, - - _callNew: function(constructor) { - if(typeof constructor === 'string') - { - constructor = window[constructor]; - } else if(constructor.length === 1 && - typeof constructor[0] !== 'string') - { - constructor = constructor[0]; - } else { - var [obj,propname] = this._parsePropDescriptor(constructor); - constructor = obj[propname]; - } - - /* Hacky, but should be robust */ - var s = 'new constructor('; - for(var i = 1; i < arguments.length; ++i) { - if(i != 1) { - s += ','; - } - - s += 'arguments[' + i + ']'; - } - - s += ')'; - return eval(s); - }, - - _callEval: function(thisobj, js) { - return eval.call(thisobj, js); - }, - - getPrompt: function getPrompt(repl) { - return 'EVAL>' - }, - - _lookupObject: function _lookupObject(repl, id) { - if(typeof id === 'string') { - switch(id) { - case 'global': - return window; - case 'nil': - return null; - case 't': - return true; - case 'false': - return false; - case 'undefined': - return undefined; - case 'repl': - return repl; - case 'interactor': - return this; - case 'NaN': - return NaN; - case 'Infinity': - return Infinity; - case '-Infinity': - return -Infinity; - default: - throw new Error('No object with special id:' + id); - } - } - - var ret = repl._jsObjects[id]; - if(ret === undefined) { - throw new Error('No object with id:' + id + '(' + typeof id + ')'); - } - return ret; - }, - - _findOrAllocateObject: function _findOrAllocateObject(repl, value) { - if(typeof value !== 'object' && typeof value !== 'function') { - throw new Error('_findOrAllocateObject called on non-object(' - + typeof(value) + '): ' - + value) - } - - for(var id in repl._jsObjects) { - id = Number(id); - var obj = repl._jsObjects[id]; - if(obj === value) { - return id; - } - } - - var id = ++repl._jsLastID; - repl._jsObjects[id] = value; - return id; - }, - - _fixupList: function _fixupList(repl, list) { - for(var i = 0; i < list.length; ++i) { - if(list[i] instanceof Array) { - this._fixupList(repl, list[i]); - } else if(typeof list[i] === 'object') { - var obj = list[i]; - if(obj.funcall) { - var parts = obj.funcall; - this._fixupList(repl, parts); - var [thisobj, func] = this._parseFunc(parts[0]); - list[i] = func.apply(thisobj, parts.slice(1)); - } else if(obj.objid) { - list[i] = this._lookupObject(repl, obj.objid); - } else { - throw new Error('Unknown object type: ' + obj.toSource()); - } - } - } - }, - - _parseFunc: function(func) { - var thisobj = null; - - if(typeof func === 'string') { - func = window[func]; - } else if(func instanceof Array) { - if(func.length === 1 && typeof func[0] !== 'string') { - func = func[0]; - } else { - [thisobj, func] = this._parsePropDescriptor(func); - func = thisobj[func]; - } - } - - return [thisobj,func]; - }, - - _encodeReturn: function(value, array_as_mv) { - var ret; - - if(value === null) { - ret = ['special', 'null']; - } else if(value === true) { - ret = ['special', 'true']; - } else if(value === false) { - ret = ['special', 'false']; - } else if(value === undefined) { - ret = ['special', 'undefined']; - } else if(typeof value === 'number') { - if(isNaN(value)) { - ret = ['special', 'NaN']; - } else if(value === Infinity) { - ret = ['special', 'Infinity']; - } else if(value === -Infinity) { - ret = ['special', '-Infinity']; - } else { - ret = ['atom', value]; - } - } else if(typeof value === 'string') { - ret = ['atom', value]; - } else if(array_as_mv && value instanceof Array) { - ret = ['array', value.map(this._encodeReturn, this)]; - } else { - ret = ['objid', this._findOrAllocateObject(repl, value)]; - } - - return ret; - }, - - _handleInputLine: function _handleInputLine(repl, line) { - var ret; - var array_as_mv = false; - - try { - if(line[0] === '*') { - array_as_mv = true; - line = line.substring(1); - } - var parts = eval(line); - this._fixupList(repl, parts); - var [thisobj, func] = this._parseFunc(parts[0]); - ret = this._encodeReturn( - func.apply(thisobj, parts.slice(1)), - array_as_mv); - } catch(x) { - ret = ['error', x.toString() ]; - } - - var JSON = Components.classes['@mozilla.org/dom/json;1'].createInstance(Components.interfaces.nsIJSON); - repl.print(JSON.encode(ret)); - repl._prompt(); - }, - - handleInput: function handleInput(repl, chunk) { - this._input += chunk; - var match, line; - while(match = this._input.match(/.*\\n/)) { - line = match[0]; - - if(line === 'EXIT\\n') { - repl.popInteractor(); - repl._prompt(); - return; - } - - this._input = this._input.substring(line.length); - this._handleInputLine(repl, line); - } - } - }); -}) -") - - "String to set MozRepl up into a simple-minded evaluation mode.") - -(defun js--js-encode-value (x) - "Marshall the given value for JS. -Strings and numbers are JSON-encoded. Lists (including nil) are -made into JavaScript array literals and their contents encoded -with `js--js-encode-value'." - (cond ((or (stringp x) (numberp x)) (json-encode x)) - ((symbolp x) (format "{objid:%S}" (symbol-name x))) - ((js--js-handle-p x) - - (when (js--js-handle-expired-p x) - (error "Stale JS handle")) - - (format "{objid:%s}" (js--js-handle-id x))) - - ((sequencep x) - (if (eq (car-safe x) 'js--funcall) - (format "{funcall:[%s]}" - (mapconcat #'js--js-encode-value (cdr x) ",")) - (concat - "[" (mapconcat #'js--js-encode-value x ",") "]"))) - (t - (error "Unrecognized item: %S" x)))) - -(defconst js--js-prompt-regexp "\\(repl[0-9]*\\)> $") -(defconst js--js-repl-prompt-regexp "^EVAL>$") -(defvar js--js-repl-depth 0) - -(defun js--js-wait-for-eval-prompt () - (js--wait-for-matching-output - (inferior-moz-process) - js--js-repl-prompt-regexp js-js-timeout - - ;; start matching against the beginning of the line in - ;; order to catch a prompt that's only partially arrived - (save-excursion (forward-line 0) (point)))) - -;; Presumably "inferior-moz-process" loads comint. -(declare-function comint-send-string "comint" (process string)) -(declare-function comint-send-input "comint" - (&optional no-newline artificial)) - -(defun js--js-enter-repl () - (inferior-moz-process) ; called for side-effect - (with-current-buffer inferior-moz-buffer - (goto-char (point-max)) - - ;; Do some initialization the first time we see a process - (unless (eq (inferior-moz-process) js--js-process) - (setq js--js-process (inferior-moz-process)) - (setq js--js-references (make-hash-table :test 'eq :weakness t)) - (setq js--js-repl-depth 0) - - ;; Send interactor definition - (comint-send-string js--js-process js--moz-interactor) - (comint-send-string js--js-process - (concat "(" moz-repl-name ")\n")) - (js--wait-for-matching-output - (inferior-moz-process) js--js-prompt-regexp - js-js-timeout)) - - ;; Sanity check - (when (looking-back js--js-prompt-regexp - (save-excursion (forward-line 0) (point))) - (setq js--js-repl-depth 0)) - - (if (> js--js-repl-depth 0) - ;; If js--js-repl-depth > 0, we *should* be seeing an - ;; EVAL> prompt. If we don't, give Mozilla a chance to catch - ;; up with us. - (js--js-wait-for-eval-prompt) - - ;; Otherwise, tell Mozilla to enter the interactor mode - (insert (match-string-no-properties 1) - ".pushInteractor('js')") - (comint-send-input nil t) - (js--wait-for-matching-output - (inferior-moz-process) js--js-repl-prompt-regexp - js-js-timeout)) - - (cl-incf js--js-repl-depth))) - -(defun js--js-leave-repl () - (cl-assert (> js--js-repl-depth 0)) - (when (= 0 (cl-decf js--js-repl-depth)) - (with-current-buffer inferior-moz-buffer - (goto-char (point-max)) - (js--js-wait-for-eval-prompt) - (insert "EXIT") - (comint-send-input nil t) - (js--wait-for-matching-output - (inferior-moz-process) js--js-prompt-regexp - js-js-timeout)))) - -(defsubst js--js-not (value) - (memq value '(nil null false undefined))) - -(defsubst js--js-true (value) - (not (js--js-not value))) - -(eval-and-compile - (defun js--optimize-arglist (arglist) - "Convert immediate js< and js! references to deferred ones." - (cl-loop for item in arglist - if (eq (car-safe item) 'js<) - collect (append (list 'list ''js--funcall - '(list 'interactor "_getProp")) - (js--optimize-arglist (cdr item))) - else if (eq (car-safe item) 'js>) - collect (append (list 'list ''js--funcall - '(list 'interactor "_putProp")) - - (if (atom (cadr item)) - (list (cadr item)) - (list - (append - (list 'list ''js--funcall - '(list 'interactor "_mkArray")) - (js--optimize-arglist (cadr item))))) - (js--optimize-arglist (cddr item))) - else if (eq (car-safe item) 'js!) - collect (pcase-let ((`(,_ ,function . ,body) item)) - (append (list 'list ''js--funcall - (if (consp function) - (cons 'list - (js--optimize-arglist function)) - function)) - (js--optimize-arglist body))) - else - collect item))) - -(defmacro js--js-get-service (class-name interface-name) - `(js! ("Components" "classes" ,class-name "getService") - (js< "Components" "interfaces" ,interface-name))) - -(defmacro js--js-create-instance (class-name interface-name) - `(js! ("Components" "classes" ,class-name "createInstance") - (js< "Components" "interfaces" ,interface-name))) - -(defmacro js--js-qi (object interface-name) - `(js! (,object "QueryInterface") - (js< "Components" "interfaces" ,interface-name))) - -(defmacro with-js (&rest forms) - "Run FORMS with the Mozilla repl set up for js commands. -Inside the lexical scope of `with-js', `js?', `js!', -`js-new', `js-eval', `js-list', `js<', `js>', `js-get-service', -`js-create-instance', and `js-qi' are defined." - (declare (indent 0) (debug t)) - `(progn - (js--js-enter-repl) - (unwind-protect - (cl-macrolet ((js? (&rest body) `(js--js-true ,@body)) - (js! (function &rest body) - `(js--js-funcall - ,(if (consp function) - (cons 'list - (js--optimize-arglist function)) - function) - ,@(js--optimize-arglist body))) - - (js-new (function &rest body) - `(js--js-new - ,(if (consp function) - (cons 'list - (js--optimize-arglist function)) - function) - ,@body)) - - (js-eval (thisobj js) - `(js--js-eval - ,@(js--optimize-arglist - (list thisobj js)))) - - (js-list (&rest args) - `(js--js-list - ,@(js--optimize-arglist args))) - - (js-get-service (&rest args) - `(js--js-get-service - ,@(js--optimize-arglist args))) - - (js-create-instance (&rest args) - `(js--js-create-instance - ,@(js--optimize-arglist args))) - - (js-qi (&rest args) - `(js--js-qi - ,@(js--optimize-arglist args))) - - (js< (&rest body) `(js--js-get - ,@(js--optimize-arglist body))) - (js> (props value) - `(js--js-funcall - '(interactor "_putProp") - ,(if (consp props) - (cons 'list - (js--optimize-arglist props)) - props) - ,@(js--optimize-arglist (list value)) - )) - (js-handle? (arg) `(js--js-handle-p ,arg))) - ,@forms) - (js--js-leave-repl)))) - -(defvar js--js-array-as-list nil - "Whether to listify any Array returned by a Mozilla function. -If nil, the whole Array is treated as a JS symbol.") - -(defun js--js-decode-retval (result) - (pcase (intern (cl-first result)) - ('atom (cl-second result)) - ('special (intern (cl-second result))) - ('array - (mapcar #'js--js-decode-retval (cl-second result))) - ('objid - (or (gethash (cl-second result) - js--js-references) - (puthash (cl-second result) - (make-js--js-handle - :id (cl-second result) - :process (inferior-moz-process)) - js--js-references))) - - ('error (signal 'js-js-error (list (cl-second result)))) - (x (error "Unmatched case in js--js-decode-retval: %S" x)))) - -(defvar comint-last-input-end) - -(defun js--js-funcall (function &rest arguments) - "Call the Mozilla function FUNCTION with arguments ARGUMENTS. -If function is a string, look it up as a property on the global -object and use the global object for `this'. -If FUNCTION is a list with one element, use that element as the -function with the global object for `this', except that if that -single element is a string, look it up on the global object. -If FUNCTION is a list with more than one argument, use the list -up to the last value as a property descriptor and the last -argument as a function." - - (with-js - (let ((argstr (js--js-encode-value - (cons function arguments)))) - - (with-current-buffer inferior-moz-buffer - ;; Actual funcall - (when js--js-array-as-list - (insert "*")) - (insert argstr) - (comint-send-input nil t) - (js--wait-for-matching-output - (inferior-moz-process) "EVAL>" - js-js-timeout) - (goto-char comint-last-input-end) - - ;; Read the result - (let* ((json-array-type 'list) - (result (prog1 (json-read) - (goto-char (point-max))))) - (js--js-decode-retval result)))))) - -(defun js--js-new (constructor &rest arguments) - "Call CONSTRUCTOR as a constructor, with arguments ARGUMENTS. -CONSTRUCTOR is a JS handle, a string, or a list of these things." - (apply #'js--js-funcall - '(interactor "_callNew") - constructor arguments)) - -(defun js--js-eval (thisobj js) - (js--js-funcall '(interactor "_callEval") thisobj js)) - -(defun js--js-list (&rest arguments) - "Return a Lisp array resulting from evaluating each of ARGUMENTS." - (let ((js--js-array-as-list t)) - (apply #'js--js-funcall '(interactor "_mkArray") - arguments))) - -(defun js--js-get (&rest props) - (apply #'js--js-funcall '(interactor "_getProp") props)) - -(defun js--js-put (props value) - (js--js-funcall '(interactor "_putProp") props value)) - -(defun js-gc (&optional force) - "Tell the repl about any objects we don't reference anymore. -With argument, run even if no intervening GC has happened." - (interactive) - - (when force - (setq js--js-last-gcs-done nil)) - - (let ((this-gcs-done gcs-done) keys num) - (when (and js--js-references - (boundp 'inferior-moz-buffer) - (buffer-live-p inferior-moz-buffer) - - ;; Don't bother running unless we've had an intervening - ;; garbage collection; without a gc, nothing is deleted - ;; from the weak hash table, so it's pointless telling - ;; MozRepl about that references we still hold - (not (eq js--js-last-gcs-done this-gcs-done)) - - ;; Are we looking at a normal prompt? Make sure not to - ;; interrupt the user if he's doing something - (with-current-buffer inferior-moz-buffer - (save-excursion - (goto-char (point-max)) - (looking-back js--js-prompt-regexp - (save-excursion (forward-line 0) (point)))))) - - (setq keys (cl-loop for x being the hash-keys - of js--js-references - collect x)) - (setq num (js--js-funcall '(repl "_jsGC") (or keys []))) - - (setq js--js-last-gcs-done this-gcs-done) - (when (called-interactively-p 'interactive) - (message "Cleaned %s entries" num)) - - num))) - -(run-with-idle-timer 30 t #'js-gc) - -(defun js-eval (js) - "Evaluate the JavaScript in JS and return JSON-decoded result." - (interactive "MJavaScript to evaluate: ") - (with-js - (let* ((content-window (js--js-content-window - (js--get-js-context))) - (result (js-eval content-window js))) - (when (called-interactively-p 'interactive) - (message "%s" (js! "String" result))) - result))) - -(defun js--get-tabs () - "Enumerate all JavaScript contexts available. -Each context is a list: - (TITLE URL BROWSER TAB TABBROWSER) for content documents - (TITLE URL WINDOW) for windows - -All tabs of a given window are grouped together. The most recent -window is first. Within each window, the tabs are returned -left-to-right." - (with-js - (let (windows) - - (cl-loop with window-mediator = (js! ("Components" "classes" - "@mozilla.org/appshell/window-mediator;1" - "getService") - (js< "Components" "interfaces" - "nsIWindowMediator")) - with enumerator = (js! (window-mediator "getEnumerator") nil) - - while (js? (js! (enumerator "hasMoreElements"))) - for window = (js! (enumerator "getNext")) - for window-info = (js-list window - (js< window "document" "title") - (js! (window "location" "toString")) - (js< window "closed") - (js< window "windowState")) - - unless (or (js? (cl-fourth window-info)) - (eq (cl-fifth window-info) 2)) - do (push window-info windows)) - - (cl-loop for (window title location) in windows - collect (list title location window) - - for gbrowser = (js< window "gBrowser") - if (js-handle? gbrowser) - nconc (cl-loop - for x below (js< gbrowser "browsers" "length") - collect (js-list (js< gbrowser - "browsers" - x - "contentDocument" - "title") - - (js! (gbrowser - "browsers" - x - "contentWindow" - "location" - "toString")) - (js< gbrowser - "browsers" - x) - - (js! (gbrowser - "tabContainer" - "childNodes" - "item") - x) - - gbrowser)))))) - -(defvar js-read-tab-history nil) - -(declare-function ido-chop "ido" (items elem)) - -(defun js--read-tab (prompt) - "Read a Mozilla tab with prompt PROMPT. -Return a cons of (TYPE . OBJECT). TYPE is either `window' or -`tab', and OBJECT is a JavaScript handle to a ChromeWindow or a -browser, respectively." - - ;; Prime IDO - (unless ido-mode - (ido-mode 1) - (ido-mode -1)) - - (with-js - (let ((tabs (js--get-tabs)) selected-tab-cname - selected-tab prev-hitab) - - ;; Disambiguate names - (setq tabs - (cl-loop with tab-names = (make-hash-table :test 'equal) - for tab in tabs - for cname = (format "%s (%s)" - (cl-second tab) (cl-first tab)) - for num = (cl-incf (gethash cname tab-names -1)) - if (> num 0) - do (setq cname (format "%s <%d>" cname num)) - collect (cons cname tab))) - - (cl-labels - ((find-tab-by-cname - (cname) - (cl-loop for tab in tabs - if (equal (car tab) cname) - return (cdr tab))) - - (mogrify-highlighting - (hitab unhitab) - - ;; Hack to reduce the number of - ;; round-trips to mozilla - (let (cmds) - (cond - ;; Highlighting tab - ((cl-fourth hitab) - (push '(js! ((cl-fourth hitab) "setAttribute") - "style" - "color: red; font-weight: bold") - cmds) - - ;; Highlight window proper - (push '(js! ((cl-third hitab) - "setAttribute") - "style" - "border: 8px solid red") - cmds) - - ;; Select tab, when appropriate - (when js-js-switch-tabs - (push - '(js> ((cl-fifth hitab) "selectedTab") (cl-fourth hitab)) - cmds))) - - ;; Highlighting whole window - ((cl-third hitab) - (push '(js! ((cl-third hitab) "document" - "documentElement" "setAttribute") - "style" - (concat "-moz-appearance: none;" - "border: 8px solid red;")) - cmds))) - - (cond - ;; Unhighlighting tab - ((cl-fourth unhitab) - (push '(js! ((cl-fourth unhitab) "setAttribute") "style" "") - cmds) - (push '(js! ((cl-third unhitab) "setAttribute") "style" "") - cmds)) - - ;; Unhighlighting window - ((cl-third unhitab) - (push '(js! ((cl-third unhitab) "document" - "documentElement" "setAttribute") - "style" "") - cmds))) - - (eval `(with-js - (js-list ,@(nreverse cmds))) - t))) - - (command-hook - () - (let* ((tab (find-tab-by-cname (car ido-matches)))) - (mogrify-highlighting tab prev-hitab) - (setq prev-hitab tab))) - - (setup-hook - () - ;; Fiddle with the match list a bit: if our first match - ;; is a tabbrowser window, rotate the match list until - ;; the active tab comes up - (let ((matched-tab (find-tab-by-cname (car ido-matches)))) - (when (and matched-tab - (null (cl-fourth matched-tab)) - (equal "navigator:browser" - (js! ((cl-third matched-tab) - "document" - "documentElement" - "getAttribute") - "windowtype"))) - - (cl-loop with tab-to-match = (js< (cl-third matched-tab) - "gBrowser" - "selectedTab") - - for match in ido-matches - for candidate-tab = (find-tab-by-cname match) - if (eq (cl-fourth candidate-tab) tab-to-match) - do (setq ido-cur-list - (ido-chop ido-cur-list match)) - and return t))) - - (add-hook 'post-command-hook #'command-hook t t))) - - - (unwind-protect - ;; FIXME: Don't impose IDO on the user. - (setq selected-tab-cname - (let ((ido-minibuffer-setup-hook - (cons #'setup-hook ido-minibuffer-setup-hook))) - (ido-completing-read - prompt - (mapcar #'car tabs) - nil t nil - 'js-read-tab-history))) - - (when prev-hitab - (mogrify-highlighting nil prev-hitab) - (setq prev-hitab nil))) - - (add-to-history 'js-read-tab-history selected-tab-cname) - - (setq selected-tab (cl-loop for tab in tabs - if (equal (car tab) selected-tab-cname) - return (cdr tab))) - - (cons (if (cl-fourth selected-tab) 'browser 'window) - (cl-third selected-tab)))))) - -(defun js--guess-eval-defun-info (pstate) - "Helper function for `js-eval-defun'. -Return a list (NAME . CLASSPARTS), where CLASSPARTS is a list of -strings making up the class name and NAME is the name of the -function part." - (cond ((and (= (length pstate) 3) - (eq (js--pitem-type (cl-first pstate)) 'function) - (= (length (js--pitem-name (cl-first pstate))) 1) - (consp (js--pitem-type (cl-second pstate)))) - - (append (js--pitem-name (cl-second pstate)) - (list (cl-first (js--pitem-name (cl-first pstate)))))) - - ((and (= (length pstate) 2) - (eq (js--pitem-type (cl-first pstate)) 'function)) - - (append - (butlast (js--pitem-name (cl-first pstate))) - (list (car (last (js--pitem-name (cl-first pstate))))))) - - (t (error "Function not a toplevel defun or class member")))) - -(defvar js--js-context nil - "The current JavaScript context. -This is a cons like the one returned from `js--read-tab'. -Change with `js-set-js-context'.") - -(defconst js--js-inserter - "(function(func_info,func) { - func_info.unshift('window'); - var obj = window; - for(var i = 1; i < func_info.length - 1; ++i) { - var next = obj[func_info[i]]; - if(typeof next !== 'object' && typeof next !== 'function') { - next = obj.prototype && obj.prototype[func_info[i]]; - if(typeof next !== 'object' && typeof next !== 'function') { - alert('Could not find ' + func_info.slice(0, i+1).join('.') + - ' or ' + func_info.slice(0, i+1).join('.') + '.prototype'); - return; - } - - func_info.splice(i+1, 0, 'prototype'); - ++i; - } - } - - obj[func_info[i]] = func; - alert('Successfully updated '+func_info.join('.')); - })") - -(defun js-set-js-context (context) - "Set the JavaScript context to CONTEXT. -When called interactively, prompt for CONTEXT." - (interactive (list (js--read-tab "JavaScript Context: "))) - (setq js--js-context context)) - -(defun js--get-js-context () - "Return a valid JavaScript context. -If one hasn't been set, or if it's stale, prompt for a new one." - (with-js - (when (or (null js--js-context) - (js--js-handle-expired-p (cdr js--js-context)) - (pcase (car js--js-context) - ('window (js? (js< (cdr js--js-context) "closed"))) - ('browser (not (js? (js< (cdr js--js-context) - "contentDocument")))) - (x (error "Unmatched case in js--get-js-context: %S" x)))) - (setq js--js-context (js--read-tab "JavaScript Context: "))) - js--js-context)) - -(defun js--js-content-window (context) - (with-js - (pcase (car context) - ('window (cdr context)) - ('browser (js< (cdr context) - "contentWindow" "wrappedJSObject")) - (x (error "Unmatched case in js--js-content-window: %S" x))))) - -(defun js--make-nsilocalfile (path) - (with-js - (let ((file (js-create-instance "@mozilla.org/file/local;1" - "nsILocalFile"))) - (js! (file "initWithPath") path) - file))) - -(defun js--js-add-resource-alias (alias path) - (with-js - (let* ((io-service (js-get-service "@mozilla.org/network/io-service;1" - "nsIIOService")) - (res-prot (js! (io-service "getProtocolHandler") "resource")) - (res-prot (js-qi res-prot "nsIResProtocolHandler")) - (path-file (js--make-nsilocalfile path)) - (path-uri (js! (io-service "newFileURI") path-file))) - (js! (res-prot "setSubstitution") alias path-uri)))) - -(cl-defun js-eval-defun () - "Update a Mozilla tab using the JavaScript defun at point." - (interactive) - - ;; This function works by generating a temporary file that contains - ;; the function we'd like to insert. We then use the elisp-js bridge - ;; to command mozilla to load this file by inserting a script tag - ;; into the document we set. This way, debuggers and such will have - ;; a way to find the source of the just-inserted function. - ;; - ;; We delete the temporary file if there's an error, but otherwise - ;; we add an unload event listener on the Mozilla side to delete the - ;; file. - - (save-excursion - (let (begin end pstate defun-info temp-name defun-body) - (js-end-of-defun) - (setq end (point)) - (js--ensure-cache) - (js-beginning-of-defun) - (re-search-forward "\\_<function\\_>") - (setq begin (match-beginning 0)) - (setq pstate (js--forward-pstate)) - - (when (or (null pstate) - (> (point) end)) - (error "Could not locate function definition")) - - (setq defun-info (js--guess-eval-defun-info pstate)) - - (let ((overlay (make-overlay begin end))) - (overlay-put overlay 'face 'highlight) - (unwind-protect - (unless (y-or-n-p (format "Send %s to Mozilla? " - (mapconcat #'identity defun-info "."))) - (message "") ; question message lingers until next command - (cl-return-from js-eval-defun)) - (delete-overlay overlay))) - - (setq defun-body (buffer-substring-no-properties begin end)) - - (make-directory js-js-tmpdir t) - - ;; (Re)register a Mozilla resource URL to point to the - ;; temporary directory - (js--js-add-resource-alias "js" js-js-tmpdir) - - (setq temp-name (make-temp-file (concat js-js-tmpdir - "/js-") - nil ".js")) - (unwind-protect - (with-js - (with-temp-buffer - (insert js--js-inserter) - (insert "(") - (let ((standard-output (current-buffer))) - (json--print-list defun-info)) - (insert ",\n") - (insert defun-body) - (insert "\n)") - (write-region (point-min) (point-max) temp-name - nil 1)) - - ;; Give Mozilla responsibility for deleting this file - (let* ((content-window (js--js-content-window - (js--get-js-context))) - (content-document (js< content-window "document")) - (head (if (js? (js< content-document "body")) - ;; Regular content - (js< (js! (content-document "getElementsByTagName") - "head") - 0) - ;; Chrome - (js< content-document "documentElement"))) - (elem (js! (content-document "createElementNS") - "http://www.w3.org/1999/xhtml" "script"))) - - (js! (elem "setAttribute") "type" "text/javascript") - (js! (elem "setAttribute") "src" - (format "resource://js/%s" - (file-name-nondirectory temp-name))) - - (js! (head "appendChild") elem) - - (js! (content-window "addEventListener") "unload" - (js! ((js-new - "Function" "file" - "return function() { file.remove(false) }")) - (js--make-nsilocalfile temp-name)) - 'false) - (setq temp-name nil) - - - - )) - - ;; temp-name is set to nil on success - (when temp-name - (delete-file temp-name)))))) - ;;; Syntax extensions (defvar js-syntactic-mode-name t diff --git a/lisp/progmodes/octave.el b/lisp/progmodes/octave.el index 6bf070cf9e5..79530f81673 100644 --- a/lisp/progmodes/octave.el +++ b/lisp/progmodes/octave.el @@ -1814,18 +1814,18 @@ If the environment variable OCTAVE_SRCDIR is set, it is searched first." (user-error "Aborted"))) (_ name))) -(defvar find-tag-marker-ring) +(declare-function xref-push-marker-stack "xref" (&optional m)) (defun octave-find-definition (fn) "Find the definition of FN. Functions implemented in C++ can be found if variable `octave-source-directories' is set correctly." (interactive (list (octave-completing-read))) - (require 'etags) + (require 'xref) (let ((orig (point))) (if (and (derived-mode-p 'octave-mode) (octave-goto-function-definition fn)) - (ring-insert find-tag-marker-ring (copy-marker orig)) + (xref-push-marker-stack (copy-marker orig)) (inferior-octave-send-list-and-digest ;; help NAME is more verbose (list (format "\ @@ -1840,7 +1840,7 @@ if iskeyword('%s') disp('`%s'' is a keyword') else which('%s') endif\n" (setq file (match-string 1 line)))) (if (not file) (user-error "%s" (or line (format-message "`%s' not found" fn))) - (ring-insert find-tag-marker-ring (point-marker)) + (xref-push-marker-stack) (setq file (funcall octave-find-definition-filename-function file)) (when file (find-file file) diff --git a/lisp/progmodes/pascal.el b/lisp/progmodes/pascal.el index e6e6e40aa19..5938da542ac 100644 --- a/lisp/progmodes/pascal.el +++ b/lisp/progmodes/pascal.el @@ -1357,9 +1357,7 @@ The default is a name found in the buffer around point." default "")) (label ;; Do completion with default. - (completing-read (if (not (string= default "")) - (concat "Label (default " default "): ") - "Label: ") + (completing-read (format-prompt "Label" default) ;; Complete with the defuns found in the ;; current-buffer. (let ((buf (current-buffer))) diff --git a/lisp/progmodes/prog-mode.el b/lisp/progmodes/prog-mode.el index e43f2ff90b5..496b0810183 100644 --- a/lisp/progmodes/prog-mode.el +++ b/lisp/progmodes/prog-mode.el @@ -49,9 +49,15 @@ (define-key-after menu [prog-separator] menu-bar-separator 'middle-separator) + (unless (xref-forward-history-empty-p) + (define-key-after menu [xref-forward] + '(menu-item "Go Forward" xref-go-forward + :help "Forward to the position gone Back from") + 'prog-separator)) + (unless (xref-marker-stack-empty-p) (define-key-after menu [xref-pop] - '(menu-item "Go Back" xref-pop-marker-stack + '(menu-item "Go Back" xref-go-back :help "Back to the position of the last search") 'prog-separator)) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index da7435cddf3..8fecdbb61cf 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -322,7 +322,15 @@ to find the list of ignores for each directory." (process-file-shell-command command nil t)) (pt (point-min))) (unless (zerop status) - (error "File listing failed: %s" (buffer-string))) + (goto-char (point-min)) + (if (and + (not (eql status 127)) + (search-forward "Permission denied\n" nil t)) + (let ((end (1- (point)))) + (re-search-backward "\\`\\|\0") + (error "File listing failed: %s" + (buffer-substring (1+ (point)) end))) + (error "File listing failed: %s" (buffer-string)))) (goto-char pt) (while (search-forward "\0" nil t) (push (buffer-substring-no-properties (1+ pt) (1- (point))) @@ -840,28 +848,36 @@ pattern to search for." project-regexp-history-variable))) ;;;###autoload -(defun project-find-file () +(defun project-find-file (&optional include-all) "Visit a file (with completion) in the current project. The filename at point (determined by `thing-at-point'), if any, -is available as part of \"future history\"." - (interactive) +is available as part of \"future history\". + +If INCLUDE-ALL is non-nil, or with prefix argument when called +interactively, include all files under the project root, except +for VCS directories listed in `vc-directory-exclusion-list'." + (interactive "P") (let* ((pr (project-current t)) (dirs (list (project-root pr)))) - (project-find-file-in (thing-at-point 'filename) dirs pr))) + (project-find-file-in (thing-at-point 'filename) dirs pr include-all))) ;;;###autoload -(defun project-or-external-find-file () +(defun project-or-external-find-file (&optional include-all) "Visit a file (with completion) in the current project or external roots. The filename at point (determined by `thing-at-point'), if any, -is available as part of \"future history\"." - (interactive) +is available as part of \"future history\". + +If INCLUDE-ALL is non-nil, or with prefix argument when called +interactively, include all files under the project root, except +for VCS directories listed in `vc-directory-exclusion-list'." + (interactive "P") (let* ((pr (project-current t)) (dirs (cons (project-root pr) (project-external-roots pr)))) - (project-find-file-in (thing-at-point 'filename) dirs pr))) + (project-find-file-in (thing-at-point 'filename) dirs pr include-all))) (defcustom project-read-file-name-function #'project--read-file-cpd-relative "Function to call to read a file name from a list. @@ -914,12 +930,25 @@ by the user at will." predicate hist mb-default)) -(defun project-find-file-in (suggested-filename dirs project) +(defun project-find-file-in (suggested-filename dirs project &optional include-all) "Complete a file name in DIRS in PROJECT and visit the result. SUGGESTED-FILENAME is a relative file name, or part of it, which -is used as part of \"future history\"." - (let* ((all-files (project-files project dirs)) +is used as part of \"future history\". + +If INCLUDE-ALL is non-nil, or with prefix argument when called +interactively, include all files from DIRS, except for VCS +directories listed in `vc-directory-exclusion-list'." + (let* ((vc-dirs-ignores (mapcar + (lambda (dir) + (concat dir "/")) + vc-directory-exclusion-list)) + (all-files + (if include-all + (mapcan + (lambda (dir) (project--files-in-directory dir vc-dirs-ignores)) + dirs) + (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 @@ -1144,7 +1173,9 @@ displayed." (not (major-mode . help-mode))) (derived-mode . compilation-mode) (derived-mode . dired-mode) - (derived-mode . diff-mode)) + (derived-mode . diff-mode) + (derived-mode . comint-mode) + (derived-mode . change-log-mode)) "List of conditions to kill buffers related to a project. This list is used by `project-kill-buffers'. Each condition is either: @@ -1177,9 +1208,18 @@ current project, it will be killed." (const and) sexp) (cons :tag "Disjunction" (const or) sexp))) - :version "28.1" + :version "29.1" :group 'project - :package-version '(project . "0.6.0")) + :package-version '(project . "0.8.2")) + +(defcustom project-kill-buffers-display-buffer-list nil + "Non-nil to display list of buffers to kill before killing project buffers. +Used by `project-kill-buffers'." + :type 'boolean + :version "29.1" + :group 'project + :package-version '(project . "0.8.2") + :safe #'booleanp) (defun project--buffer-list (pr) "Return the list of all buffers in project PR." @@ -1247,14 +1287,35 @@ NO-CONFIRM is always nil when the command is invoked interactively." (interactive) (let* ((pr (project-current t)) - (bufs (project--buffers-to-kill pr))) + (bufs (project--buffers-to-kill pr)) + (query-user (lambda () + (yes-or-no-p + (format "Kill %d buffers in %s? " + (length bufs) + (project-root 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))) + (project-kill-buffers-display-buffer-list + (when + (with-current-buffer-window + (get-buffer-create "*Buffer List*") + `(display-buffer--maybe-at-bottom + (dedicated . t) + (window-height . (fit-window-to-buffer)) + (preserve-size . (nil . t)) + (body-function + . ,#'(lambda (_window) + (list-buffers-noselect nil bufs)))) + #'(lambda (window _value) + (with-selected-window window + (unwind-protect + (funcall query-user) + (when (window-live-p window) + (quit-restore-window window 'kill)))))) + (mapc #'kill-buffer bufs))) + ((funcall query-user) (mapc #'kill-buffer bufs))))) diff --git a/lisp/progmodes/prolog.el b/lisp/progmodes/prolog.el index 59004e413eb..c36082bb6d0 100644 --- a/lisp/progmodes/prolog.el +++ b/lisp/progmodes/prolog.el @@ -2484,11 +2484,8 @@ Interaction supports completion." (if (eq (try-completion default prolog-info-alist) nil) (setq default nil)) ;; Read the PredSpec from the user - (completing-read - (if (zerop (length default)) - "Help on predicate: " - (concat "Help on predicate (default " default "): ")) - prolog-info-alist nil t nil nil default))) + (completing-read (format-prompt "Help on predicate" default) + prolog-info-alist nil t nil nil default))) (defun prolog-build-info-alist (&optional verbose) "Build an alist of all builtins and library predicates. diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index 6357c4f2d3e..b403de8b7a6 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -5,7 +5,7 @@ ;; Author: Fabián E. Gallina <fgallina@gnu.org> ;; URL: https://github.com/fgallina/python.el ;; Version: 0.28 -;; Package-Requires: ((emacs "24.2") (cl-lib "1.0")) +;; Package-Requires: ((emacs "24.4") (cl-lib "1.0")) ;; Maintainer: emacs-devel@gnu.org ;; Created: Jul 2010 ;; Keywords: languages @@ -1427,6 +1427,13 @@ marks the next defun after the ones already marked." ;;; Navigation +(defcustom python-forward-sexp-function #'python-nav-forward-sexp + "Function to use when navigating between expressions." + :version "28.1" + :type '(choice (const :tag "Python blocks" python-nav-forward-sexp) + (const :tag "CC-mode like" nil) + function)) + (defvar python-nav-beginning-of-defun-regexp (python-rx line-start (* space) defun (+ space) (group symbol-name)) "Regexp matching class or function definition. @@ -1518,7 +1525,10 @@ Returns nil if point is not in a def or class." (python-util-forward-comment -1) (forward-line 1) ;; Ensure point moves forward. - (and (> beg-pos (point)) (goto-char beg-pos))))) + (and (> beg-pos (point)) (goto-char beg-pos)) + ;; Return non-nil if we did something (because then we were in a + ;; def/class). + (/= beg-pos (point))))) (defun python-nav--syntactically (fn poscompfn &optional contextfn) "Move point using FN avoiding places with specific context. @@ -2724,20 +2734,12 @@ goes wrong and syntax highlighting in the shell gets messed up." (deactivate-mark nil) (start-pos prompt-end) (buffer-undo-list t) - (font-lock-buffer-pos nil) (replacement (python-shell-font-lock-with-font-lock-buffer - (delete-region (line-beginning-position) - (point-max)) - (setq font-lock-buffer-pos (point)) + (delete-region (point-min) (point-max)) (insert input) - ;; Ensure buffer is fontified, keeping it - ;; compatible with Emacs < 24.4. - (if (fboundp 'font-lock-ensure) - (funcall 'font-lock-ensure) - (font-lock-default-fontify-buffer)) - (buffer-substring font-lock-buffer-pos - (point-max)))) + (font-lock-ensure) + (buffer-string))) (replacement-length (length replacement)) (i 0)) ;; Inject text properties to get input fontified. @@ -3763,7 +3765,8 @@ With argument MSG show activation/deactivation message." (format "was t and %S is not part of the " (file-name-nondirectory python-shell-interpreter)) "`python-shell-completion-native-disabled-interpreters' " - "list. Native completions have been disabled locally. ")) + "list. Native completions have been disabled locally. " + "Consider installing the python package \"readline\". ")) (python-shell-completion-native-turn-off msg)))))) (defun python-shell-completion-native-turn-on-maybe-with-msg () @@ -3810,7 +3813,7 @@ With argument MSG show activation/deactivation message." (comint-redirect-perform-sanity-check nil) (comint-redirect-insert-matching-regexp t) (comint-redirect-finished-regexp - "1__dummy_completion__[[:space:]]*\n") + "1__dummy_completion__.*\n") (comint-redirect-output-buffer redirect-buffer)) ;; Compatibility with Emacs 24.x. Comint changed and ;; now `comint-redirect-filter' gets 3 args. This @@ -4670,7 +4673,10 @@ See `python-check-command' for the default." target = obj objtype = 'def' if target: - args = inspect.formatargspec(*argspec_function(target)) + if hasattr(inspect, 'signature'): + args = str(inspect.signature(target)) + else: + args = inspect.formatargspec(*argspec_function(target)) name = obj.__name__ doc = '{objtype} {name}{args}'.format( objtype=objtype, name=name, args=args @@ -4769,10 +4775,14 @@ Interactively, prompt for symbol." (interactive (let ((symbol (python-eldoc--get-symbol-at-point)) (enable-recursive-minibuffers t)) - (list (read-string (if symbol - (format "Describe symbol (default %s): " symbol) - "Describe symbol: ") - nil nil symbol)))) + (list (read-string + ;; `format-prompt' is new in Emacs 28.1. + (if (fboundp 'format-prompt) + (format-prompt "Describe symbol" symbol) + (if symbol + (format "Describe symbol (default %s): " symbol) + "Describe symbol: ")) + nil nil symbol)))) (message (python-eldoc--get-doc-at-point symbol))) (defun python-describe-at-point (symbol process) @@ -5569,13 +5579,6 @@ By default messages are considered errors." :type '(alist :key-type (regexp) :value-type (symbol))) -(defcustom python-forward-sexp-function #'python-nav-forward-sexp - "Function to use when navigating between expressions." - :version "28.1" - :type '(choice (const :tag "Python blocks" python-nav-forward-sexp) - (const :tag "CC-mode like" nil) - function)) - (defvar-local python--flymake-proc nil) (defun python--flymake-parse-output (source proc report-fn) diff --git a/lisp/progmodes/scheme.el b/lisp/progmodes/scheme.el index 57351a7308d..abcdcb3349e 100644 --- a/lisp/progmodes/scheme.el +++ b/lisp/progmodes/scheme.el @@ -143,7 +143,6 @@ (setq-local comment-start-skip ";+[ \t]*") (setq-local comment-use-syntax t) (setq-local comment-column 40) - (setq-local parse-sexp-ignore-comments t) (setq-local lisp-indent-function 'scheme-indent-function) (setq mode-line-process '("" scheme-mode-line-process)) (setq-local imenu-case-fold-search t) diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el index 0dd9f2b4fa2..c6b6f83471d 100644 --- a/lisp/progmodes/sh-script.el +++ b/lisp/progmodes/sh-script.el @@ -628,7 +628,8 @@ removed when closing the here document." (wksh sh-append ksh88) (zsh sh-append ksh88 - "autoload" "bindkey" "builtin" "chdir" "compctl" "declare" "dirs" + "autoload" "always" + "bindkey" "builtin" "chdir" "compctl" "declare" "dirs" "disable" "disown" "echotc" "enable" "functions" "getln" "hash" "history" "integer" "limit" "local" "log" "popd" "pushd" "r" "readonly" "rehash" "sched" "setopt" "source" "suspend" "true" diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el index 5dfbf87e452..f5888a0ce7a 100644 --- a/lisp/progmodes/sql.el +++ b/lisp/progmodes/sql.el @@ -481,9 +481,9 @@ file. Since that is a plaintext file, this could be dangerous." :list-all ("\\d+" . "\\dS+") :list-table ("\\d+ %s" . "\\dS+ %s") :completion-object sql-postgres-completion-object - :prompt-regexp "^[[:alnum:]_]*=[#>] " + :prompt-regexp "^[-[:alnum:]_]*[-=][#>] " :prompt-length 5 - :prompt-cont-regexp "^[[:alnum:]_]*[-(][#>] " + :prompt-cont-regexp "^[-[:alnum:]_]*[-'(][#>] " :statement sql-postgres-statement-starters :input-filter sql-remove-tabs-filter :terminator ("\\(^\\s-*\\\\g\\|;\\)" . "\\g")) @@ -700,8 +700,17 @@ making new SQLi sessions." (sexp :tag "Value Expression"))))) :version "24.1") -(defvaralias 'sql-dialect 'sql-product) +(defun sql-add-connection (connection params) + "Add a new connection to `sql-connection-alist'. +If CONNECTION already exists, it is replaced with PARAMS." + (setq sql-connection-alist + (assoc-delete-all connection sql-connection-alist)) + (push + (cons connection params) + sql-connection-alist)) + +(defvaralias 'sql-dialect 'sql-product) (defcustom sql-product 'ansi "Select the SQL database product used. This allows highlighting buffers properly when you open them." @@ -963,12 +972,7 @@ If set to \"\\n\", each line in the history file will be interpreted as one command. Multi-line commands are split into several commands when the input ring is initialized from a history file. -This variable used to initialize `comint-input-ring-separator'. -`comint-input-ring-separator' is part of Emacs 21; if your Emacs -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\"." +This variable used to initialize `comint-input-ring-separator'." :type 'string) ;; The usual hooks @@ -1357,8 +1361,6 @@ specified, it's `sql-product' or `sql-connection' must match." (defvar sql-interactive-mode-map (let ((map (make-sparse-keymap))) (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) (define-key map (kbd "C-c C-w") 'sql-copy-column) (define-key map (kbd "O") 'sql-magic-go) @@ -2832,16 +2834,6 @@ configured." (font-lock-mode-internal nil) (font-lock-mode-internal t)) - (add-hook 'font-lock-mode-hook - (lambda () - ;; Provide defaults for new font-lock faces. - (defvar font-lock-builtin-face - (if (boundp 'font-lock-preprocessor-face) - font-lock-preprocessor-face - font-lock-keyword-face)) - (defvar font-lock-doc-face font-lock-string-face)) - nil t) - ;; Setup imenu; it needs the same syntax-alist. (when imenu (setq imenu-syntax-alist syntax-alist)))) @@ -3219,14 +3211,7 @@ For both `:file' and `:completion', there can also be a symbol (let* ((default (plist-get plist :default)) (last-value (sql-default-value symbol)) - (prompt-def - (if default - (if (string-match "\\(\\):[ \t]*\\'" prompt) - (replace-match (format " (default \"%s\")" default) t t prompt 1) - (replace-regexp-in-string "[ \t]*\\'" - (format " (default \"%s\") " default) - prompt t t)) - prompt)) + (prompt-def (format-prompt prompt default)) (use-dialog-box nil)) (cond ((plist-member plist :file) @@ -3311,7 +3296,7 @@ function like this: (sql-get-login \\='user \\='password \\='database)." (let ((plist (cdr-safe w))) (pcase (or (car-safe w) w) ('user - (sql-get-login-ext 'sql-user "User: " 'sql-user-history plist)) + (sql-get-login-ext 'sql-user "User" 'sql-user-history plist)) ('password (setq-default sql-password @@ -3330,14 +3315,14 @@ function like this: (sql-get-login \\='user \\='password \\='database)." (read-passwd "Password: " nil (sql-default-value 'sql-password))))) ('server - (sql-get-login-ext 'sql-server "Server: " 'sql-server-history plist)) + (sql-get-login-ext 'sql-server "Server" 'sql-server-history plist)) ('database - (sql-get-login-ext 'sql-database "Database: " + (sql-get-login-ext 'sql-database "Database" 'sql-database-history plist)) ('port - (sql-get-login-ext 'sql-port "Port: " + (sql-get-login-ext 'sql-port "Port" nil (append '(:number t) plist))))))) (defun sql-find-sqli-buffer (&optional product connection) @@ -4182,10 +4167,6 @@ must tell Emacs. Here's how to do that in your init file: (modify-syntax-entry ?\\\\ \"\\\\\" sql-mode-syntax-table)))" :abbrev-table sql-mode-abbrev-table - (when (and (featurep 'xemacs) - sql-mode-menu) - (easy-menu-add sql-mode-menu)) - ;; (smie-setup sql-smie-grammar #'sql-smie-rules) (setq-local comment-start "--") ;; Make each buffer in sql-mode remember the "current" SQLi buffer. @@ -4308,9 +4289,6 @@ you entered, right above the output it created. (setq mode-name (concat "SQLi[" (or (sql-get-product-feature sql-product :name) (symbol-name sql-product)) "]")) - (when (and (featurep 'xemacs) - sql-interactive-mode-menu) - (easy-menu-add sql-interactive-mode-menu)) ;; 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 @@ -4681,6 +4659,14 @@ the call to \\[sql-product-interactive] with (get-buffer new-sqli-buffer))))) (user-error "No default SQL product defined: set `sql-product'"))) +(defun sql-comint-automatic-password (_) + "Intercept password prompts when we know the password. +This must also do the job of detecting password prompts." + (when (and + sql-password + (not (string= "" sql-password))) + sql-password)) + (defun sql-comint (product params &optional buf-name) "Set up a comint buffer to run the SQL processor. @@ -4705,6 +4691,13 @@ buffer. If nil, a name is chosen for it." (setq buf-name (sql-generate-unique-sqli-buffer-name product nil))) (set-text-properties 0 (length buf-name) nil buf-name) + ;; Create the buffer first, because we want to set it up before + ;; comint starts to run. + (set-buffer (get-buffer-create buf-name)) + ;; Set up the automatic population of passwords, if supported. + (when (sql-get-product-feature product :password-in-comint) + (setq comint-password-function #'sql-comint-automatic-password)) + ;; Start the command interpreter in the buffer ;; PROC-NAME is BUF-NAME without enclosing asterisks (let ((proc-name (replace-regexp-in-string "\\`[*]\\(.*\\)[*]\\'" "\\1" buf-name))) diff --git a/lisp/progmodes/verilog-mode.el b/lisp/progmodes/verilog-mode.el index 52c34d9fbc6..14f252b42d4 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: 2021.09.23.089128420 +;; Version: 2021.10.14.127365406 ;; 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 "2021-09-23-54ffde4-vpo-GNU" +(defconst verilog-mode-version "2021-10-14-797711e-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.") @@ -1264,7 +1264,9 @@ See `verilog-auto-inst-param-value'." Also affects AUTOINSTPARAM. Declaration order is the default for backward compatibility, and as some teams prefer signals that are declared together to remain together. Sorted order reduces -changes when declarations are moved around in a file. +changes when declarations are moved around in a file. Sorting is +within input/output/inout groupings, there is intentionally no +option to intermix between input/output/inouts. See also `verilog-auto-arg-sort'." :version "24.1" ; rev688 @@ -5478,8 +5480,11 @@ becomes: (let* ((pop-up-windows t)) (let ((name (expand-file-name (read-file-name - (format "Find this error in: (default %s) " - file) + ;; `format-prompt' is new in Emacs 28.1. + (if (fboundp 'format-prompt) + (format-prompt "Find this error in" file) + (format "Find this error in (default %s): " + file)) nil ;; dir file t)))) (setq buffer @@ -6598,7 +6603,8 @@ Also move point to constraint." (equal (char-before) ?\;) (equal (char-before) ?\})) ;; skip what looks like bus repetition operator {#{ - (not (string-match "^{\\s-*[\\(\\)0-9a-zA-Z_]*\\s-*{" (buffer-substring p (point))))))))) + (not (string-match "^{\\s-*[()0-9a-zA-Z_\\]*\\s-*{" + (buffer-substring p (point))))))))) (progn (let ( (pt (point)) (pass 0)) (verilog-backward-ws&directives) @@ -7863,14 +7869,14 @@ If search fails, other files are checked based on (let* ((default (verilog-get-default-symbol)) ;; The following variable is used in verilog-comp-function (verilog-buffer-to-use (current-buffer)) - (label (if (not (string= default "")) - ;; Do completion with default - (completing-read (concat "Goto-Label: (default " - default ") ") - #'verilog-comp-defun nil nil "") - ;; There is no default value. Complete without it - (completing-read "Goto-Label: " - #'verilog-comp-defun nil nil ""))) + (label + (completing-read (cond ((fboundp 'format-prompt) + ;; `format-prompt' is new in Emacs 28.1. + (format-prompt "Goto-Label" default)) + ((not (string= default "")) + (concat "Goto-Label (default " default "): ")) + (t "Goto-Label: ")) + #'verilog-comp-defun nil nil "")) pt) ;; Make sure library paths are correct, in case need to resolve module (verilog-auto-reeval-locals) diff --git a/lisp/progmodes/vhdl-mode.el b/lisp/progmodes/vhdl-mode.el index 3a9185b334f..f3a7d96c63b 100644 --- a/lisp/progmodes/vhdl-mode.el +++ b/lisp/progmodes/vhdl-mode.el @@ -10683,8 +10683,9 @@ Include a library specification, if not already there." (replace-match "" t t) (vhdl-template-insert-date)) (goto-char beg) - (while (search-forward "<year>" end t) - (replace-match (format-time-string "%Y" nil) t t)) + (let ((year (format-time-string "%Y"))) + (while (search-forward "<year>" end t) + (replace-match year t t))) (goto-char beg) (when file-title (while (search-forward "<title string>" end t) diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index 492be9a104d..ca3594d253b 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -1,7 +1,7 @@ ;;; xref.el --- Cross-referencing commands -*-lexical-binding:t-*- ;; Copyright (C) 2014-2021 Free Software Foundation, Inc. -;; Version: 1.3.0 +;; Version: 1.3.2 ;; Package-Requires: ((emacs "26.1")) ;; This is a GNU ELPA :core package. Avoid functionality that is not @@ -75,7 +75,7 @@ (require 'project) (eval-and-compile - (when (version< emacs-version "28") + (when (version< emacs-version "28.0.60") ;; etags.el in Emacs 26 and 27 uses EIEIO, and its location type ;; inherits from `xref-location'. (require 'eieio) @@ -195,16 +195,23 @@ is not known." ;;; Cross-reference -(cl-defstruct (xref-item - (:constructor xref-make (summary location)) - (:noinline t)) +(defmacro xref--defstruct (name &rest fields) + (declare (indent 1)) + `(cl-defstruct ,(if (>= emacs-major-version 27) + name + (remq (assq :noinline name) name)) + ,@fields)) + +(xref--defstruct (xref-item + (:constructor xref-make (summary location)) + (:noinline t)) "An xref item describes a reference to a location somewhere." summary location) -(cl-defstruct (xref-match-item - (:include xref-item) - (:constructor xref-make-match (summary location length)) - (:noinline t)) +(xref--defstruct (xref-match-item + (:include xref-item) + (:constructor xref-make-match (summary location length)) + (:noinline t)) "A match xref item describes a search result." length) @@ -334,15 +341,9 @@ backward." (t (goto-char start) nil)))) -;;; Marker stack (M-. pushes, M-, pops) - -(defcustom xref-marker-ring-length 16 - "Length of the xref marker ring. -If this variable is not set through Customize, you must call -`xref-set-marker-ring-length' for changes to take effect." - :type 'integer - :initialize #'custom-initialize-default - :set #'xref-set-marker-ring-length) +;; Dummy variable retained for compatibility. +(defvar xref-marker-ring-length 16) +(make-obsolete-variable 'xref-marker-ring-length nil "29.1") (defcustom xref-prompt-for-identifier '(not xref-find-definitions xref-find-definitions-other-window @@ -413,29 +414,59 @@ or earlier: it can break `dired-do-find-regexp-and-replace'." :version "28.1" :package-version '(xref . "1.2.0")) -(defvar xref--marker-ring (make-ring xref-marker-ring-length) - "Ring of markers to implement the marker stack.") +(make-obsolete-variable 'xref-marker-ring nil "29.1") + +(defun xref-set-marker-ring-length (_var _val) + (declare (obsolete nil "29.1")) + nil) + +(defvar xref--history (cons nil nil) + "(BACKWARD-STACK . FORWARD-STACK) of markers to visited Xref locations.") -(defun xref-set-marker-ring-length (var val) - "Set `xref-marker-ring-length'. -VAR is the symbol `xref-marker-ring-length' and VAL is the new -value." - (set-default var val) - (if (ring-p xref--marker-ring) - (ring-resize xref--marker-ring val))) +(defun xref--push-backward (m) + "Push marker M onto the backward history stack." + (unless (equal m (caar xref--history)) + (push m (car xref--history)))) + +(defun xref--push-forward (m) + "Push marker M onto the forward history stack." + (unless (equal m (cadr xref--history)) + (push m (cdr xref--history)))) (defun xref-push-marker-stack (&optional m) - "Add point M (defaults to `point-marker') to the marker stack." - (ring-insert xref--marker-ring (or m (point-marker)))) + "Add point M (defaults to `point-marker') to the marker stack. +The future stack is erased." + (xref--push-backward (or m (point-marker))) + (dolist (mk (cdr xref--history)) + (set-marker mk nil nil)) + (setcdr xref--history nil)) + +;;;###autoload +(define-obsolete-function-alias 'xref-pop-marker-stack #'xref-go-back "29.1") + +;;;###autoload +(defun xref-go-back () + "Go back to the previous position in xref history. +To undo, use \\[xref-go-forward]." + (interactive) + (if (null (car xref--history)) + (user-error "At start of xref history") + (let ((marker (pop (car xref--history)))) + (xref--push-forward (point-marker)) + (switch-to-buffer (or (marker-buffer marker) + (user-error "The marked buffer has been deleted"))) + (goto-char (marker-position marker)) + (set-marker marker nil nil) + (run-hooks 'xref-after-return-hook)))) ;;;###autoload -(defun xref-pop-marker-stack () - "Pop back to where \\[xref-find-definitions] was last invoked." +(defun xref-go-forward () + "Got to the point where a previous \\[xref-go-back] was invoked." (interactive) - (let ((ring xref--marker-ring)) - (when (ring-empty-p ring) - (user-error "Marker stack is empty")) - (let ((marker (ring-remove ring 0))) + (if (null (cdr xref--history)) + (user-error "At end of xref history") + (let ((marker (pop (cdr xref--history)))) + (xref--push-backward (point-marker)) (switch-to-buffer (or (marker-buffer marker) (user-error "The marked buffer has been deleted"))) (goto-char (marker-position marker)) @@ -458,17 +489,23 @@ value." ;; etags.el needs this (defun xref-clear-marker-stack () - "Discard all markers from the marker stack." - (let ((ring xref--marker-ring)) - (while (not (ring-empty-p ring)) - (let ((marker (ring-remove ring))) - (set-marker marker nil nil))))) + "Discard all markers from the xref history." + (dolist (l (list (car xref--history) (cdr xref--history))) + (dolist (m l) + (set-marker m nil nil))) + (setq xref--history (cons nil nil)) + nil) ;;;###autoload (defun xref-marker-stack-empty-p () - "Return t if the marker stack is empty; nil otherwise." - (ring-empty-p xref--marker-ring)) + "Whether the xref back-history is empty." + (null (car xref--history))) +;; FIXME: rename this to `xref-back-history-empty-p'. +;;;###autoload +(defun xref-forward-history-empty-p () + "Whether the xref forward-history is empty." + (null (cdr xref--history))) (defun xref--goto-char (pos) @@ -683,7 +720,7 @@ quit the *xref* buffer." "Quit *xref* buffer, then pop the xref marker stack." (interactive) (quit-window) - (xref-pop-marker-stack)) + (xref-go-back)) (defun xref-query-replace-in-results (from to) "Perform interactive replacement of FROM with TO in all displayed xrefs. @@ -1322,12 +1359,17 @@ definitions." (xref--prompt-p this-command)) (let ((id (completing-read - (if def - (format "%s (default %s): " - (substring prompt 0 (string-match - "[ :]+\\'" prompt)) - def) - prompt) + ;; `format-prompt' is new in Emacs 28.1 + (if (fboundp 'format-prompt) + (format-prompt (substring prompt 0 (string-match + "[ :]+\\'" prompt)) + def) + (if def + (format "%s (default %s): " + (substring prompt 0 (string-match + "[ :]+\\'" prompt)) + def) + prompt)) (xref-backend-identifier-completion-table backend) nil nil nil 'xref--read-identifier-history def))) @@ -1388,7 +1430,7 @@ definition for IDENTIFIER, display it in the selected window. Otherwise, display the list of the possible definitions in a buffer where the user can select from the list. -Use \\[xref-pop-marker-stack] to return back to where you invoked this command." +Use \\[xref-go-back] to return back to where you invoked this command." (interactive (list (xref--read-identifier "Find definitions of: "))) (xref--find-definitions identifier nil)) @@ -1479,7 +1521,8 @@ output of this command when the backend is etags." ;;; Key bindings ;;;###autoload (define-key esc-map "." #'xref-find-definitions) -;;;###autoload (define-key esc-map "," #'xref-pop-marker-stack) +;;;###autoload (define-key esc-map "," #'xref-go-back) +;;;###autoload (define-key esc-map [?\C-,] #'xref-go-forward) ;;;###autoload (define-key esc-map "?" #'xref-find-references) ;;;###autoload (define-key esc-map [?\C-.] #'xref-find-apropos) ;;;###autoload (define-key ctl-x-4-map "." #'xref-find-definitions-other-window) diff --git a/lisp/progmodes/xscheme.el b/lisp/progmodes/xscheme.el index 26ffe33b83e..e7667ebf51f 100644 --- a/lisp/progmodes/xscheme.el +++ b/lisp/progmodes/xscheme.el @@ -574,9 +574,8 @@ See also the commands \\[xscheme-yank-pop] and \\[xscheme-yank-push]." (if (consp arg) (exchange-point-and-mark))) -;; Old name, to avoid errors in users' init files. -(fset 'xscheme-yank-previous-send - 'xscheme-yank) +(define-obsolete-function-alias 'xscheme-yank-previous-send + #'xscheme-yank "29.1") (defun xscheme-yank-pop (arg) "Insert or replace a just-yanked expression with an older expression. diff --git a/lisp/ps-mule.el b/lisp/ps-mule.el index ab8af40628a..2d1dcd2b686 100644 --- a/lisp/ps-mule.el +++ b/lisp/ps-mule.el @@ -1209,8 +1209,8 @@ V%s 0 /%s-latin1 /%s Latin1Encoding put\n" (ps-output-prologue (format "ETOP%d %d %d put\n" i (car font) index)) (setq index (1+ index)))) (ps-output-prologue (format "/VTOP%d [%s] def\n" i - (mapconcat #'(lambda (x) - (format "F%02X" (cdr x))) + (mapconcat (lambda (x) + (format "F%02X" (cdr x))) font-list " "))))) ;; Redefine fonts f0, f1, f2, f3, h0, h1, H0. diff --git a/lisp/ps-print.el b/lisp/ps-print.el index b1d03fda1d4..0fc95546794 100644 --- a/lisp/ps-print.el +++ b/lisp/ps-print.el @@ -3855,7 +3855,7 @@ It can be retrieved with `(ps-get ALIST-SYM KEY)'." (defun ps-color-scale (color) ;; Scale 16-bit X-COLOR-VALUE to PostScript color value in [0, 1] interval. - (mapcar #'(lambda (value) (/ value ps-print-color-scale)) + (mapcar (lambda (value) (/ value ps-print-color-scale)) (color-values color))) @@ -4747,11 +4747,11 @@ page-height == ((floor print-height ((th + ls) * zh)) * ((th + ls) * zh)) - th (defun ps-background-pages (page-list func) (if page-list (mapcar - #'(lambda (pages) - (let ((start (if (consp pages) (car pages) pages)) - (end (if (consp pages) (cdr pages) pages))) - (and (integerp start) (integerp end) (<= start end) - (add-to-list 'ps-background-pages (vector start end func))))) + (lambda (pages) + (let ((start (if (consp pages) (car pages) pages)) + (end (if (consp pages) (cdr pages) pages))) + (and (integerp start) (integerp end) (<= start end) + (add-to-list 'ps-background-pages (vector start end func))))) page-list) (setq ps-background-all-pages (cons func ps-background-all-pages)))) @@ -4789,76 +4789,76 @@ page-height == ((floor print-height ((th + ls) * zh)) * ((th + ls) * zh)) - th (defun ps-background-text () (mapcar - #'(lambda (text) - (setq ps-background-text-count (1+ ps-background-text-count)) - (ps-output (format "/ShowBackText-%d{\n" ps-background-text-count)) - (ps-output-string (nth 0 text)) ; text - (ps-output - "\n" - (ps-float-format (nth 4 text) 200.0) ; font size - (format "/%s " (or (nth 3 text) "Times-Roman")) ; font name - (ps-float-format (nth 6 text) - "PrintHeight PrintPageWidth atan") ; rotation - (ps-float-format (nth 5 text) 0.85) ; gray - (ps-float-format (nth 1 text) "0") ; x position - (ps-float-format (nth 2 text) "0") ; y position - "\nShowBackText}def\n") - (ps-background-pages (nthcdr 7 text) ; page list - (format "ShowBackText-%d\n" - ps-background-text-count))) + (lambda (text) + (setq ps-background-text-count (1+ ps-background-text-count)) + (ps-output (format "/ShowBackText-%d{\n" ps-background-text-count)) + (ps-output-string (nth 0 text)) ; text + (ps-output + "\n" + (ps-float-format (nth 4 text) 200.0) ; font size + (format "/%s " (or (nth 3 text) "Times-Roman")) ; font name + (ps-float-format (nth 6 text) + "PrintHeight PrintPageWidth atan") ; rotation + (ps-float-format (nth 5 text) 0.85) ; gray + (ps-float-format (nth 1 text) "0") ; x position + (ps-float-format (nth 2 text) "0") ; y position + "\nShowBackText}def\n") + (ps-background-pages (nthcdr 7 text) ; page list + (format "ShowBackText-%d\n" + ps-background-text-count))) ps-print-background-text)) (defun ps-background-image () (mapcar - #'(lambda (image) - (let ((image-file (expand-file-name (nth 0 image)))) - (when (file-readable-p image-file) - (setq ps-background-image-count (1+ ps-background-image-count)) - (ps-output - (format "/ShowBackImage-%d{\n--back-- " - ps-background-image-count) - (ps-float-format (nth 5 image) 0.0) ; rotation - (ps-float-format (nth 3 image) 1.0) ; x scale - (ps-float-format (nth 4 image) 1.0) ; y scale - (ps-float-format (nth 1 image) ; x position - "PrintPageWidth 2 div") - (ps-float-format (nth 2 image) ; y position - "PrintHeight 2 div BottomMargin add") - "\nBeginBackImage\n") - (ps-insert-file image-file) - ;; coordinate adjustment to center image - ;; around x and y position - (let ((box (ps-get-boundingbox))) - (with-current-buffer ps-spool-buffer - (save-excursion - (if (re-search-backward "^--back--" nil t) - (replace-match - (format "%s %s" - (ps-float-format - (- (+ (/ (- (aref box 2) (aref box 0)) 2.0) - (aref box 0)))) - (ps-float-format - (- (+ (/ (- (aref box 3) (aref box 1)) 2.0) - (aref box 1))))) - t))))) - (ps-output "\nEndBackImage}def\n") - (ps-background-pages (nthcdr 6 image) ; page list - (format "ShowBackImage-%d\n" - ps-background-image-count))))) + (lambda (image) + (let ((image-file (expand-file-name (nth 0 image)))) + (when (file-readable-p image-file) + (setq ps-background-image-count (1+ ps-background-image-count)) + (ps-output + (format "/ShowBackImage-%d{\n--back-- " + ps-background-image-count) + (ps-float-format (nth 5 image) 0.0) ; rotation + (ps-float-format (nth 3 image) 1.0) ; x scale + (ps-float-format (nth 4 image) 1.0) ; y scale + (ps-float-format (nth 1 image) ; x position + "PrintPageWidth 2 div") + (ps-float-format (nth 2 image) ; y position + "PrintHeight 2 div BottomMargin add") + "\nBeginBackImage\n") + (ps-insert-file image-file) + ;; coordinate adjustment to center image + ;; around x and y position + (let ((box (ps-get-boundingbox))) + (with-current-buffer ps-spool-buffer + (save-excursion + (if (re-search-backward "^--back--" nil t) + (replace-match + (format "%s %s" + (ps-float-format + (- (+ (/ (- (aref box 2) (aref box 0)) 2.0) + (aref box 0)))) + (ps-float-format + (- (+ (/ (- (aref box 3) (aref box 1)) 2.0) + (aref box 1))))) + t))))) + (ps-output "\nEndBackImage}def\n") + (ps-background-pages (nthcdr 6 image) ; page list + (format "ShowBackImage-%d\n" + ps-background-image-count))))) ps-print-background-image)) (defun ps-background (page-number) (let (has-local-background) - (mapc #'(lambda (range) - (and (<= (aref range 0) page-number) - (<= page-number (aref range 1)) - (if has-local-background - (ps-output (aref range 2)) - (setq has-local-background t) - (ps-output "/printLocalBackground{\n" - (aref range 2))))) + (mapc (lambda (range) + (and (<= (aref range 0) page-number) + (<= page-number (aref range 1)) + (if has-local-background + (ps-output (aref range 2)) + (setq has-local-background t) + (ps-output "/printLocalBackground{\n" + (aref range 2))))) ps-background-pages) (and has-local-background (ps-output "}def\n")))) @@ -5697,8 +5697,8 @@ XSTART YSTART are the relative position for the first page in a sheet.") (> (car page) 0) (<= (car page) (cdr page)) (setq new (cons page new)))))) - (setq ps-selected-pages (sort new #'(lambda (one other) - (< (car one) (car other)))) + (setq ps-selected-pages (sort new (lambda (one other) + (< (car one) (car other)))) ps-last-selected-pages ps-selected-pages ps-first-page nil ps-last-page nil)) @@ -5782,8 +5782,8 @@ XSTART YSTART are the relative position for the first page in a sheet.") "unspecified-fg" 0.0) ps-foreground-list (mapcar - #'(lambda (arg) - (ps-rgb-color arg "unspecified-fg" 0.0)) + (lambda (arg) + (ps-rgb-color arg "unspecified-fg" 0.0)) (append (and (not (member ps-print-color-p '(nil black-white))) ps-fg-list) @@ -6012,9 +6012,9 @@ XSTART YSTART are the relative position for the first page in a sheet.") (if (and (boundp 'ucs-mule-8859-to-mule-unicode) (char-table-p ucs-mule-8859-to-mule-unicode)) (map-char-table - #'(lambda (k v) - (if (and v (eq (char-charset v) 'latin-iso8859-1) (/= k v)) - (aset tbl k v))) + (lambda (k v) + (if (and v (eq (char-charset v) 'latin-iso8859-1) (/= k v)) + (aset tbl k v))) ucs-mule-8859-to-mule-unicode)) tbl) "Translation table for PostScript printing. diff --git a/lisp/recentf.el b/lisp/recentf.el index 57cbaf0debb..6b5a47c66fd 100644 --- a/lisp/recentf.el +++ b/lisp/recentf.el @@ -674,55 +674,55 @@ Return nil if file NAME is not one of the ten more recent." "Sort the list of menu elements L in ascending order. The MENU-ITEM part of each menu element is compared." (sort (copy-sequence l) - #'(lambda (e1 e2) - (recentf-string-lessp - (recentf-menu-element-item e1) - (recentf-menu-element-item e2))))) + (lambda (e1 e2) + (recentf-string-lessp + (recentf-menu-element-item e1) + (recentf-menu-element-item e2))))) (defsubst recentf-sort-descending (l) "Sort the list of menu elements L in descending order. The MENU-ITEM part of each menu element is compared." (sort (copy-sequence l) - #'(lambda (e1 e2) - (recentf-string-lessp - (recentf-menu-element-item e2) - (recentf-menu-element-item e1))))) + (lambda (e1 e2) + (recentf-string-lessp + (recentf-menu-element-item e2) + (recentf-menu-element-item e1))))) (defsubst recentf-sort-basenames-ascending (l) "Sort the list of menu elements L in ascending order. Only filenames sans directory are compared." (sort (copy-sequence l) - #'(lambda (e1 e2) - (recentf-string-lessp - (file-name-nondirectory (recentf-menu-element-value e1)) - (file-name-nondirectory (recentf-menu-element-value e2)))))) + (lambda (e1 e2) + (recentf-string-lessp + (file-name-nondirectory (recentf-menu-element-value e1)) + (file-name-nondirectory (recentf-menu-element-value e2)))))) (defsubst recentf-sort-basenames-descending (l) "Sort the list of menu elements L in descending order. Only filenames sans directory are compared." (sort (copy-sequence l) - #'(lambda (e1 e2) - (recentf-string-lessp - (file-name-nondirectory (recentf-menu-element-value e2)) - (file-name-nondirectory (recentf-menu-element-value e1)))))) + (lambda (e1 e2) + (recentf-string-lessp + (file-name-nondirectory (recentf-menu-element-value e2)) + (file-name-nondirectory (recentf-menu-element-value e1)))))) (defsubst recentf-sort-directories-ascending (l) "Sort the list of menu elements L in ascending order. Compares directories then filenames to order the list." (sort (copy-sequence l) - #'(lambda (e1 e2) - (recentf-directory-compare - (recentf-menu-element-value e1) - (recentf-menu-element-value e2))))) + (lambda (e1 e2) + (recentf-directory-compare + (recentf-menu-element-value e1) + (recentf-menu-element-value e2))))) (defsubst recentf-sort-directories-descending (l) "Sort the list of menu elements L in descending order. Compares directories then filenames to order the list." (sort (copy-sequence l) - #'(lambda (e1 e2) - (recentf-directory-compare - (recentf-menu-element-value e2) - (recentf-menu-element-value e1))))) + (lambda (e1 e2) + (recentf-directory-compare + (recentf-menu-element-value e2) + (recentf-menu-element-value e1))))) (defun recentf-show-basenames (l &optional no-dir) "Filter the list of menu elements L to show filenames sans directory. @@ -1382,5 +1382,5 @@ buffers you switch to a lot, you can say something like the following: (provide 'recentf) (run-hooks 'recentf-load-hook) - + ;;; recentf.el ends here diff --git a/lisp/register.el b/lisp/register.el index e48a09f1574..38ee87cd775 100644 --- a/lisp/register.el +++ b/lisp/register.el @@ -279,6 +279,8 @@ ARG is the value of the prefix argument or nil." (goto-char (cadr val))) ((eq (car val) 'file) (find-file (cdr val))) + ((eq (car val) 'buffer) + (switch-to-buffer (cdr val))) ((eq (car val) 'file-query) (or (find-buffer-visiting (nth 1 val)) (y-or-n-p (format "Visit file %s again? " (nth 1 val))) @@ -417,6 +419,11 @@ Interactively, reads the register using `register-read-with-preview'." (prin1 (cdr val)) (princ ".")) + ((eq (car val) 'buffer) + (princ "the buffer ") + (prin1 (cdr val)) + (princ ".")) + ((eq (car val) 'file-query) (princ "a file-query reference:\n file ") (prin1 (car (cdr val))) diff --git a/lisp/repeat.el b/lisp/repeat.el index 308ba46a265..ea6da5d7f9b 100644 --- a/lisp/repeat.el +++ b/lisp/repeat.el @@ -546,31 +546,32 @@ See `describe-repeat-maps' for a list of all repeatable commands." Used in `repeat-mode'." (interactive) (require 'help-fns) - (help-setup-xref (list #'describe-repeat-maps) - (called-interactively-p 'interactive)) - (let ((keymaps nil)) - (all-completions - "" obarray (lambda (s) - (and (commandp s) - (get s 'repeat-map) - (push s (alist-get (get s 'repeat-map) keymaps))))) - (with-help-window (help-buffer) - (with-current-buffer standard-output - (princ "A list of keymaps used by commands with the symbol property `repeat-map'.\n\n") - - (dolist (keymap (sort keymaps (lambda (a b) (string-lessp (car a) (car b))))) - (princ (format-message "`%s' keymap is repeatable by these commands:\n" - (car keymap))) - (dolist (command (sort (cdr keymap) 'string-lessp)) - (let* ((info (help-fns--analyze-function command)) - (map (list (symbol-value (car keymap)))) - (desc (mapconcat (lambda (key) - (format-message "`%s'" (key-description key))) - (or (where-is-internal command map) - (where-is-internal (nth 3 info) map)) - ", "))) - (princ (format-message " `%s' (bound to %s)\n" command desc)))) - (princ "\n")))))) + (let ((help-buffer-under-preparation t)) + (help-setup-xref (list #'describe-repeat-maps) + (called-interactively-p 'interactive)) + (let ((keymaps nil)) + (all-completions + "" obarray (lambda (s) + (and (commandp s) + (get s 'repeat-map) + (push s (alist-get (get s 'repeat-map) keymaps))))) + (with-help-window (help-buffer) + (with-current-buffer standard-output + (princ "A list of keymaps used by commands with the symbol property `repeat-map'.\n\n") + + (dolist (keymap (sort keymaps (lambda (a b) (string-lessp (car a) (car b))))) + (princ (format-message "`%s' keymap is repeatable by these commands:\n" + (car keymap))) + (dolist (command (sort (cdr keymap) 'string-lessp)) + (let* ((info (help-fns--analyze-function command)) + (map (list (symbol-value (car keymap)))) + (desc (mapconcat (lambda (key) + (format-message "`%s'" (key-description key))) + (or (where-is-internal command map) + (where-is-internal (nth 3 info) map)) + ", "))) + (princ (format-message " `%s' (bound to %s)\n" command desc)))) + (princ "\n"))))))) (provide 'repeat) diff --git a/lisp/replace.el b/lisp/replace.el index 84ec042f455..0e81b15a097 100644 --- a/lisp/replace.el +++ b/lisp/replace.el @@ -2263,11 +2263,11 @@ See also `multi-occur'." (defun occur-engine-add-prefix (lines &optional prefix-face) (mapcar - #'(lambda (line) - (concat (if prefix-face - (propertize " :" 'font-lock-face prefix-face) - " :") - line "\n")) + (lambda (line) + (concat (if prefix-face + (propertize " :" 'font-lock-face prefix-face) + " :") + line "\n")) lines)) (defun occur-accumulate-lines (count &optional keep-props pt) @@ -2402,20 +2402,20 @@ To be added to `context-menu-functions'." ;; It would be nice to use \\[...], but there is no reasonable way ;; to make that display both SPC and Y. (defconst query-replace-help - "Type Space or `y' to replace one match, Delete or `n' to skip to next, -RET or `q' to exit, Period to replace one match and exit, -Comma to replace but not move point immediately, -C-r to enter recursive edit (\\[exit-recursive-edit] to get out again), -C-w to delete match and recursive edit, -C-l to clear the screen, redisplay, and offer same replacement again, -! to replace all remaining matches in this buffer with no more questions, -^ to move point back to previous match, -u to undo previous replacement, -U to undo all replacements, -E to edit the replacement string. -In multi-buffer replacements type `Y' to replace all remaining + "Type \\`SPC' or \\`y' to replace one match, Delete or \\`n' to skip to next, +\\`RET' or \\`q' to exit, Period to replace one match and exit, +\\`,' to replace but not move point immediately, +\\`C-r' to enter recursive edit (\\[exit-recursive-edit] to get out again), +\\`C-w' to delete match and recursive edit, +\\`C-l' to clear the screen, redisplay, and offer same replacement again, +\\`!' to replace all remaining matches in this buffer with no more questions, +\\`^' to move point back to previous match, +\\`u' to undo previous replacement, +\\`U' to undo all replacements, +\\`E' to edit the replacement string. +In multi-buffer replacements type \\`Y' to replace all remaining matches in all remaining buffers with no more questions, -`N' to skip to the next buffer without replacing remaining matches +\\`N' to skip to the next buffer without replacing remaining matches in the current buffer." "Help message while in `query-replace'.") diff --git a/lisp/rot13.el b/lisp/rot13.el index 4e4e60fea3f..e509b22529f 100644 --- a/lisp/rot13.el +++ b/lisp/rot13.el @@ -46,29 +46,23 @@ ;;; Code: -(defvar rot13-display-table - (let ((table (make-display-table)) - (i 0)) - (while (< i 26) +(defconst rot13-display-table + (let ((table (make-display-table))) + (dotimes (i 26) (aset table (+ i ?a) (vector (+ (% (+ i 13) 26) ?a))) - (aset table (+ i ?A) (vector (+ (% (+ i 13) 26) ?A))) - (setq i (1+ i))) + (aset table (+ i ?A) (vector (+ (% (+ i 13) 26) ?A)))) table) "Char table for ROT13 display.") -(defvar rot13-translate-table - (let ((str (make-string 127 0)) - (i 0)) - (while (< i 127) - (aset str i i) - (setq i (1+ i))) - (setq i 0) - (while (< i 26) - (aset str (+ i ?a) (+ (% (+ i 13) 26) ?a)) - (aset str (+ i ?A) (+ (% (+ i 13) 26) ?A)) - (setq i (1+ i))) - str) - "String table for ROT13 translation.") +(put 'plain-char-table 'char-table-extra-slots 0) + +(defconst rot13-translate-table + (let ((table (make-char-table 'translation-table))) + (dotimes (i 26) + (aset table (+ i ?a) (+ (% (+ i 13) 26) ?a)) + (aset table (+ i ?A) (+ (% (+ i 13) 26) ?A))) + table) + "Char table for ROT13 translation.") ;;;###autoload (defun rot13 (object &optional start end) diff --git a/lisp/saveplace.el b/lisp/saveplace.el index 4191a3fa62e..3eff816fa07 100644 --- a/lisp/saveplace.el +++ b/lisp/saveplace.el @@ -328,11 +328,18 @@ may have changed) back to `save-place-alist'." (with-current-buffer (car buf-list) ;; save-place checks buffer-file-name too, but we can avoid ;; overhead of function call by checking here too. - (and (or buffer-file-name (and (derived-mode-p 'dired-mode) - (boundp 'dired-subdir-alist) - dired-subdir-alist - (dired-current-directory))) - (save-place-to-alist)) + (when (and (or buffer-file-name + (and (derived-mode-p 'dired-mode) + (boundp 'dired-subdir-alist) + dired-subdir-alist + (dired-current-directory))) + ;; Don't save place in literally-visited file + ;; because this will commonly differ from the place + ;; when visiting literally (and + ;; `find-file-literally' always places point at the + ;; start of the buffer). + (not find-file-literally)) + (save-place-to-alist)) (setq buf-list (cdr buf-list)))))) (defun save-place-find-file-hook () diff --git a/lisp/select.el b/lisp/select.el index 15e171c13f9..43424d94b39 100644 --- a/lisp/select.el +++ b/lisp/select.el @@ -304,22 +304,32 @@ the formats available in the clipboard if TYPE is `CLIPBOARD'." (let ((data (gui-backend-get-selection (or type 'PRIMARY) (or data-type 'STRING)))) (when (and (stringp data) - (setq data-type (get-text-property 0 'foreign-selection data))) + ;; If this text property is set, then the data needs to + ;; be decoded -- otherwise it has already been decoded + ;; by the lower level functions. + (get-text-property 0 'foreign-selection data)) (let ((coding (or next-selection-coding-system selection-coding-system (pcase data-type ('UTF8_STRING 'utf-8) ('COMPOUND_TEXT 'compound-text-with-extensions) ('C_STRING nil) - ('STRING 'iso-8859-1) - (_ (error "Unknown selection data type: %S" - type)))))) - (setq data (if coding (decode-coding-string data coding) - ;; This is for C_STRING case. + ('STRING 'iso-8859-1))))) + (setq data + (cond (coding (decode-coding-string data coding)) ;; We want to convert each non-ASCII byte to the ;; corresponding eight-bit character, which has ;; a codepoint >= #x3FFF00. - (string-to-multibyte data)))) + ((eq data-type 'C_STRING) + (string-to-multibyte data)) + ;; Guess at the charset for types like text/html + ;; -- it can be anything, and different + ;; applications use different encodings. + ((string-match-p "\\`text/" (symbol-name data-type)) + (decode-coding-string + data (car (detect-coding-string data)))) + ;; Do nothing. + (t data)))) (setq next-selection-coding-system nil) (put-text-property 0 (length data) 'foreign-selection data-type data)) data)) @@ -440,13 +450,13 @@ two markers or an overlay. Otherwise, it is nil." (setq type 'C_STRING)) (t (let (non-latin-1 non-unicode eight-bit) - (mapc #'(lambda (x) - (if (>= x #x100) - (if (< x #x110000) - (setq non-latin-1 t) - (if (< x #x3FFF80) - (setq non-unicode t) - (setq eight-bit t))))) + (mapc (lambda (x) + (if (>= x #x100) + (if (< x #x110000) + (setq non-latin-1 t) + (if (< x #x3FFF80) + (setq non-unicode t) + (setq eight-bit t))))) str) (setq type (if (or non-unicode (and diff --git a/lisp/server.el b/lisp/server.el index 6359a761994..2f003a380a1 100644 --- a/lisp/server.el +++ b/lisp/server.el @@ -90,12 +90,12 @@ (defcustom server-use-tcp nil "If non-nil, use TCP sockets instead of local sockets." - :set #'(lambda (sym val) - (unless (featurep 'make-network-process '(:family local)) - (setq val t) - (unless load-in-progress - (message "Local sockets unsupported, using TCP sockets"))) - (set-default sym val)) + :set (lambda (sym val) + (unless (featurep 'make-network-process '(:family local)) + (setq val t) + (unless load-in-progress + (message "Local sockets unsupported, using TCP sockets"))) + (set-default sym val)) :type 'boolean :version "22.1") @@ -485,11 +485,11 @@ If CLIENT is non-nil, add a description of it to the logged message." (when (and (frame-live-p frame) proc ;; See if this is the last frame for this client. - (>= 1 (let ((frame-num 0)) - (dolist (f (frame-list)) - (when (eq proc (frame-parameter f 'client)) - (setq frame-num (1+ frame-num)))) - frame-num))) + (not (seq-some + (lambda (f) + (and (not (eq frame f)) + (eq proc (frame-parameter f 'client)))) + (frame-list)))) (server-log (format "server-handle-delete-frame, frame %s" frame) proc) (server-delete-client proc 'noframe)))) ; Let delete-frame delete the frame later. @@ -1580,13 +1580,13 @@ specifically for the clients and did not exist before their request for it." (server-buffer-done (current-buffer)))) (defun server-kill-emacs-query-function () - "Ask before exiting Emacs if it has live clients." - (or (not (let (live-client) - (dolist (proc server-clients) - (when (memq t (mapcar #'buffer-live-p - (process-get proc 'buffers))) - (setq live-client t))) - live-client)) + "Ask before exiting Emacs if it has live clients. +A \"live client\" is a client with at least one live buffer +associated with it." + (or (not (seq-some (lambda (proc) + (seq-some #'buffer-live-p + (process-get proc 'buffers))) + server-clients)) (yes-or-no-p "This Emacs session has clients; exit anyway? "))) (defun server-kill-buffer () @@ -1716,6 +1716,9 @@ be a cons cell (LINENUMBER . COLUMNNUMBER)." (when server-raise-frame (select-frame-set-input-focus (window-frame))))) +(defvar server-stop-automatically nil + "Internal status variable for `server-stop-automatically'.") + ;;;###autoload (defun server-save-buffers-kill-terminal (arg) ;; Called from save-buffers-kill-terminal in files.el. @@ -1724,27 +1727,103 @@ With ARG non-nil, silently save all file-visiting buffers, then kill. If emacsclient was started with a list of filenames to edit, then only these files will be asked to be saved." - (let ((proc (frame-parameter nil 'client))) - (cond ((eq proc 'nowait) - ;; Nowait frames have no client buffer list. - (if (cdr (frame-list)) - (progn (save-some-buffers arg) - (delete-frame)) - ;; If we're the last frame standing, kill Emacs. - (save-buffers-kill-emacs arg))) - ((processp proc) - (let ((buffers (process-get proc 'buffers))) - (save-some-buffers - arg (if buffers - ;; Only files from emacsclient file list. - (lambda () (memq (current-buffer) buffers)) - ;; No emacsclient file list: don't override - ;; `save-some-buffers-default-predicate' (unless - ;; ARG is non-nil), since we're not killing - ;; Emacs (unlike `save-buffers-kill-emacs'). - (and arg t))) - (server-delete-client proc))) - (t (error "Invalid client frame"))))) + (if server-stop-automatically + (server-stop-automatically--handle-delete-frame (selected-frame)) + (let ((proc (frame-parameter nil 'client))) + (cond ((eq proc 'nowait) + ;; Nowait frames have no client buffer list. + (if (cdr (frame-list)) + (progn (save-some-buffers arg) + (delete-frame)) + ;; If we're the last frame standing, kill Emacs. + (save-buffers-kill-emacs arg))) + ((processp proc) + (let ((buffers (process-get proc 'buffers))) + (save-some-buffers + arg (if buffers + ;; Only files from emacsclient file list. + (lambda () (memq (current-buffer) buffers)) + ;; No emacsclient file list: don't override + ;; `save-some-buffers-default-predicate' (unless + ;; ARG is non-nil), since we're not killing + ;; Emacs (unlike `save-buffers-kill-emacs'). + (and arg t))) + (server-delete-client proc))) + (t (error "Invalid client frame")))))) + +(defun server-stop-automatically--handle-delete-frame (frame) + "Handle deletion of FRAME when `server-stop-automatically' is used." + (when server-stop-automatically + (if (if (and (processp (frame-parameter frame 'client)) + (eq this-command 'save-buffers-kill-terminal)) + (progn + (dolist (f (frame-list)) + (when (and (eq (frame-parameter frame 'client) + (frame-parameter f 'client)) + (not (eq frame f))) + (set-frame-parameter f 'client nil) + (let ((server-stop-automatically nil)) + (delete-frame f)))) + (if (cddr (frame-list)) + (let ((server-stop-automatically nil)) + (delete-frame frame) + nil) + t)) + (null (cddr (frame-list)))) + (let ((server-stop-automatically nil)) + (save-buffers-kill-emacs) + (delete-frame frame))))) + +(defun server-stop-automatically--maybe-kill-emacs () + "Handle closing of Emacs daemon when `server-stop-automatically' is used." + (unless (cdr (frame-list)) + (when (and + (not (memq t (mapcar (lambda (b) + (and (buffer-file-name b) + (buffer-modified-p b))) + (buffer-list)))) + (not (memq t (mapcar (lambda (p) + (and (memq (process-status p) + '(run stop open listen)) + (process-query-on-exit-flag p))) + (process-list))))) + (kill-emacs)))) + +;;;###autoload +(defun server-stop-automatically (arg) + "Automatically stop server as specified by ARG. + +If ARG is the symbol `empty', stop the server when it has no +remaining clients, no remaining unsaved file-visiting buffers, +and no running processes with a `query-on-exit' flag. + +If ARG is the symbol `delete-frame', ask the user when the last +frame is deleted whether each unsaved file-visiting buffer must +be saved and each running process with a `query-on-exit' flag +can be stopped, and if so, stop the server itself. + +If ARG is the symbol `kill-terminal', ask the user when the +terminal is killed with \\[save-buffers-kill-terminal] \ +whether each unsaved file-visiting +buffer must be saved and each running process with a `query-on-exit' +flag can be stopped, and if so, stop the server itself. + +Any other value of ARG will cause this function to signal an error. + +This function is meant to be called from the user init file." + (when (daemonp) + (setq server-stop-automatically arg) + (cond + ((eq arg 'empty) + (setq server-stop-automatically nil) + (run-with-timer 10 2 + #'server-stop-automatically--maybe-kill-emacs)) + ((eq arg 'delete-frame) + (add-hook 'delete-frame-functions + #'server-stop-automatically--handle-delete-frame)) + ((eq arg 'kill-terminal)) + (t + (error "Unexpected argument"))))) (define-key ctl-x-map "#" 'server-edit) diff --git a/lisp/ses.el b/lisp/ses.el index ea966295b18..8496aeec8e8 100644 --- a/lisp/ses.el +++ b/lisp/ses.el @@ -227,12 +227,6 @@ Used for listing local printers or renamed cells.") "w" ses-set-column-width "x" ses-export-keymap "\M-p" ses-read-column-printer)) - (repl '(;;We'll replace these wherever they appear in the keymap - clipboard-kill-region ses-kill-override - end-of-line ses-end-of-line - kill-line ses-delete-row - kill-region ses-kill-override - open-line ses-insert-row)) (numeric "0123456789.-") (newmap (make-keymap))) ;;Get rid of printables @@ -240,13 +234,11 @@ Used for listing local printers or renamed cells.") ;;These keys insert themselves as the beginning of a numeric value (dotimes (x (length numeric)) (define-key newmap (substring numeric x (1+ x)) 'ses-read-cell)) - ;;Override these global functions wherever they're bound - (while repl - (substitute-key-definition (car repl) (cadr repl) newmap - (current-global-map)) - (setq repl (cddr repl))) - ;;Apparently substitute-key-definition doesn't catch this? - (define-key newmap [(menu-bar) edit cut] 'ses-kill-override) + (define-key newmap [remap clipboard-kill-region] #'ses-kill-override) + (define-key newmap [remap end-of-line] #'ses-end-of-line) + (define-key newmap [remap kill-line] #'ses-delete-row) + (define-key newmap [remap kill-region] #'ses-kill-override) + (define-key newmap [remap open-line] #'ses-insert-row) ;;Define our other local keys (while keys (define-key newmap (car keys) (cadr keys)) @@ -3554,7 +3546,7 @@ With prefix, sorts in REVERSE order." (push (cons (buffer-substring-no-properties (point) end) (+ minrow x)) keys)) - (setq keys (sort keys #'(lambda (x y) (string< (car x) (car y))))) + (setq keys (sort keys (lambda (x y) (string< (car x) (car y))))) ;;Extract the lines in reverse sorted order (or reverse (setq keys (nreverse keys))) @@ -3774,7 +3766,9 @@ function is redefined." (setq name (intern name)) (let* ((cur-printer (gethash name ses--local-printer-hashmap)) (default (and cur-printer (ses--locprn-def cur-printer)))) - (setq def (ses-read-printer (format "Enter definition of printer %S" name) + (setq def (ses-read-printer (format-prompt + "Enter definition of printer %S" + default name) default))) (list name def))) diff --git a/lisp/shell.el b/lisp/shell.el index cb4afe6dea8..370532ea46f 100644 --- a/lisp/shell.el +++ b/lisp/shell.el @@ -785,7 +785,8 @@ Make the shell buffer the current buffer, and return it. (startfile (concat "~/.emacs_" name)) (xargs-name (intern-soft (concat "explicit-" name "-args")))) (unless (file-exists-p startfile) - (setq startfile (concat user-emacs-directory "init_" name ".sh"))) + (setq startfile (locate-user-emacs-file + (concat "init_" name ".sh")))) (setq-local shell--start-prog (file-name-nondirectory prog)) (apply #'make-comint-in-buffer "shell" buffer prog (if (file-exists-p startfile) startfile) diff --git a/lisp/simple.el b/lisp/simple.el index 94a459b7795..84928caa310 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -527,21 +527,28 @@ Other major modes are defined by comparison with this one." (kill-all-local-variables) (run-mode-hooks)) +(define-derived-mode clean-mode fundamental-mode "Clean" + "A mode that removes all overlays and text properties." + (kill-all-local-variables t) + (let ((inhibit-read-only t)) + (dolist (overlay (overlays-in (point-min) (point-max))) + (delete-overlay overlay)) + (set-text-properties (point-min) (point-max) nil) + (setq-local yank-excluded-properties t))) + ;; Special major modes to view specially formatted data rather than files. -(defvar special-mode-map - (let ((map (make-sparse-keymap))) - (suppress-keymap map) - (define-key map "q" 'quit-window) - (define-key map " " 'scroll-up-command) - (define-key map [?\S-\ ] 'scroll-down-command) - (define-key map "\C-?" 'scroll-down-command) - (define-key map "?" 'describe-mode) - (define-key map "h" 'describe-mode) - (define-key map ">" 'end-of-buffer) - (define-key map "<" 'beginning-of-buffer) - (define-key map "g" 'revert-buffer) - map)) +(defvar-keymap special-mode-map + :suppress t + "q" #'quit-window + "SPC" #'scroll-up-command + "S-SPC" #'scroll-down-command + "DEL" #'scroll-down-command + "?" #'describe-mode + "h" #'describe-mode + ">" #'end-of-buffer + "<" #'beginning-of-buffer + "g" #'revert-buffer) (put 'special-mode 'mode-class 'special) (define-derived-mode special-mode nil "Special" @@ -703,9 +710,10 @@ When called from Lisp code, ARG may be a prefix string to copy." :height 0.1 :background "#505050") (((type graphic) (background light)) :height 0.1 :background "#a0a0a0") - (t :foreground "ForestGreen")) + (t + :foreground "ForestGreen" :underline t)) "Face for separator lines." - :version "28.1" + :version "29.1" :group 'text) (defun make-separator-line (&optional length) @@ -713,11 +721,13 @@ When called from Lisp code, ARG may be a prefix string to copy." This uses the `separator-line' face. If LENGTH is nil, use the window width." - (if (display-graphic-p) + (if (or (display-graphic-p) + (display-supports-face-attributes-p '(:underline t))) (if length (concat (propertize (make-string length ?\s) 'face 'separator-line) "\n") (propertize "\n" 'face '(:inherit separator-line :extend t))) + ;; In terminals (that don't support underline), use a line of dashes. (concat (propertize (make-string (or length (1- (window-width))) ?-) 'face 'separator-line) "\n"))) @@ -3104,7 +3114,7 @@ Interactively, ARG is the prefix numeric argument and defaults to 1." (let ((undo-in-progress t)) (while (and (consp ul) (eq (car ul) nil)) (setq ul (cdr ul))) - (primitive-undo arg ul))) + (primitive-undo (or arg 1) ul))) (new-pul (undo--last-change-was-undo-p new-ul))) (message "Redo%s" (if undo-in-region " in region" "")) (setq this-command 'undo) @@ -5069,10 +5079,11 @@ interact nicely with `interprogram-cut-function' and interaction; you may want to use them instead of manipulating the kill ring directly.") -(defcustom kill-ring-max 60 +(defcustom kill-ring-max 120 "Maximum length of kill ring before oldest elements are thrown away." :type 'integer - :group 'killing) + :group 'killing + :version "29.1") (defvar kill-ring-yank-pointer nil "The tail of the kill ring whose car is the last thing yanked.") @@ -8573,40 +8584,43 @@ The function should return non-nil if the two tokens do not match.") (current-buffer)) (sit-for blink-matching-delay)) (delete-overlay blink-matching--overlay))))) - (t - (let ((open-paren-line-string - (save-excursion - (goto-char blinkpos) - ;; Show what precedes the open in its line, if anything. - (cond - ((save-excursion (skip-chars-backward " \t") (not (bolp))) - (buffer-substring (line-beginning-position) - (1+ blinkpos))) - ;; Show what follows the open in its line, if anything. - ((save-excursion - (forward-char 1) - (skip-chars-forward " \t") - (not (eolp))) - (buffer-substring blinkpos - (line-end-position))) - ;; Otherwise show the previous nonblank line, - ;; if there is one. - ((save-excursion (skip-chars-backward "\n \t") (not (bobp))) - (concat - (buffer-substring (progn - (skip-chars-backward "\n \t") - (line-beginning-position)) - (progn (end-of-line) - (skip-chars-backward " \t") - (point))) - ;; Replace the newline and other whitespace with `...'. - "..." - (buffer-substring blinkpos (1+ blinkpos)))) - ;; There is nothing to show except the char itself. - (t (buffer-substring blinkpos (1+ blinkpos))))))) - (minibuffer-message - "Matches %s" - (substring-no-properties open-paren-line-string)))))))) + ((not show-paren-context-when-offscreen) + (minibuffer-message + "Matches %s" + (substring-no-properties + (blink-paren-open-paren-line-string blinkpos)))))))) + +(defun blink-paren-open-paren-line-string (pos) + "Return the line string that contains the openparen at POS." + (save-excursion + (goto-char pos) + ;; Show what precedes the open in its line, if anything. + (cond + ((save-excursion (skip-chars-backward " \t") (not (bolp))) + (buffer-substring (line-beginning-position) + (1+ pos))) + ;; Show what follows the open in its line, if anything. + ((save-excursion + (forward-char 1) + (skip-chars-forward " \t") + (not (eolp))) + (buffer-substring pos + (line-end-position))) + ;; Otherwise show the previous nonblank line, + ;; if there is one. + ((save-excursion (skip-chars-backward "\n \t") (not (bobp))) + (concat + (buffer-substring (progn + (skip-chars-backward "\n \t") + (line-beginning-position)) + (progn (end-of-line) + (skip-chars-backward " \t") + (point))) + ;; Replace the newline and other whitespace with `...'. + "..." + (buffer-substring pos (1+ pos)))) + ;; There is nothing to show except the char itself. + (t (buffer-substring pos (1+ pos)))))) (defvar blink-paren-function 'blink-matching-open "Function called, if non-nil, whenever a close parenthesis is inserted. @@ -8898,7 +8912,7 @@ With a prefix argument, set VARIABLE to VALUE buffer-locally. When called interactively, the user is prompted for VARIABLE and then VALUE. The current value of VARIABLE will be put in the -minibuffer history so that it can be accessed with `M-n', which +minibuffer history so that it can be accessed with \\`M-n', which makes it easier to edit it." (interactive (let* ((default-var (variable-at-point)) @@ -9856,6 +9870,7 @@ does not have any effect until this variable is set. CUSTOMIZATIONS, if non-nil, should be composed of alternating `defcustom' keywords and values to add to the declaration of `COMMAND-alternatives' (typically :group and :version)." + (declare (indent defun)) (let* ((command-name (symbol-name command)) (varalt-name (concat command-name "-alternatives")) (varalt-sym (intern varalt-name)) diff --git a/lisp/skeleton.el b/lisp/skeleton.el index c363fb2c489..2b183996d83 100644 --- a/lisp/skeleton.el +++ b/lisp/skeleton.el @@ -113,7 +113,8 @@ are integer buffer positions in the reverse order of the insertion order.") "Define a user-configurable COMMAND that enters a statement skeleton. DOCUMENTATION is that of the command. SKELETON is as defined under `skeleton-insert'." - (declare (doc-string 2) (debug (&define name stringp skeleton-edebug-spec))) + (declare (doc-string 2) (debug (&define name stringp skeleton-edebug-spec)) + (indent defun)) (if skeleton-debug (set command skeleton)) `(progn diff --git a/lisp/sort.el b/lisp/sort.el index d6767ed5098..09259805415 100644 --- a/lisp/sort.el +++ b/lisp/sort.el @@ -540,8 +540,8 @@ Use \\[untabify] to convert tabs to spaces before sorting." (narrow-to-region beg1 end1) (goto-char beg1) (sort-subr reverse 'forward-line 'end-of-line - #'(lambda () (move-to-column col-start) nil) - #'(lambda () (move-to-column col-end) nil)))))))) + (lambda () (move-to-column col-start) nil) + (lambda () (move-to-column col-end) nil)))))))) ;;;###autoload (defun reverse-region (beg end) diff --git a/lisp/speedbar.el b/lisp/speedbar.el index 3cc3e276067..cfa96608bff 100644 --- a/lisp/speedbar.el +++ b/lisp/speedbar.el @@ -3694,27 +3694,21 @@ regular expression EXPR." ;;; BUFFER DISPLAY mode. ;; -(defvar speedbar-buffers-key-map nil +(defvar speedbar-buffers-key-map + (let ((map (speedbar-make-specialized-keymap))) + ;; Basic tree features + (define-key map "e" #'speedbar-edit-line) + (define-key map "\C-m" #'speedbar-edit-line) + (define-key map "+" #'speedbar-expand-line) + (define-key map "=" #'speedbar-expand-line) + (define-key map "-" #'speedbar-contract-line) + (define-key map " " #'speedbar-toggle-line-expansion) + ;; Buffer specific keybindings + (define-key map "k" #'speedbar-buffer-kill-buffer) + (define-key map "r" #'speedbar-buffer-revert-buffer) + map) "Keymap used when in the buffers display mode.") -(if speedbar-buffers-key-map - nil - (setq speedbar-buffers-key-map (speedbar-make-specialized-keymap)) - - ;; Basic tree features - (define-key speedbar-buffers-key-map "e" 'speedbar-edit-line) - (define-key speedbar-buffers-key-map "\C-m" 'speedbar-edit-line) - (define-key speedbar-buffers-key-map "+" 'speedbar-expand-line) - (define-key speedbar-buffers-key-map "=" 'speedbar-expand-line) - (define-key speedbar-buffers-key-map "-" 'speedbar-contract-line) - (define-key speedbar-buffers-key-map " " 'speedbar-toggle-line-expansion) - - ;; Buffer specific keybindings - (define-key speedbar-buffers-key-map "k" 'speedbar-buffer-kill-buffer) - (define-key speedbar-buffers-key-map "r" 'speedbar-buffer-revert-buffer) - - ) - (defvar speedbar-buffer-easymenu-definition '(["Jump to buffer" speedbar-edit-line t] ["Expand File Tags" speedbar-expand-line diff --git a/lisp/sqlite-mode.el b/lisp/sqlite-mode.el new file mode 100644 index 00000000000..082eb8276e8 --- /dev/null +++ b/lisp/sqlite-mode.el @@ -0,0 +1,216 @@ +;;; sqlite-mode.el --- Mode for examining sqlite3 database files -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'cl-lib) + +(declare-function sqlite-execute "sqlite.c") +(declare-function sqlite-more-p "sqlite.c") +(declare-function sqlite-next "sqlite.c") +(declare-function sqlite-columns "sqlite.c") +(declare-function sqlite-finalize "sqlite.c") +(declare-function sqlite-select "sqlite.c") +(declare-function sqlite-open "sqlite.c") + +(defvar-keymap sqlite-mode-map + "g" #'sqlite-mode-list-tables + "c" #'sqlite-mode-list-columns + "RET" #'sqlite-mode-list-data + "DEL" #'sqlite-mode-delete) + +(define-derived-mode sqlite-mode special-mode "Sqlite" + "This mode lists the contents of an .sqlite3 file" + :interactive nil + (buffer-disable-undo) + (setq-local buffer-read-only t + truncate-lines t)) + +(defvar sqlite--db nil) + +;;;###autoload +(defun sqlite-mode-open-file (file) + "Browse the contents of an sqlite file." + (interactive "fSQLite file name: ") + (unless (sqlite-available-p) + (error "This Emacs doesn't have SQLite support, so it can't view SQLite files")) + (pop-to-buffer (get-buffer-create + (format "*SQLite %s*" (file-name-nondirectory file)))) + (sqlite-mode) + (setq-local sqlite--db (sqlite-open file)) + (sqlite-mode-list-tables)) + +(defun sqlite-mode-list-tables () + "Re-list the tables from the currently selected database." + (interactive nil sqlite-mode) + (let ((inhibit-read-only t) + (db sqlite--db) + (entries nil)) + (erase-buffer) + (dolist (table (sqlite-select db "select name from sqlite_master where type = 'table' and name not like 'sqlite_%' order by name")) + (push (list (car table) + (caar (sqlite-select db (format "select count(*) from %s" + (car table))))) + entries)) + (sqlite-mode--tablify '("Table Name" "Number of Rows") + (nreverse entries) + 'table) + (goto-char (point-min)))) + +(defun sqlite-mode--tablify (columns rows type &optional prefix) + (let ((widths + (mapcar + (lambda (i) + (1+ (seq-max (mapcar (lambda (row) + (length (format "%s" (nth i row)))) + (cons columns rows))))) + (number-sequence 0 (1- (length columns)))))) + (when prefix + (insert prefix)) + (dotimes (i (length widths)) + (insert (propertize (format (format "%%-%ds " (nth i widths)) + (nth i columns)) + 'face 'header-line))) + (insert "\n") + (dolist (row rows) + (let ((start (point))) + (when prefix + (insert prefix)) + (dotimes (i (length widths)) + (let ((elem (nth i row))) + (insert (format (format "%%%s%ds " + (if (numberp elem) + "" "-") + (nth i widths)) + (if (numberp elem) + (nth i row) + (string-replace "\n" " " (or elem ""))))))) + (put-text-property start (point) 'sqlite--row row) + (put-text-property start (point) 'sqlite--type type) + (insert "\n"))))) + +(defun sqlite-mode-list-columns () + "List the columns of the table under point." + (interactive nil sqlite-mode) + (let ((row (get-text-property (point) 'sqlite--row))) + (unless row + (user-error "No table under point")) + (let ((columns (sqlite-mode--column-names (car row))) + (inhibit-read-only t)) + (save-excursion + (forward-line 1) + (if (looking-at " ") + ;; Delete the info. + (delete-region (point) (if (re-search-forward "^[^ ]" nil t) + (match-beginning 0) + (point-max))) + ;; Insert the info. + (dolist (column columns) + (insert (format " %s\n" column)))))))) + +(defun sqlite-mode--column-names (table) + (let ((sql + (caar + (sqlite-select + sqlite--db + "select sql from sqlite_master where tbl_name = ? AND type = 'table'" + (list table))))) + (mapcar + #'string-trim + (split-string (replace-regexp-in-string "^.*(\\|)$" "" sql) ",")))) + +(defun sqlite-mode-list-data () + "List the data from the table under point." + (interactive nil sqlite-mode) + (let ((row (and (eq (get-text-property (point) 'sqlite--type) 'table) + (get-text-property (point) 'sqlite--row)))) + (unless row + (user-error "No table under point")) + (let ((inhibit-read-only t)) + (save-excursion + (forward-line 1) + (if (looking-at " ") + ;; Delete the info. + (delete-region (point) (if (re-search-forward "^[^ ]" nil t) + (match-beginning 0) + (point-max))) + (sqlite--mode--list-data (list (car row) 0))))))) + +(defun sqlite-mode--more-data (stmt) + (let ((inhibit-read-only t)) + (beginning-of-line) + (delete-region (point) (progn (forward-line 1) (point))) + (sqlite--mode--list-data stmt))) + +(defun sqlite--mode--list-data (data) + (let* ((table (car data)) + (rowid (cadr data)) + stmt) + (unwind-protect + (progn + (setq stmt + (sqlite-select + sqlite--db + (format "select rowid, * from %s where rowid >= ?" table) + (list rowid) + 'set)) + (sqlite-mode--tablify (sqlite-columns stmt) + (cl-loop for i from 0 upto 1000 + for row = (sqlite-next stmt) + while row + do (setq rowid (car row)) + collect row) + (cons 'row table) + " ") + (when (sqlite-more-p stmt) + (insert (buttonize " More data...\n" #'sqlite-mode--more-data + (list table rowid))))) + (when stmt + (sqlite-finalize stmt))))) + +(defun sqlite-mode-delete () + "Delete the row under point." + (interactive nil sqlite-mode) + (let ((table (get-text-property (point) 'sqlite--type)) + (row (get-text-property (point) 'sqlite--row)) + (inhibit-read-only t)) + (when (or (not (consp table)) + (not (eq (car table) 'row))) + (user-error "No row under point")) + (unless (yes-or-no-p "Really delete the row under point? ") + (user-error "Not deleting")) + (sqlite-execute + sqlite--db + (format "delete from %s where %s" + (cdr table) + (string-join + (mapcar (lambda (column) + (format "%s = ?" (car (split-string column " ")))) + (cons "rowid" (sqlite-mode--column-names (cdr table)))) + " and ")) + row) + (delete-region (line-beginning-position) (progn (forward-line 1) (point))))) + +(provide 'sqlite-mode) + +;;; sqlite-mode.el ends here diff --git a/lisp/sqlite.el b/lisp/sqlite.el new file mode 100644 index 00000000000..6d32a0468f3 --- /dev/null +++ b/lisp/sqlite.el @@ -0,0 +1,43 @@ +;;; sqlite.el --- Functions for interacting with sqlite3 databases -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(defmacro with-sqlite-transaction (db &rest body) + "Execute BODY while holding a transaction for DB." + (declare (indent 1) (debug (form body))) + (let ((db-var (gensym)) + (func-var (gensym))) + `(let ((,db-var ,db) + (,func-var (lambda () ,@body))) + (if (sqlite-available-p) + (unwind-protect + (progn + (sqlite-transaction ,db-var) + (funcall ,func-var)) + (sqlite-commit ,db-var)) + (funcall ,func-var))))) + +(provide 'sqlite) + +;;; sqlite.el ends here diff --git a/lisp/startup.el b/lisp/startup.el index 505d7b83f48..a46a3a0233d 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -519,6 +519,19 @@ DIRS are relative." xdg-dir) (t emacs-d-dir)))) +(defvar comp--delayed-sources) +(defvar comp--loadable) +(declare-function native--compile-async "comp.el" + (files &optional recursively load selector)) +(defun startup--honor-delayed-native-compilations () + "Honor pending delayed deferred native compilations." + (when (and (native-comp-available-p) + comp--delayed-sources) + (require 'comp) + (setq comp--loadable t) + (native--compile-async comp--delayed-sources nil 'late) + (setq comp--delayed-sources nil))) + (defvar native-comp-eln-load-path) (defun normal-top-level () "Emacs calls this function when it first starts up. @@ -785,7 +798,8 @@ It is the default value of the variable `top-level'." (if (string-match "\\`DISPLAY=" varval) (setq display varval)))) (when display - (delete display process-environment))))) + (delete display process-environment)))) + (startup--honor-delayed-native-compilations)) ;; Precompute the keyboard equivalents in the menu bar items. ;; Command-line options supported by tty's: @@ -1556,17 +1570,22 @@ If this is nil, no message will be displayed." `((:face (variable-pitch font-lock-comment-face) "Welcome to " :link ("GNU Emacs" - ,(lambda (_button) (browse-url "https://www.gnu.org/software/emacs/")) + ,(lambda (_button) + (let ((browse-url-browser-function 'eww-browse-url)) + (browse-url "https://www.gnu.org/software/emacs/"))) "Browse https://www.gnu.org/software/emacs/") ", one component of the " :link ,(lambda () (if (eq system-type 'gnu/linux) `("GNU/Linux" - ,(lambda (_button) (browse-url "https://www.gnu.org/gnu/linux-and-gnu.html")) + ,(lambda (_button) + (let ((browse-url-browser-function 'eww-browse-url)) + (browse-url "https://www.gnu.org/gnu/linux-and-gnu.html"))) "Browse https://www.gnu.org/gnu/linux-and-gnu.html") `("GNU" ,(lambda (_button) - (browse-url "https://www.gnu.org/gnu/thegnuproject.html")) + (let ((browse-url-browser-function 'eww-browse-url)) + (browse-url "https://www.gnu.org/gnu/thegnuproject.html"))) "Browse https://www.gnu.org/gnu/thegnuproject.html"))) " operating system.\n\n" :face variable-pitch @@ -1599,7 +1618,8 @@ If this is nil, no message will be displayed." "\n" :link ("Emacs Guided Tour" ,(lambda (_button) - (browse-url "https://www.gnu.org/software/emacs/tour/")) + (let ((browse-url-browser-function 'eww-browse-url)) + (browse-url "https://www.gnu.org/software/emacs/tour/"))) "Browse https://www.gnu.org/software/emacs/tour/") "\tOverview of Emacs features at gnu.org\n" :link ("View Emacs Manual" ,(lambda (_button) (info-emacs-manual))) @@ -1622,22 +1642,31 @@ Each element in the list should be a list of strings or pairs `((:face (variable-pitch font-lock-comment-face) "This is " :link ("GNU Emacs" - ,(lambda (_button) (browse-url "https://www.gnu.org/software/emacs/")) + ,(lambda (_button) + (let ((browse-url-browser-function 'eww-browse-url)) + (browse-url "https://www.gnu.org/software/emacs/"))) "Browse https://www.gnu.org/software/emacs/") - ", one component of the " + ", a text editor and more.\nIt's a component of the " :link ,(lambda () (if (eq system-type 'gnu/linux) `("GNU/Linux" ,(lambda (_button) - (browse-url "https://www.gnu.org/gnu/linux-and-gnu.html")) + (let ((browse-url-browser-function 'eww-browse-url)) + (browse-url "https://www.gnu.org/gnu/linux-and-gnu.html"))) "Browse https://www.gnu.org/gnu/linux-and-gnu.html") - `("GNU" ,(lambda (_button) (describe-gnu-project)) + `("GNU" ,(lambda (_button) + (let ((browse-url-browser-function 'eww-browse-url)) + (describe-gnu-project))) "Display info on the GNU project."))) " operating system.\n" :face (variable-pitch font-lock-builtin-face) "\n" - ,(lambda () (emacs-version)) + ,(lambda () + (with-temp-buffer + (insert (emacs-version)) + (fill-region (point-min) (point-max)) + (buffer-string))) "\n" :face (variable-pitch (:height 0.8)) ,(lambda () emacs-copyright) @@ -1652,7 +1681,9 @@ Each element in the list should be a list of strings or pairs ,(lambda (_button) (info "(emacs)Contributing"))) "\tHow to report bugs and contribute improvements to Emacs\n" "\n" - :link ("GNU and Freedom" ,(lambda (_button) (describe-gnu-project))) + :link ("GNU and Freedom" ,(lambda (_button) + (let ((browse-url-browser-function 'eww-browse-url)) + (describe-gnu-project)))) "\tWhy we developed GNU Emacs, and the GNU operating system\n" :link ("Absence of Warranty" ,(lambda (_button) (describe-no-warranty))) "\tGNU Emacs comes with " @@ -1690,7 +1721,8 @@ Each element in the list should be a list of strings or pairs "\n" :link ("Emacs Guided Tour" ,(lambda (_button) - (browse-url "https://www.gnu.org/software/emacs/tour/")) + (let ((browse-url-browser-function 'eww-browse-url)) + (browse-url "https://www.gnu.org/software/emacs/tour/"))) "Browse https://www.gnu.org/software/emacs/tour/") "\tSee an overview of Emacs features at gnu.org\n" :link ("Emacs Manual" ,(lambda (_button) (info-emacs-manual))) @@ -1812,7 +1844,9 @@ a face or button specification." (make-button (prog1 (point) (insert-image img)) (point) 'face 'default 'help-echo "mouse-2, RET: Browse https://www.gnu.org/" - 'action (lambda (_button) (browse-url "https://www.gnu.org/")) + 'action (lambda (_button) + (let ((browse-url-browser-function 'eww-browse-url)) + (browse-url "https://www.gnu.org/"))) 'follow-link t) (insert "\n\n"))))) @@ -1821,28 +1855,35 @@ a face or button specification." (unless concise (fancy-splash-insert :face 'variable-pitch - "\nTo start... " + "\nTo start...\t" :link `("Open a File" ,(lambda (_button) (call-interactively 'find-file)) "Specify a new file's name, to edit the file") - " " + "\t\t" :link `("Open Home Directory" ,(lambda (_button) (dired "~")) "Open your home directory, to operate on its files") - " " + "\n\t" :link `("Customize Startup" ,(lambda (_button) (customize-group 'initialization)) "Change initialization settings including this screen") + "\t" + :link `("Explore Packages" + ,(lambda (_button) (call-interactively 'package-list-packages)) + "Explore, install and remove Emacs packages (requires Internet connection)") "\n")) (fancy-splash-insert :face 'variable-pitch "To quit a partially entered command, type " :face 'default "Control-g" :face 'variable-pitch ".\n") - (fancy-splash-insert :face '(variable-pitch font-lock-builtin-face) - "\nThis is " - (emacs-version) - "\n" - :face '(variable-pitch (:height 0.8)) + (save-restriction + (narrow-to-region (point) (point)) + (fancy-splash-insert :face '(variable-pitch font-lock-builtin-face) + "\nThis is " + (emacs-version) + "\n") + (fill-region (point-min) (point-max))) + (fancy-splash-insert :face '(variable-pitch (:height 0.8)) emacs-copyright "\n") (when auto-save-list-file-prefix @@ -1926,7 +1967,6 @@ splash screen in another window." (insert "\n") (fancy-startup-tail concise)) (use-local-map splash-screen-keymap) - (setq-local browse-url-browser-function 'eww-browse-url) (setq tab-width 22 buffer-read-only t) (set-buffer-modified-p nil) @@ -1964,11 +2004,11 @@ splash screen in another window." (goto-char (point-min)) (force-mode-line-update)) (use-local-map splash-screen-keymap) - (setq-local browse-url-browser-function 'eww-browse-url) (setq tab-width 22) (setq buffer-read-only t) + ;; Place point somewhere it doesn't cover a character. (goto-char (point-min)) - (forward-line 3)))) + (re-search-forward "\n$" nil nil 2)))) (defun fancy-splash-frame () "Return the frame to use for the fancy splash screen. @@ -2121,8 +2161,11 @@ To quit a partially entered command, type Control-g.\n") 'follow-link t) (insert "\tChange initialization settings including this screen\n") - (insert "\n" (emacs-version) - "\n" emacs-copyright)) + (save-restriction + (narrow-to-region (point) (point)) + (insert "\n" (emacs-version) "\n") + (fill-region (point-min) (point-max))) + (insert emacs-copyright)) (defun normal-no-mouse-startup-screen () "Show a splash screen suitable for displays without mouse support." @@ -2202,7 +2245,11 @@ If you have no Meta key, you may instead type ESC followed by the character.)")) (startup--get-buffer-create-scratch))) 'follow-link t) (insert "\n") - (insert "\n" (emacs-version) "\n" emacs-copyright "\n") + (save-restriction + (narrow-to-region (point) (point)) + (insert "\n" (emacs-version) "\n") + (fill-region (point-min) (point-max))) + (insert emacs-copyright "\n") (insert (substitute-command-keys " GNU Emacs comes with ABSOLUTELY NO WARRANTY; type \\[describe-no-warranty] for ")) @@ -2242,7 +2289,9 @@ Type \\[describe-distribution] for information on ")) (insert "\tHow to report bugs and contribute improvements to Emacs\n\n") (insert-button "GNU and Freedom" - 'action (lambda (_button) (describe-gnu-project)) + 'action (lambda (_button) + (let ((browse-url-browser-function 'eww-browse-url)) + (describe-gnu-project))) 'follow-link t) (insert "\t\tWhy we developed GNU Emacs and the GNU system\n") @@ -2383,6 +2432,7 @@ A fancy display is used on graphic displays, normal otherwise." ;; and long versions of what's on command-switch-alist. (longopts (append '("--funcall" "--load" "--insert" "--kill" + "--dump-file" "--seccomp" "--directory" "--eval" "--execute" "--no-splash" "--find-file" "--visit" "--file" "--no-desktop") (mapcar (lambda (elt) (concat "-" (car elt))) @@ -2526,7 +2576,15 @@ nil default-directory" name) (let* ((file (command-line-normalize-file-name (or argval (pop command-line-args-left)))) ;; Take file from default dir. - (file-ex (file-truename (expand-file-name file)))) + (file-ex (expand-file-name file)) + (truename (file-truename file-ex))) + ;; We want to use the truename here if we can, + ;; because that makes `eval-after-load' work + ;; more reliably. But if the file is, for + ;; instance, /dev/stdin, the truename doesn't + ;; actually exist on some systems. + (when (file-exists-p truename) + (setq file-ex truename)) (load file-ex nil t t))) ((equal argi "-insert") @@ -2536,6 +2594,11 @@ nil default-directory" name) (error "File name omitted from `-insert' option")) (insert-file-contents (command-line-normalize-file-name tem))) + ((or (equal argi "-dump-file") + (equal argi "-seccomp")) + ;; This was processed in C. + (or argval (pop command-line-args-left))) + ((equal argi "-kill") (kill-emacs t)) diff --git a/lisp/strokes.el b/lisp/strokes.el index 91ddefd3738..db0eb83a3e6 100644 --- a/lisp/strokes.el +++ b/lisp/strokes.el @@ -1395,14 +1395,19 @@ Encode/decode your strokes with \\[strokes-encode-buffer], (strokes-load-user-strokes)) (add-hook 'kill-emacs-query-functions #'strokes-prompt-user-save-strokes) - (add-hook 'select-frame-hook - #'strokes-update-window-configuration) + ;; FIXME: Should this be something like `focus-in-hook'? + ;; That variable is obsolete, but `select-frame-hook' has + ;; never existed in Emacs. + ;;(add-hook 'select-frame-hook + ;; #'strokes-update-window-configuration) (strokes-update-window-configuration)) (t ; turn off strokes (if (get-buffer strokes-buffer-name) - (kill-buffer (get-buffer strokes-buffer-name))) - (remove-hook 'select-frame-hook - #'strokes-update-window-configuration)))) + (kill-buffer (get-buffer strokes-buffer-name))) + ;; FIXME: Same as above. + ;;(remove-hook 'select-frame-hook + ;; #'strokes-update-window-configuration) + ))) ;;;; strokes-xpm stuff (later may be separate)... diff --git a/lisp/subr.el b/lisp/subr.el index 8ff403e1139..9c07606100b 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -61,7 +61,8 @@ must be the first non-whitespace on a line. For more information, see Info node `(elisp)Declaring Functions'." (declare (advertised-calling-convention (fn file &optional arglist fileonly) nil)) - ;; Does nothing - byte-compile-declare-function does the work. + ;; Does nothing - `byte-compile-macroexpand-declare-function' does + ;; the work. nil) @@ -193,7 +194,7 @@ set earlier in the `setq-local'. The return value of the "Define VAR as a buffer-local variable with default value VAL. Like `defvar' but additionally marks the variable as being automatically buffer-local wherever it is set." - (declare (debug defvar) (doc-string 3)) + (declare (debug defvar) (doc-string 3) (indent 2)) ;; Can't use backquote here, it's too early in the bootstrap. (list 'progn (list 'defvar var val docstring) (list 'make-variable-buffer-local (list 'quote var)))) @@ -929,15 +930,29 @@ side-effects, and the argument LIST is not modified." "Convert KEYS to the internal Emacs key representation. KEYS should be a string in the format returned by commands such as `C-h k' (`describe-key'). + This is the same format used for saving keyboard macros (see `edmacro-mode'). +Here's some example key sequences: + + \"f\" + \"C-c C-c\" + \"H-<left>\" + \"M-RET\" + \"C-M-<return>\" + 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'. (declare (pure t) (side-effect-free t)) - ;; A pure function is expected to preserve the match data. - (save-match-data (read-kbd-macro keys))) + (let ((res (key-parse keys))) + (if (not (memq nil (mapcar (lambda (ch) + (and (numberp ch) + (<= 0 ch 127))) + res))) + ;; Return a string. + (concat (mapcar #'identity res)) + ;; Return a vector. + res))) (defun undefined () "Beep to tell the user this binding is undefined." @@ -988,6 +1003,9 @@ PARENT if non-nil should be a keymap." (defun define-key-after (keymap key definition &optional after) "Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding. +This is a legacy function; see `keymap-set-after' for the +recommended function to use instead. + This is like `define-key' except that the binding for KEY is placed just after the binding for the event AFTER, instead of at the beginning of the map. Note that AFTER must be an event type (like KEY), NOT a command @@ -1000,6 +1018,7 @@ Bindings are always added before any inherited map. The order of bindings in a keymap matters only when it is used as a menu, so this function is not useful for non-menu keymaps." + (declare (indent defun)) (unless after (setq after t)) (or (keymapp keymap) (signal 'wrong-type-argument (list 'keymapp keymap))) @@ -1157,6 +1176,9 @@ Subkeymaps may be modified but are not canonicalized." (defun keyboard-translate (from to) "Translate character FROM to TO on the current terminal. +This is a legacy function; see `keymap-translate' for the +recommended function to use instead. + This function creates a `keyboard-translate-table' if necessary and then modifies one entry in it." (or (char-table-p keyboard-translate-table) @@ -1168,6 +1190,9 @@ and then modifies one entry in it." (defun global-set-key (key command) "Give KEY a global binding as COMMAND. +This is a legacy function; see `keymap-global-set' for the +recommended function to use instead. + COMMAND is the command definition to use; usually it is a symbol naming an interactively-callable function. KEY is a key sequence; noninteractively, it is a string or vector @@ -1189,6 +1214,9 @@ that you make with this function." (defun local-set-key (key command) "Give KEY a local binding as COMMAND. +This is a legacy function; see `keymap-local-set' for the +recommended function to use instead. + COMMAND is the command definition to use; usually it is a symbol naming an interactively-callable function. KEY is a key sequence; noninteractively, it is a string or vector @@ -1207,12 +1235,18 @@ cases is shared with all other buffers in the same major mode." (defun global-unset-key (key) "Remove global binding of KEY. +This is a legacy function; see `keymap-global-unset' for the +recommended function to use instead. + KEY is a string or vector representing a sequence of keystrokes." (interactive "kUnset key globally: ") (global-set-key key nil)) (defun local-unset-key (key) "Remove local binding of KEY. +This is a legacy function; see `keymap-local-unset' for the +recommended function to use instead. + KEY is a string or vector representing a sequence of keystrokes." (interactive "kUnset key locally: ") (if (current-local-map) @@ -1221,6 +1255,9 @@ KEY is a string or vector representing a sequence of keystrokes." (defun local-key-binding (keys &optional accept-default) "Return the binding for command KEYS in current local keymap only. +This is a legacy function; see `keymap-local-binding' for the +recommended function to use instead. + KEYS is a string or vector, a sequence of keystrokes. The binding is probably a symbol with a function definition. @@ -1232,6 +1269,9 @@ about this." (defun global-key-binding (keys &optional accept-default) "Return the binding for command KEYS in current global keymap only. +This is a legacy function; see `keymap-global-binding' for the +recommended function to use instead. + KEYS is a string or vector, a sequence of keystrokes. The binding is probably a symbol with a function definition. This function's return values are the same as those of `lookup-key' @@ -1250,6 +1290,9 @@ about this." (defun substitute-key-definition (olddef newdef keymap &optional oldmap prefix) "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF. +This is a legacy function; see `keymap-substitute' for the +recommended function to use instead. + In other words, OLDDEF is replaced with NEWDEF wherever it appears. Alternatively, if optional fourth argument OLDMAP is specified, we redefine in KEYMAP as NEWDEF those keys that are defined as OLDDEF in OLDMAP. @@ -1511,22 +1554,22 @@ nil or (STRING . POSITION)'. `posn-timestamp': The time the event occurred, in milliseconds. For more information, see Info node `(elisp)Click Events'." - (if (consp event) (nth 1 event) - ;; Use `window-point' for the case when the current buffer - ;; is temporarily switched to some other buffer (bug#50256) - (or (posn-at-point (window-point)) - (list (selected-window) (window-point) '(0 . 0) 0)))) + (or (and (consp event) (nth 1 event)) + ;; Use `window-point' for the case when the current buffer + ;; is temporarily switched to some other buffer (bug#50256) + (posn-at-point (window-point)) + (list (selected-window) (window-point) '(0 . 0) 0))) (defun event-end (event) "Return the ending position of EVENT. EVENT should be a click, drag, or key press event. See `event-start' for a description of the value returned." - (if (consp event) (nth (if (consp (nth 2 event)) 2 1) event) - ;; Use `window-point' for the case when the current buffer - ;; is temporarily switched to some other buffer (bug#50256) - (or (posn-at-point (window-point)) - (list (selected-window) (window-point) '(0 . 0) 0)))) + (or (and (consp event) (nth (if (consp (nth 2 event)) 2 1) event)) + ;; Use `window-point' for the case when the current buffer + ;; is temporarily switched to some other buffer (bug#50256) + (posn-at-point (window-point)) + (list (selected-window) (window-point) '(0 . 0) 0))) (defsubst event-click-count (event) "Return the multi-click count of EVENT, a click or drag event. @@ -1752,6 +1795,7 @@ be a list of the form returned by `event-start' and `event-end'." (make-obsolete 'window-redisplay-end-trigger nil "23.1") (make-obsolete 'set-window-redisplay-end-trigger nil "23.1") (make-obsolete-variable 'operating-system-release nil "28.1") +(make-obsolete-variable 'inhibit-changing-match-data 'save-match-data "29.1") (make-obsolete 'run-window-configuration-change-hook nil "27.1") @@ -1868,7 +1912,7 @@ performance impact when running `add-hook' and `remove-hook'." (when (or (get hook 'hook--depth-alist) (not (zerop depth))) ;; Note: The main purpose of the above `when' test is to avoid running ;; this `setf' before `gv' is loaded during bootstrap. - (push (cons function depth) (get hook 'hook--depth-alist))) + (setf (alist-get function (get hook 'hook--depth-alist) 0) depth)) (setq hook-value (if (< 0 depth) (append hook-value (list function)) @@ -3077,7 +3121,7 @@ Optional argument CHARS, if non-nil, should be a list of characters; the function will ignore any input that is not one of CHARS. Optional argument HISTORY, if non-nil, should be a symbol that specifies the history list variable to use for navigating in input -history using `M-p' and `M-n', with `RET' to select a character from +history using \\`M-p' and \\`M-n', with \\`RET' to select a character from history. If you bind the variable `help-form' to a non-nil value while calling this function, then pressing `help-char' @@ -3368,6 +3412,29 @@ user can undo the change normally." (accept-change-group ,handle) (cancel-change-group ,handle)))))) +(defmacro with-undo-amalgamate (&rest body) + "Like `progn' but perform BODY with amalgamated undo barriers. + +This allows multiple operations to be undone in a single step. +When undo is disabled this behaves like `progn'." + (declare (indent 0) (debug t)) + (let ((handle (make-symbol "--change-group-handle--"))) + `(let ((,handle (prepare-change-group)) + ;; Don't truncate any undo data in the middle of this, + ;; otherwise Emacs might truncate part of the resulting + ;; undo step: we want to mimic the behavior we'd get if the + ;; undo-boundaries were never added in the first place. + (undo-outer-limit nil) + (undo-limit most-positive-fixnum) + (undo-strong-limit most-positive-fixnum)) + (unwind-protect + (progn + (activate-change-group ,handle) + ,@body) + (progn + (accept-change-group ,handle) + (undo-amalgamate-change-group ,handle)))))) + (defun prepare-change-group (&optional buffer) "Return a handle for the current buffer's state, for a change group. If you specify BUFFER, make a handle for BUFFER's state instead. @@ -3567,6 +3634,9 @@ If either NAME or VAL are specified, both should be specified." (defvar suspend-resume-hook nil "Normal hook run by `suspend-emacs', after Emacs is continued.") +(defvar after-pdump-load-hook nil + "Normal hook run after loading the .pdmp file.") + (defvar temp-buffer-show-hook nil "Normal hook run by `with-output-to-temp-buffer' after displaying the buffer. When the hook runs, the temporary buffer is current, and the window it @@ -3987,7 +4057,7 @@ BUFFER is the buffer (or buffer name) to associate with the process. Process output goes at end of that buffer, unless you specify an output stream or filter function to handle the output. BUFFER may be also nil, meaning that this process is not associated - with any buffer + with any buffer. COMMAND is the shell command to run." ;; We used to use `exec' to replace the shell with the command, ;; but that failed to handle (...) and semicolon, etc. @@ -4386,11 +4456,6 @@ is allowed once again. (Immediately, if `inhibit-quit' is nil.)" ;; that intends to handle the quit signal next time. (eval '(ignore nil))))) -;; Don't throw `throw-on-input' on those events by default. -(setq while-no-input-ignore-events - '(focus-in focus-out help-echo iconify-frame - make-frame-visible selection-request)) - (defmacro while-no-input (&rest body) "Execute BODY only as long as there's no pending input. If input arrives, that ends the execution of BODY, @@ -4763,14 +4828,12 @@ wherever possible, since it is slow." (defsubst looking-at-p (regexp) "\ Same as `looking-at' except this function does not change the match data." - (let ((inhibit-changing-match-data t)) - (looking-at regexp))) + (looking-at regexp t)) (defsubst string-match-p (regexp string &optional start) "\ Same as `string-match' except this function does not change the match data." - (let ((inhibit-changing-match-data t)) - (string-match regexp string start))) + (string-match regexp string start t)) (defun subregexp-context-p (regexp pos &optional start) "Return non-nil if POS is in a normal subregexp context in REGEXP. @@ -5575,6 +5638,7 @@ If HOOKVAR is nil, `mail-send-hook' is used. The properties used on SYMBOL are `composefunc', `sendfunc', `abortfunc', and `hookvar'." + (declare (indent defun)) (put symbol 'composefunc composefunc) (put symbol 'sendfunc sendfunc) (put symbol 'abortfunc (or abortfunc #'kill-buffer)) @@ -6462,4 +6526,145 @@ not a list, return a one-element list containing OBJECT." object (list object))) +(defun define-keymap--compile (form &rest args) + ;; This compiler macro is only there for compile-time + ;; error-checking; it does not change the call in any way. + (while (and args + (keywordp (car args)) + (not (eq (car args) :menu))) + (unless (memq (car args) '(:full :keymap :parent :suppress :name :prefix)) + (byte-compile-warn "Invalid keyword: %s" (car args))) + (setq args (cdr args)) + (when (null args) + (byte-compile-warn "Uneven number of keywords in %S" form)) + (setq args (cdr args))) + ;; Bindings. + (while args + (let ((key (pop args))) + (when (and (stringp key) (not (key-valid-p key))) + (byte-compile-warn "Invalid `kbd' syntax: %S" key))) + (when (null args) + (byte-compile-warn "Uneven number of key bindings in %S" form)) + (setq args (cdr args))) + form) + +(defun define-keymap (&rest definitions) + "Create a new keymap and define KEY/DEFEFINITION pairs as key sequences. +The new keymap is returned. + +Options can be given as keywords before the KEY/DEFEFINITION +pairs. Available keywords are: + +:full If non-nil, create a chartable alist (see `make-keymap'). + If nil (i.e., the default), create a sparse keymap (see + `make-sparse-keymap'). + +:suppress If non-nil, the keymap will be suppressed (see `suppress-keymap'). + If `nodigits', treat digits like other chars. + +:parent If non-nil, this should be a keymap to use as the parent + (see `set-keymap-parent'). + +:keymap If non-nil, instead of creating a new keymap, the given keymap + will be destructively modified instead. + +:name If non-nil, this should be a string to use as the menu for + the keymap in case you use it as a menu with `x-popup-menu'. + +:prefix If non-nil, this should be a symbol to be used as a prefix + command (see `define-prefix-command'). If this is the case, + this symbol is returned instead of the map itself. + +KEY/DEFINITION pairs are as KEY and DEF in `keymap-set'. KEY can +also be the special symbol `:menu', in which case DEFINITION +should be a MENU form as accepted by `easy-menu-define'. + +\(fn &key FULL PARENT SUPPRESS NAME PREFIX KEYMAP &rest [KEY DEFINITION]...)" + (declare (indent defun) + (compiler-macro define-keymap--compile)) + (let (full suppress parent name prefix keymap) + ;; Handle keywords. + (while (and definitions + (keywordp (car definitions)) + (not (eq (car definitions) :menu))) + (let ((keyword (pop definitions))) + (unless definitions + (error "Missing keyword value for %s" keyword)) + (let ((value (pop definitions))) + (pcase keyword + (:full (setq full value)) + (:keymap (setq keymap value)) + (:parent (setq parent value)) + (:suppress (setq suppress value)) + (:name (setq name value)) + (:prefix (setq prefix value)) + (_ (error "Invalid keyword: %s" keyword)))))) + + (when (and prefix + (or full parent suppress keymap)) + (error "A prefix keymap can't be defined with :full/:parent/:suppress/:keymap keywords")) + + (when (and keymap full) + (error "Invalid combination: :keymap with :full")) + + (let ((keymap (cond + (keymap keymap) + (prefix (define-prefix-command prefix nil name)) + (full (make-keymap name)) + (t (make-sparse-keymap name))))) + (when suppress + (suppress-keymap keymap (eq suppress 'nodigits))) + (when parent + (set-keymap-parent keymap parent)) + + ;; Do the bindings. + (while definitions + (let ((key (pop definitions))) + (unless definitions + (error "Uneven number of key/definition pairs")) + (let ((def (pop definitions))) + (if (eq key :menu) + (easy-menu-define nil keymap "" def) + (keymap-set keymap key def))))) + keymap))) + +(defmacro defvar-keymap (variable-name &rest defs) + "Define VARIABLE-NAME as a variable with a keymap definition. +See `define-keymap' for an explanation of the keywords and KEY/DEFINITION. + +In addition to the keywords accepted by `define-keymap', this +macro also accepts a `:doc' keyword, which (if present) is used +as the variable documentation string. + +\(fn VARIABLE-NAME &key DOC FULL PARENT SUPPRESS NAME PREFIX KEYMAP &rest [KEY DEFINITION]...)" + (declare (indent 1)) + (let ((opts nil) + doc) + (while (and defs + (keywordp (car defs)) + (not (eq (car defs) :menu))) + (let ((keyword (pop defs))) + (unless defs + (error "Uneven number of keywords")) + (if (eq keyword :doc) + (setq doc (pop defs)) + (push keyword opts) + (push (pop defs) opts)))) + (unless (zerop (% (length defs) 2)) + (error "Uneven number of key/definition pairs: %s" defs)) + `(defvar ,variable-name + (define-keymap ,@(nreverse opts) ,@defs) + ,@(and doc (list doc))))) + +(defmacro with-delayed-message (args &rest body) + "Like `progn', but display MESSAGE if BODY takes longer than TIMEOUT seconds. +The MESSAGE form will be evaluated immediately, but the resulting +string will be displayed only if BODY takes longer than TIMEOUT seconds. + +\(fn (timeout message) &rest body)" + (declare (indent 1)) + `(funcall-with-delayed-message ,(car args) ,(cadr args) + (lambda () + ,@body))) + ;;; subr.el ends here diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el index 68d28306dd9..07aa0f2d569 100644 --- a/lisp/tab-bar.el +++ b/lisp/tab-bar.el @@ -982,10 +982,11 @@ on the tab bar instead." (wc-point . ,(point-marker)) (wc-bl . ,bl) (wc-bbl . ,bbl) - (wc-history-back . ,(gethash (or frame (selected-frame)) - tab-bar-history-back)) - (wc-history-forward . ,(gethash (or frame (selected-frame)) - tab-bar-history-forward)) + ,@(when tab-bar-history-mode + `((wc-history-back . ,(gethash (or frame (selected-frame)) + tab-bar-history-back)) + (wc-history-forward . ,(gethash (or frame (selected-frame)) + tab-bar-history-forward)))) ;; Copy other possible parameters ,@(mapcan (lambda (param) (unless (memq (car param) @@ -1126,19 +1127,21 @@ Negative TAB-NUMBER counts tabs from the end of the tab bar." (when wc-bl (set-frame-parameter nil 'buffer-list wc-bl)) (when wc-bbl (set-frame-parameter nil 'buried-buffer-list wc-bbl)) - (puthash (selected-frame) - (and (window-configuration-p (alist-get 'wc (car wc-history-back))) - wc-history-back) - tab-bar-history-back) - (puthash (selected-frame) - (and (window-configuration-p (alist-get 'wc (car wc-history-forward))) - wc-history-forward) - tab-bar-history-forward))) + (when tab-bar-history-mode + (puthash (selected-frame) + (and (window-configuration-p (alist-get 'wc (car wc-history-back))) + wc-history-back) + tab-bar-history-back) + (puthash (selected-frame) + (and (window-configuration-p (alist-get 'wc (car wc-history-forward))) + wc-history-forward) + tab-bar-history-forward)))) (ws (window-state-put ws nil 'safe))) - (setq tab-bar-history-omit t) + (when tab-bar-history-mode + (setq tab-bar-history-omit t)) (when from-index (setf (nth from-index tabs) from-tab)) @@ -1193,7 +1196,9 @@ Interactively, ARG is the prefix numeric argument and defaults to 1." Default values are tab names sorted by recency, so you can use \ \\<minibuffer-local-map>\\[next-history-element] to get the name of the most recently visited tab, the second -most recent, and so on." +most recent, and so on. +When the tab with that NAME doesn't exist, create a new tab +and rename it to NAME." (interactive (let* ((recent-tabs (mapcar (lambda (tab) (alist-get 'name tab)) @@ -1201,7 +1206,11 @@ most recent, and so on." (list (completing-read (format-prompt "Switch to tab by name" (car recent-tabs)) recent-tabs nil nil nil nil recent-tabs)))) - (tab-bar-select-tab (1+ (or (tab-bar--tab-index-by-name name) 0)))) + (let ((tab-index (tab-bar--tab-index-by-name name))) + (if tab-index + (tab-bar-select-tab (1+ tab-index)) + (tab-bar-new-tab) + (tab-bar-rename-tab name)))) (defalias 'tab-bar-select-tab-by-name 'tab-bar-switch-to-tab) @@ -1388,6 +1397,11 @@ After the tab is created, the hooks in ;; `pushnew' handles the head of tabs but not frame-parameter (tab-bar-tabs-set tabs)) + (when tab-bar-history-mode + (puthash (selected-frame) nil tab-bar-history-back) + (puthash (selected-frame) nil tab-bar-history-forward) + (setq tab-bar-history-omit t)) + (run-hook-with-args 'tab-bar-tab-post-open-functions (nth to-index tabs))) @@ -1803,30 +1817,34 @@ Interactively, prompt for GROUP-NAME." (defvar tab-bar-history-old nil "Window configuration before the current command.") -(defvar tab-bar-history-old-minibuffer-depth 0 - "Minibuffer depth before the current command.") +(defvar tab-bar-history-pre-command nil + "Command set to `this-command' by `pre-command-hook'.") + +(defvar tab-bar-history-done-command nil + "Command handled by `window-configuration-change-hook'.") (defun tab-bar--history-pre-change () - (setq tab-bar-history-old-minibuffer-depth (minibuffer-depth)) - ;; Store window-configuration before possibly entering the minibuffer. - (when (zerop tab-bar-history-old-minibuffer-depth) + ;; Reset before the command could set it + (setq tab-bar-history-omit nil) + (setq tab-bar-history-pre-command this-command) + (when (zerop (minibuffer-depth)) (setq tab-bar-history-old `((wc . ,(current-window-configuration)) (wc-point . ,(point-marker)))))) (defun tab-bar--history-change () - (when (and (not tab-bar-history-omit) - tab-bar-history-old - ;; Store window-configuration before possibly entering - ;; the minibuffer. - (zerop tab-bar-history-old-minibuffer-depth)) + (when (and (not tab-bar-history-omit) tab-bar-history-old + ;; Don't register changes performed by the same command + ;; repeated in sequence, such as incremental window resizing. + (not (eq tab-bar-history-done-command tab-bar-history-pre-command)) + (zerop (minibuffer-depth))) (puthash (selected-frame) (seq-take (cons tab-bar-history-old (gethash (selected-frame) tab-bar-history-back)) tab-bar-history-limit) - tab-bar-history-back)) - (when tab-bar-history-omit - (setq tab-bar-history-omit nil))) + tab-bar-history-back) + (setq tab-bar-history-old nil)) + (setq tab-bar-history-done-command tab-bar-history-pre-command)) (defun tab-bar-history-back () "Restore a previous window configuration used in the current tab. diff --git a/lisp/tab-line.el b/lisp/tab-line.el index 5affae79138..af0647acf7c 100644 --- a/lisp/tab-line.el +++ b/lisp/tab-line.el @@ -792,7 +792,9 @@ Its effect is the same as using the `previous-buffer' command (if (eq tab-line-tabs-function #'tab-line-tabs-window-buffers) (switch-to-prev-buffer window) (with-selected-window (or window (selected-window)) - (let* ((tabs (funcall tab-line-tabs-function)) + (let* ((tabs (seq-filter + (lambda (tab) (or (bufferp tab) (assq 'buffer tab))) + (funcall tab-line-tabs-function))) (pos (seq-position tabs (current-buffer) (lambda (tab buffer) @@ -816,7 +818,9 @@ Its effect is the same as using the `next-buffer' command (if (eq tab-line-tabs-function #'tab-line-tabs-window-buffers) (switch-to-next-buffer window) (with-selected-window (or window (selected-window)) - (let* ((tabs (funcall tab-line-tabs-function)) + (let* ((tabs (seq-filter + (lambda (tab) (or (bufferp tab) (assq 'buffer tab))) + (funcall tab-line-tabs-function))) (pos (seq-position tabs (current-buffer) (lambda (tab buffer) @@ -893,7 +897,14 @@ sight of the tab line." (define-minor-mode tab-line-mode "Toggle display of tab line in the windows displaying the current buffer." :lighter nil - (setq tab-line-format (when tab-line-mode '(:eval (tab-line-format))))) + (let ((default-value '(:eval (tab-line-format)))) + (if tab-line-mode + ;; Preserve the existing tab-line set outside of this mode + (unless tab-line-format + (setq tab-line-format default-value)) + ;; Reset only values set by this mode + (when (equal tab-line-format default-value) + (setq tab-line-format nil))))) (defcustom tab-line-exclude-modes '(completion-list-mode) diff --git a/lisp/term.el b/lisp/term.el index e76eb77647f..698bef08b2d 100644 --- a/lisp/term.el +++ b/lisp/term.el @@ -303,6 +303,7 @@ (require 'ange-ftp) (require 'cl-lib)) (require 'comint) ; Password regexp. +(require 'ansi-color) (require 'ehelp) (require 'ring) (require 'shell) @@ -710,13 +711,20 @@ Buffer local variable.") (defvar term-ansi-at-save-pwd nil) (defvar term-ansi-at-save-anon nil) (defvar term-ansi-current-bold nil) +(defvar term-ansi-current-faint nil) +(defvar term-ansi-current-italic nil) +(defvar term-ansi-current-underline nil) +(defvar term-ansi-current-slow-blink nil) +(defvar term-ansi-current-fast-blink nil) (defvar term-ansi-current-color 0) (defvar term-ansi-face-already-done nil) (defvar term-ansi-current-bg-color 0) -(defvar term-ansi-current-underline nil) (defvar term-ansi-current-reverse nil) (defvar term-ansi-current-invisible nil) +(make-obsolete-variable 'term-ansi-face-already-done + "it doesn't have any effect." "29.1") + ;;; Faces (defvar ansi-term-color-vector [term @@ -765,12 +773,36 @@ Buffer local variable.") :group 'term :version "28.1") +(defface term-faint + '((t :inherit ansi-color-faint)) + "Default face to use for faint text." + :group 'term + :version "29.1") + +(defface term-italic + '((t :inherit ansi-color-italic)) + "Default face to use for italic text." + :group 'term + :version "29.1") + (defface term-underline '((t :inherit ansi-color-underline)) "Default face to use for underlined text." :group 'term :version "28.1") +(defface term-slow-blink + '((t :inherit ansi-color-slow-blink)) + "Default face to use for slowly blinking text." + :group 'term + :version "29.1") + +(defface term-fast-blink + '((t :inherit ansi-color-fast-blink)) + "Default face to use for rapidly blinking text." + :group 'term + :version "29.1") + (defface term-color-black '((t :inherit ansi-color-black)) "Face used to render black color code." @@ -1034,15 +1066,15 @@ is buffer-local." (defun term-ansi-reset () (setq term-current-face 'term) - (setq term-ansi-current-underline nil) (setq term-ansi-current-bold nil) + (setq term-ansi-current-faint nil) + (setq term-ansi-current-italic nil) + (setq term-ansi-current-underline nil) + (setq term-ansi-current-slow-blink nil) + (setq term-ansi-current-fast-blink nil) (setq term-ansi-current-reverse nil) (setq term-ansi-current-color 0) (setq term-ansi-current-invisible nil) - ;; Stefan thought this should be t, but could not remember why. - ;; Setting it to t seems to cause bug#11785. Setting it to nil - ;; again to see if there are other consequences... - (setq term-ansi-face-already-done nil) (setq term-ansi-current-bg-color 0)) (define-derived-mode term-mode fundamental-mode "Term" @@ -1499,7 +1531,6 @@ commands to use in that buffer. (getenv "ESHELL") shell-file-name)))) (set-buffer (make-term "terminal" program)) - (term-mode) (term-char-mode) (switch-to-buffer "*terminal*")) @@ -1581,10 +1612,12 @@ Using \"emacs\" loses, because bash disables editing if $TERM == emacs.") :nd=\\E[C:up=\\E[A:ce=\\E[K:ho=\\E[H:pt\ :al=\\E[L:dl=\\E[M:DL=\\E[%%dM:AL=\\E[%%dL:cs=\\E[%%i%%d;%%dr:sf=^J\ :dc=\\E[P:DC=\\E[%%dP:IC=\\E[%%d@:im=\\E[4h:ei=\\E[4l:mi:\ +:mb=\\E[5m:mh=\\E[2m:ZR=\\E[23m:ZH=\\E[3m\ :so=\\E[7m:se=\\E[m:us=\\E[4m:ue=\\E[m:md=\\E[1m:mr=\\E[7m:me=\\E[m\ :UP=\\E[%%dA:DO=\\E[%%dB:LE=\\E[%%dD:RI=\\E[%%dC\ :kl=\\EOD:kd=\\EOB:kr=\\EOC:ku=\\EOA:kN=\\E[6~:kP=\\E[5~:@7=\\E[4~:kh=\\E[1~\ -:mk=\\E[8m:cb=\\E[1K:op=\\E[39;49m:Co#8:pa#64:AB=\\E[4%%dm:AF=\\E[3%%dm:cr=^M\ +:mk=\\E[8m:cb=\\E[1K:op=\\E[39;49m:Co#256:pa#32767\ +:AB=\\E[48;5;%%dm:AF=\\E[38;5;%%dm:cr=^M\ :bl=^G:do=^J:le=^H:ta=^I:se=\\E[27m:ue=\\E[24m\ :kb=^?:kD=^[[3~:sc=\\E7:rc=\\E8:r1=\\Ec:" ;; : -undefine ic @@ -2375,7 +2408,14 @@ Checks if STRING contains a password prompt as defined by (when (term-in-line-mode) (when (let ((case-fold-search t)) (string-match comint-password-prompt-regexp string)) - (term-send-invisible (read-passwd string))))) + ;; Use `run-at-time' in order not to pause execution of the + ;; process filter with a minibuffer + (run-at-time + 0 nil + (lambda (current-buf) + (with-current-buffer current-buf + (term-send-invisible (read-passwd string)))) + (current-buffer))))) ;;; Low-level process communication @@ -3104,30 +3144,34 @@ See `term-prompt-regexp'." (term-horizontal-column) term-ansi-current-bg-color term-ansi-current-bold + term-ansi-current-faint + term-ansi-current-italic + term-ansi-current-underline + term-ansi-current-slow-blink + term-ansi-current-fast-blink term-ansi-current-color term-ansi-current-invisible term-ansi-current-reverse - term-ansi-current-underline term-current-face))) (?8 ;; Restore cursor (terminfo: rc, [ctlseqs] ;; "DECRC"). (when term-saved-cursor (term-goto (nth 0 term-saved-cursor) (nth 1 term-saved-cursor)) - (setq term-ansi-current-bg-color - (nth 2 term-saved-cursor) - term-ansi-current-bold - (nth 3 term-saved-cursor) - term-ansi-current-color - (nth 4 term-saved-cursor) - term-ansi-current-invisible - (nth 5 term-saved-cursor) - term-ansi-current-reverse - (nth 6 term-saved-cursor) - term-ansi-current-underline - (nth 7 term-saved-cursor) - term-current-face - (nth 8 term-saved-cursor)))) + (pcase-setq + `( ,_ ,_ + ,term-ansi-current-bg-color + ,term-ansi-current-bold + ,term-ansi-current-faint + ,term-ansi-current-italic + ,term-ansi-current-underline + ,term-ansi-current-slow-blink + ,term-ansi-current-fast-blink + ,term-ansi-current-color + ,term-ansi-current-invisible + ,term-ansi-current-reverse + ,term-current-face) + term-saved-cursor))) (?c ;; \Ec - Reset (terminfo: rs1, [ctlseqs] "RIS"). ;; This is used by the "clear" program. (term-reset-terminal)) @@ -3285,133 +3329,141 @@ option is enabled. See `term-set-goto-process-mark'." (setq term-current-row 0) (setq term-current-column 1) (term--reset-scroll-region) - (setq term-insert-mode nil) - ;; FIXME: No idea why this is here, it looks wrong. --Stef - (setq term-ansi-face-already-done nil)) - -(defun term--maybe-brighten-color (color bold) - "Possibly convert COLOR to its bright variant. -COLOR is an index into `ansi-term-color-vector'. If BOLD and -`ansi-color-bold-is-bright' are non-nil and COLOR is a regular color, -return the bright version of COLOR; otherwise, return COLOR." - (if (and ansi-color-bold-is-bright bold (<= 1 color 8)) - (+ color 8) - color)) + (setq term-insert-mode nil)) + +(defun term--color-as-hex (for-foreground) + "Return the current ANSI color as a hexadecimal color string. +Use the current background color if FOR-FOREGROUND is nil, +otherwise use the current foreground color." + (let ((color (if for-foreground term-ansi-current-color + term-ansi-current-bg-color))) + (or (ansi-color--code-as-hex (1- color)) + (progn + (and ansi-color-bold-is-bright term-ansi-current-bold + (<= 1 color 8) + (setq color (+ color 8))) + (if for-foreground + (face-foreground (elt ansi-term-color-vector color) + nil 'default) + (face-background (elt ansi-term-color-vector color) + nil 'default)))))) ;; New function to deal with ansi colorized output, as you can see you can ;; have any bold/underline/fg/bg/reverse combination. -mm (defun term-handle-colors-array (parameter) - (cond - - ;; Bold (terminfo: bold) - ((eq parameter 1) - (setq term-ansi-current-bold t)) - - ;; Underline - ((eq parameter 4) - (setq term-ansi-current-underline t)) - - ;; Blink (unsupported by Emacs), will be translated to bold. - ;; This may change in the future though. - ((eq parameter 5) - (setq term-ansi-current-bold t)) - - ;; Reverse (terminfo: smso) - ((eq parameter 7) - (setq term-ansi-current-reverse t)) - - ;; Invisible - ((eq parameter 8) - (setq term-ansi-current-invisible t)) - - ;; Reset underline (terminfo: rmul) - ((eq parameter 24) - (setq term-ansi-current-underline nil)) - - ;; Reset reverse (terminfo: rmso) - ((eq parameter 27) - (setq term-ansi-current-reverse nil)) - - ;; Foreground - ((and (>= parameter 30) (<= parameter 37)) - (setq term-ansi-current-color (- parameter 29))) - - ;; Bright foreground - ((and (>= parameter 90) (<= parameter 97)) - (setq term-ansi-current-color (- parameter 81))) - - ;; Reset foreground - ((eq parameter 39) - (setq term-ansi-current-color 0)) - - ;; Background - ((and (>= parameter 40) (<= parameter 47)) - (setq term-ansi-current-bg-color (- parameter 39))) - - ;; Bright foreground - ((and (>= parameter 100) (<= parameter 107)) - (setq term-ansi-current-bg-color (- parameter 91))) - - ;; Reset background - ((eq parameter 49) - (setq term-ansi-current-bg-color 0)) - - ;; 0 (Reset) or unknown (reset anyway) - (t - (term-ansi-reset))) - - ;; (message "Debug: U-%d R-%d B-%d I-%d D-%d F-%d B-%d" - ;; term-ansi-current-underline - ;; term-ansi-current-reverse - ;; term-ansi-current-bold - ;; term-ansi-current-invisible - ;; term-ansi-face-already-done - ;; term-ansi-current-color - ;; term-ansi-current-bg-color) - - (unless term-ansi-face-already-done - (let ((current-color (term--maybe-brighten-color - term-ansi-current-color - term-ansi-current-bold)) - (current-bg-color (term--maybe-brighten-color - term-ansi-current-bg-color - term-ansi-current-bold))) - (if term-ansi-current-invisible - (let ((color - (if term-ansi-current-reverse - (face-foreground - (elt ansi-term-color-vector current-color) - nil 'default) - (face-background - (elt ansi-term-color-vector current-bg-color) - nil 'default)))) - (setq term-current-face - (list :background color - :foreground color)) - ) ;; No need to bother with anything else if it's invisible. - (setq term-current-face - (list :foreground - (face-foreground - (elt ansi-term-color-vector current-color) - nil 'default) - :background - (face-background - (elt ansi-term-color-vector current-bg-color) - nil 'default) - :inverse-video term-ansi-current-reverse)) - - (when term-ansi-current-bold - (setq term-current-face - `(,term-current-face :inherit term-bold))) - - (when term-ansi-current-underline - (setq term-current-face - `(,term-current-face :inherit term-underline)))))) - - ;; (message "Debug %S" term-current-face) - ;; FIXME: shouldn't we set term-ansi-face-already-done to t here? --Stef - (setq term-ansi-face-already-done nil)) + (declare (obsolete term--handle-colors-list "29.1")) + (term--handle-colors-list (list parameter))) + +(defun term--handle-colors-list (parameters) + (while parameters + (pcase (pop parameters) + (1 (setq term-ansi-current-bold t)) ; (terminfo: bold) + (2 (setq term-ansi-current-faint t)) ; (terminfo: dim) + (3 (setq term-ansi-current-italic t)) ; (terminfo: sitm) + (4 (setq term-ansi-current-underline t)) ; (terminfo: smul) + (5 (setq term-ansi-current-slow-blink t)) ; (terminfo: blink) + (6 (setq term-ansi-current-fast-blink t)) + (7 (setq term-ansi-current-reverse t)) ; (terminfo: smso, rev) + (8 (setq term-ansi-current-invisible t)) ; (terminfo: invis) + (21 (setq term-ansi-current-bold nil)) + (22 (setq term-ansi-current-bold nil) + (setq term-ansi-current-faint nil)) + (23 (setq term-ansi-current-italic nil)) ; (terminfo: ritm) + (24 (setq term-ansi-current-underline nil)) ; (terminfo: rmul) + (25 (setq term-ansi-current-slow-blink nil) + (setq term-ansi-current-fast-blink nil)) + (27 (setq term-ansi-current-reverse nil)) ; (terminfo: rmso) + + ;; Foreground (terminfo: setaf) + ((and param (guard (<= 30 param 37))) + (setq term-ansi-current-color (- param 29))) + + ;; Bright foreground (terminfo: setaf) + ((and param (guard (<= 90 param 97))) + (setq term-ansi-current-color (- param 81))) + + ;; Extended foreground (terminfo: setaf) + (38 + (pcase (pop parameters) + ;; 256 color + (5 (if (setq term-ansi-current-color (pop parameters)) + (cl-incf term-ansi-current-color) + (term-ansi-reset))) + ;; Full 24-bit color + (2 (cl-loop with color = (1+ 256) ; Base + for i from 16 downto 0 by 8 + if (pop parameters) + do (setq color (+ color (ash it i))) + else return (term-ansi-reset) + finally + (if (> color (+ 1 256 #xFFFFFF)) + (term-ansi-reset) + (setq term-ansi-current-color color)))) + (_ (term-ansi-reset)))) + + ;; Reset foreground (terminfo: op) + (39 (setq term-ansi-current-color 0)) + + ;; Background (terminfo: setab) + ((and param (guard (<= 40 param 47))) + (setq term-ansi-current-bg-color (- param 39))) + + ;; Bright background (terminfo: setab) + ((and param (guard (<= 100 param 107))) + (setq term-ansi-current-bg-color (- param 91))) + + ;; Extended background (terminfo: setab) + (48 + (pcase (pop parameters) + ;; 256 color + (5 (if (setq term-ansi-current-bg-color (pop parameters)) + (cl-incf term-ansi-current-bg-color) + (term-ansi-reset))) + ;; Full 24-bit color + (2 (cl-loop with color = (1+ 256) ; Base + for i from 16 downto 0 by 8 + if (pop parameters) + do (setq color (+ color (ash it i))) + else return (term-ansi-reset) + finally + (if (> color (+ 1 256 #xFFFFFF)) + (term-ansi-reset) + (setq term-ansi-current-bg-color color)))) + (_ (term-ansi-reset)))) + + ;; Reset background (terminfo: op) + (49 (setq term-ansi-current-bg-color 0)) + + ;; 0 (Reset) (terminfo: sgr0) or unknown (reset anyway) + (_ (term-ansi-reset)))) + + (let (fg bg) + (if term-ansi-current-invisible + (setq bg (term--color-as-hex term-ansi-current-reverse) + fg bg) + (setq fg (term--color-as-hex t) + bg (term--color-as-hex nil))) + (setq term-current-face + `( :foreground ,fg + :background ,bg + ,@(unless term-ansi-current-invisible + (list :inverse-video term-ansi-current-reverse))))) + + (setq term-current-face + `(,term-current-face + ,@(when term-ansi-current-bold + '(term-bold)) + ,@(when term-ansi-current-faint + '(term-faint)) + ,@(when term-ansi-current-italic + '(term-italic)) + ,@(when term-ansi-current-underline + '(term-underline)) + ,@(when term-ansi-current-slow-blink + '(term-slow-blink)) + ,@(when term-ansi-current-fast-blink + '(term-fast-blink))))) ;; Handle a character assuming (eq terminal-state 2) - @@ -3497,9 +3549,9 @@ return the bright version of COLOR; otherwise, return COLOR." ;; Modified to allow ansi coloring -mm ;; \E[m - Set/reset modes, set bg/fg - ;;(terminfo: smso,rmso,smul,rmul,rev,bold,sgr0,invis,op,setab,setaf) + ;;(terminfo: smso,rmso,smul,rmul,rev,bold,dim,sitm,ritm,blink,sgr0,invis,op,setab,setaf) ((eq char ?m) - (mapc #'term-handle-colors-array params)) + (term--handle-colors-list params)) ;; \E[6n - Report cursor position (terminfo: u7) ((eq char ?n) diff --git a/lisp/term/haiku-win.el b/lisp/term/haiku-win.el new file mode 100644 index 00000000000..3c4d00f7f99 --- /dev/null +++ b/lisp/term/haiku-win.el @@ -0,0 +1,139 @@ +;;; haiku-win.el --- set up windowing on Haiku -*- lexical-binding: t -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Support for using Haiku's BeOS derived windowing system. + +;;; Code: + +(eval-when-compile (require 'cl-lib)) +(unless (featurep 'haiku) + (error "%s: Loading haiku-win without having Haiku" + invocation-name)) + +;; Documentation-purposes only: actually loaded in loadup.el. +(require 'frame) +(require 'mouse) +(require 'scroll-bar) +(require 'menu-bar) +(require 'fontset) +(require 'dnd) + +(add-to-list 'display-format-alist '(".*" . haiku-win)) + +;;;; Command line argument handling. + +(defvar x-invocation-args) +(defvar x-command-line-resources) + +(defvar haiku-initialized) + +(declare-function x-open-connection "haikufns.c") +(declare-function x-handle-args "common-win") +(declare-function haiku-selection-data "haikuselect.c") +(declare-function haiku-selection-put "haikuselect.c") +(declare-function haiku-selection-targets "haikuselect.c") +(declare-function haiku-put-resource "haikufns.c") + +(defun haiku--handle-x-command-line-resources (command-line-resources) + "Handle command line X resources specified with the option `-xrm'. +The resources should be a list of strings in COMMAND-LINE-RESOURCES." + (dolist (s command-line-resources) + (let ((components (split-string s ":"))) + (when (car components) + (haiku-put-resource (car components) + (string-trim-left + (mapconcat #'identity (cdr components) ":"))))))) + +(cl-defmethod window-system-initialization (&context (window-system haiku) + &optional display) + "Set up the window system. WINDOW-SYSTEM must be HAIKU. +DISPLAY may be set to the name of a display that will be initialized." + (cl-assert (not haiku-initialized)) + + (create-default-fontset) + (when x-command-line-resources + (haiku--handle-x-command-line-resources + (split-string x-command-line-resources "\n"))) + (x-open-connection (or display "be") x-command-line-resources t) + (setq haiku-initialized t)) + +(cl-defmethod frame-creation-function (params &context (window-system haiku)) + (x-create-frame-with-faces params)) + +(cl-defmethod handle-args-function (args &context (window-system haiku)) + (x-handle-args args)) + +(defun haiku--selection-type-to-mime (type) + "Convert symbolic selection type TYPE to its MIME equivalent. +If TYPE is nil, return \"text/plain\"." + (cond + ((memq type '(TEXT COMPOUND_TEXT STRING UTF8_STRING)) "text/plain") + ((stringp type) type) + ((symbolp type) (symbol-name type)) + (t "text/plain"))) + +(cl-defmethod gui-backend-get-selection (type data-type + &context (window-system haiku)) + (if (eq data-type 'TARGETS) + (apply #'vector (mapcar #'intern + (haiku-selection-targets type))) + (haiku-selection-data type (haiku--selection-type-to-mime data-type)))) + +(cl-defmethod gui-backend-set-selection (type value + &context (window-system haiku)) + (haiku-selection-put type "text/plain" value t)) + +(cl-defmethod gui-backend-selection-exists-p (selection + &context (window-system haiku)) + (haiku-selection-data selection "text/plain")) + +(cl-defmethod gui-backend-selection-owner-p (_ + &context (window-system haiku)) + t) + +(declare-function haiku-read-file-name "haikufns.c") + +(defun x-file-dialog (prompt dir default_filename mustmatch only_dir_p) + "SKIP: real doc in xfns.c." + (if (eq (framep-on-display (selected-frame)) 'haiku) + (haiku-read-file-name prompt (selected-frame) + (or dir (and default_filename + (file-name-directory default_filename))) + mustmatch only_dir_p + (file-name-nondirectory default_filename)) + (error "x-file-dialog on a tty frame"))) + +(defun haiku-dnd-handle-drag-n-drop-event (event) + "Handle specified drag-n-drop EVENT." + (interactive "e") + (let* ((string (caddr event)) + (window (posn-window (event-start event)))) + (with-selected-window window + (raise-frame) + (dnd-handle-one-url window 'private (concat "file:" string))))) + +(define-key special-event-map [drag-n-drop] + 'haiku-dnd-handle-drag-n-drop-event) + +(provide 'haiku-win) +(provide 'term/haiku-win) + +;;; haiku-win.el ends here diff --git a/lisp/term/ns-win.el b/lisp/term/ns-win.el index 1a3811a37c2..67a417c1161 100644 --- a/lisp/term/ns-win.el +++ b/lisp/term/ns-win.el @@ -867,10 +867,10 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.") ;; For Darwin nothing except UTF-8 makes sense. (when (eq system-type 'darwin) (add-hook 'before-init-hook - #'(lambda () - (setq locale-coding-system 'utf-8-unix) - (setq default-process-coding-system - '(utf-8-unix . utf-8-unix))))) + (lambda () + (setq locale-coding-system 'utf-8-unix) + (setq default-process-coding-system + '(utf-8-unix . utf-8-unix))))) ;; Mac OS X Lion introduces PressAndHold, which is unsupported by this port. ;; See this thread for more details: diff --git a/lisp/term/w32-win.el b/lisp/term/w32-win.el index 5d1dc606676..0ee010b6c87 100644 --- a/lisp/term/w32-win.el +++ b/lisp/term/w32-win.el @@ -274,6 +274,8 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.") '(gif "libgif-6.dll" "giflib5.dll" "gif.dll") '(gif "libgif-5.dll" "giflib4.dll" "libungif4.dll" "libungif.dll"))) '(svg "librsvg-2-2.dll") + '(webp "libwebp-7.dll" "libwebp.dll") + '(sqlite3 "libsqlite3-0.dll") '(gdk-pixbuf "libgdk_pixbuf-2.0-0.dll") '(glib "libglib-2.0-0.dll") '(gio "libgio-2.0-0.dll") diff --git a/lisp/textmodes/artist.el b/lisp/textmodes/artist.el index c42286e5bc3..25f0c35aa5d 100644 --- a/lisp/textmodes/artist.el +++ b/lisp/textmodes/artist.el @@ -2840,9 +2840,8 @@ Returns a list of strings." (if (memq system-type '(windows-nt ms-dos)) (artist-figlet-get-font-list-windows) (artist-figlet-get-font-list))) - (font (completing-read (concat "Select font (default " - artist-figlet-default-font - "): ") + (font (completing-read (format-prompt "Select font" + artist-figlet-default-font) (mapcar (lambda (font) (cons font font)) avail-fonts)))) diff --git a/lisp/textmodes/bibtex.el b/lisp/textmodes/bibtex.el index 237a1d99353..2dd4e8e7af0 100644 --- a/lisp/textmodes/bibtex.el +++ b/lisp/textmodes/bibtex.el @@ -839,6 +839,24 @@ for a new entry." ("eprint") ("eprintclass" nil nil 4) ("primaryclass" nil nil -4) ("eprinttype" nil nil 5) ("archiveprefix" nil nil -5) ("url") ("urldate"))) + ("PhdThesis" "PhD Thesis" + (("author") + ("title" "Title of the PhD thesis") + ("school" "School where the PhD thesis was written") + ("year")) + nil + (("type" "Type of the PhD thesis") + ("address" "Address of the school (if not part of field \"school\") or country") + ("month") ("note"))) + ("TechReport" "Technical Report" + (("author") + ("title" "Title of the technical report (BibTeX converts it to lowercase)") + ("institution" "Sponsoring institution of the report") + ("year")) + nil + (("type" "Type of the report (if other than \"technical report\")") + ("number" "Number of the technical report") + ("address") ("month") ("note"))) ("Unpublished" "Unpublished" (("author") ("title") ("date" nil nil 1) ("year" nil nil -1)) nil @@ -4317,8 +4335,6 @@ for a crossref key, t otherwise." (eqb (goto-char pos)) (t (set-buffer buffer) (goto-char pos))) pos)) -;; backward compatibility -(defalias 'bibtex-find-crossref 'bibtex-search-crossref) (defun bibtex-dist (pos beg end) "Return distance between POS and region delimited by BEG and END." @@ -4381,8 +4397,6 @@ A prefix arg negates the value of `bibtex-search-entry-globally'." (if display (bibtex-reposition-window))) (display (message "Key `%s' not found" key))) pnt))) -;; backward compatibility -(defalias 'bibtex-find-entry 'bibtex-search-entry) (defun bibtex-prepare-new-entry (index) "Prepare a new BibTeX entry with index INDEX. @@ -5608,5 +5622,8 @@ If APPEND is non-nil, append ENTRIES to those already displayed." (setq buffer-read-only t) (goto-char (point-min))) +(define-obsolete-function-alias 'bibtex-find-crossref #'bibtex-search-crossref "29.1") +(define-obsolete-function-alias 'bibtex-find-entry #'bibtex-search-entry "29.1") + (provide 'bibtex) ;;; bibtex.el ends here diff --git a/lisp/textmodes/etc-authors-mode.el b/lisp/textmodes/etc-authors-mode.el index 8b5fefd3b7d..a79a1ecf4bb 100644 --- a/lisp/textmodes/etc-authors-mode.el +++ b/lisp/textmodes/etc-authors-mode.el @@ -115,12 +115,10 @@ With a prefix arg ARG, move point that many authors backward." (interactive "p" etc-authors-mode) (etc-authors-next-author (- arg))) -(defvar etc-authors-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "n" #'etc-authors-next-author) - (define-key map "p" #'etc-authors-prev-author) - map) - "Keymap for `etc-authors-mode'.") +(defvar-keymap etc-authors-mode-map + :doc "Keymap for `etc-authors-mode'." + "n" #'etc-authors-next-author + "p" #'etc-authors-prev-author) ;;;###autoload (define-derived-mode etc-authors-mode special-mode "Authors View" diff --git a/lisp/textmodes/fill.el b/lisp/textmodes/fill.el index decce88573b..4e161099cd6 100644 --- a/lisp/textmodes/fill.el +++ b/lisp/textmodes/fill.el @@ -396,12 +396,8 @@ and `fill-nobreak-invisible'." (save-excursion (skip-chars-backward " ") (and (eq (preceding-char) ?.) - (looking-at " \\([^ ]\\|$\\)")))) - ;; Another approach to the same problem. - (save-excursion - (skip-chars-backward " ") - (and (eq (preceding-char) ?.) - (not (progn (forward-char -1) (looking-at (sentence-end)))))) + ;; There's something more after the space. + (looking-at " [^ \n]")))) ;; Don't split a line if the rest would look like a new paragraph. (unless use-hard-newlines (save-excursion @@ -709,7 +705,10 @@ space does not end a sentence, so don't break a line there." (goto-char from-plus-indent)) (if (not (> to (point))) - nil ;; There is no paragraph, only whitespace: exit now. + ;; There is no paragraph, only whitespace: exit now. + (progn + (set-marker to nil) + nil) (or justify (setq justify (current-justification))) @@ -795,6 +794,7 @@ space does not end a sentence, so don't break a line there." ;; Leave point after final newline. (goto-char to) (unless (eobp) (forward-char 1)) + (set-marker to nil) ;; Return the fill-prefix we used fill-prefix))) diff --git a/lisp/textmodes/flyspell.el b/lisp/textmodes/flyspell.el index 258e5fde674..2a9cae29f79 100644 --- a/lisp/textmodes/flyspell.el +++ b/lisp/textmodes/flyspell.el @@ -2270,17 +2270,8 @@ If OPOINT is non-nil, restore point there after adjusting it for replacement." ;;*---------------------------------------------------------------------*/ (defun flyspell-emacs-popup (event poss word) "The Emacs popup menu." - (if (and (not event) - (display-mouse-p)) - (let* ((mouse-pos (mouse-position)) - (mouse-pos (if (nth 1 mouse-pos) - mouse-pos - (set-mouse-position (car mouse-pos) - (/ (frame-width) 2) 2) - (mouse-position)))) - (setq event (list (list (car (cdr mouse-pos)) - (1+ (cdr (cdr mouse-pos)))) - (car mouse-pos))))) + (unless event + (setq event (popup-menu-normalize-position (point)))) (let* ((corrects (flyspell-sort (car (cdr (cdr poss))) word)) (cor-menu (if (consp corrects) (mapcar (lambda (correct) diff --git a/lisp/textmodes/glyphless-mode.el b/lisp/textmodes/glyphless-mode.el new file mode 100644 index 00000000000..177ba42c9c8 --- /dev/null +++ b/lisp/textmodes/glyphless-mode.el @@ -0,0 +1,68 @@ +;;; glyphless-mode.el --- minor mode for displaying glyphless characters -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; 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: + +;;; Code: + +(defcustom glyphless-mode-types '(all) + "Which glyphless characters to display. +The value can be any of the groups supported by +`glyphless-char-display-control' (which see), and in addition +`all', for all glyphless characters." + :version "29.1" + :type '(repeat (choice (const :tag "All" all) + (const :tag "No font" no-font) + (const :tag "C0 Control" c0-control) + (const :tag "C1 Control" c1-control) + (const :tag "Format Control" format-control) + (const :tag "Bidirectional Control" bidi-control) + (const :tag "Variation Selectors" variation-selectors) + (const :tag "No Font" no-font))) + :group 'display) + +;;;###autoload +(define-minor-mode glyphless-display-mode + "Minor mode for displaying glyphless characters in the current buffer. +If enabled, all glyphless characters will be displayed as boxes +that display their acronyms." + :lighter " Glyphless" + (if glyphless-display-mode + (progn + (setq-local glyphless-char-display + (let ((table (make-display-table))) + (set-char-table-parent table glyphless-char-display) + table)) + (glyphless-mode--setup)) + (kill-local-variable 'glyphless-char-display))) + +(defun glyphless-mode--setup () + (let ((types (if (memq 'all glyphless-mode-types) + '(c0-control c1-control format-control + variation-selectors no-font) + glyphless-mode-types))) + (when types + (update-glyphless-char-display + nil (mapcar (lambda (e) (cons e 'acronym)) types))))) + +(provide 'glyphless-mode) + +;;; glyphless-mode.el ends here diff --git a/lisp/textmodes/ispell.el b/lisp/textmodes/ispell.el index 0a3a49d868a..754ecb3a1d7 100644 --- a/lisp/textmodes/ispell.el +++ b/lisp/textmodes/ispell.el @@ -2398,24 +2398,24 @@ Global `ispell-quit' set to start location to continue spell session." Selections are: -DIGIT: Replace the word with a digit offered in the *Choices* buffer. -SPC: Accept word this time. -`i': Accept word and insert into private dictionary. -`a': Accept word for this session. -`A': Accept word and place in `buffer-local dictionary'. -`r': Replace word with typed-in value. Rechecked. -`R': Replace word with typed-in value. Query-replaced in buffer. Rechecked. -`?': Show these commands. -`x': Exit spelling buffer. Move cursor to original point. -`X': Exit spelling buffer. Leaves cursor at the current point, and permits +\\`0'..\\`9' Replace the word with a digit offered in the *Choices* buffer. +\\`SPC' Accept word this time. +\\`i' Accept word and insert into private dictionary. +\\`a' Accept word for this session. +\\`A' Accept word and place in `buffer-local dictionary'. +\\`r' Replace word with typed-in value. Rechecked. +\\`R' Replace word with typed-in value. Query-replaced in buffer. Rechecked. +\\`?' Show these commands. +\\`x' Exit spelling buffer. Move cursor to original point. +\\`X' Exit spelling buffer. Leaves cursor at the current point, and permits the aborted check to be completed later. -`q': Quit spelling session (Kills ispell process). -`l': Look up typed-in replacement in alternate dictionary. Wildcards okay. -`u': Like `i', but the word is lower-cased first. -`m': Place typed-in value in personal dictionary, then recheck current word. -`C-l': Redraw screen. -`C-r': Recursive edit. -`C-z': Suspend Emacs or iconify frame." +\\`q' Quit spelling session (Kills ispell process). +\\`l' Look up typed-in replacement in alternate dictionary. Wildcards okay. +\\`u' Like \\`i', but the word is lower-cased first. +\\`m' Place typed-in value in personal dictionary, then recheck current word. +\\`C-l' Redraw screen. +\\`C-r' Recursive edit. +\\`C-z' Suspend Emacs or iconify frame." (if (equal ispell-help-in-bufferp 'electric) (progn @@ -2428,26 +2428,28 @@ SPC: Accept word this time. ;;(if (< (window-height) 15) ;; (enlarge-window ;; (- 15 (ispell-adjusted-window-height)))) - (princ "Selections are: - -DIGIT: Replace the word with a digit offered in the *Choices* buffer. -SPC: Accept word this time. -`i': Accept word and insert into private dictionary. -`a': Accept word for this session. -`A': Accept word and place in `buffer-local dictionary'. -`r': Replace word with typed-in value. Rechecked. -`R': Replace word with typed-in value. Query-replaced in buffer. Rechecked. -`?': Show these commands. -`x': Exit spelling buffer. Move cursor to original point. -`X': Exit spelling buffer. Leaves cursor at the current point, and permits - the aborted check to be completed later. -`q': Quit spelling session (Kills ispell process). -`l': Look up typed-in replacement in alternate dictionary. Wildcards okay. -`u': Like `i', but the word is lower-cased first. -`m': Place typed-in value in personal dictionary, then recheck current word. -`C-l': Redraw screen. -`C-r': Recursive edit. -`C-z': Suspend Emacs or iconify frame.") + (princ + (substitute-command-keys + "Selections are: + +\\`0'..\\`9' Replace the word with a digit offered in the *Choices* buffer. +\\`SPC' Accept word this time. +\\`i' Accept word and insert into private dictionary. +\\`a' Accept word for this session. +\\`A' Accept word and place in `buffer-local dictionary'. +\\`r' Replace word with typed-in value. Rechecked. +\\`R' Replace word with typed-in value. Query-replaced in buffer. Rechecked. +\\`?' Show these commands. +\\`x' Exit spelling buffer. Move cursor to original point. +\\`X' Exit spelling buffer. Leaves cursor at the current point, and permits + the aborted check to be completed later. +\\`q' Quit spelling session (Kills ispell process). +\\`l' Look up typed-in replacement in alternate dictionary. Wildcards okay. +\\`u' Like \\`i', but the word is lower-cased first. +\\`m' Place typed-in value in personal dictionary, then recheck current word. +\\`C-l' Redraw screen. +\\`C-r' Recursive edit. +\\`C-z' Suspend Emacs or iconify frame.")) nil))) @@ -3883,8 +3885,8 @@ Don't check spelling of message headers except the Subject field. Don't check included messages. To abort spell checking of a message region and send the message anyway, -use the `x' command. (Any subsequent regions will be checked.) -The `X' command aborts sending the message so that you can edit the buffer. +use the \\`x' command. (Any subsequent regions will be checked.) +The \\`X' command aborts sending the message so that you can edit the buffer. To spell-check whenever a message is sent, include the appropriate lines in your init file: @@ -3975,7 +3977,7 @@ You can bind this to the key C-c i in GNUS or mail by adding to (if (re-search-forward "^Subject: *" end-of-headers t) (progn (goto-char (match-end 0)) - (if (and (not (looking-at ".*Re\\>")) + (if (and (not (looking-at ".*\\<Re\\>")) (not (looking-at "\\["))) (progn (setq case-fold-search old-case-fold-search) diff --git a/lisp/textmodes/pixel-fill.el b/lisp/textmodes/pixel-fill.el new file mode 100644 index 00000000000..0a0f0eb8b66 --- /dev/null +++ b/lisp/textmodes/pixel-fill.el @@ -0,0 +1,240 @@ +;;; pixel-fill.el --- variable pitch filling functions -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; Maintainer: emacs-devel@gnu.org +;; Keywords: filling + +;; 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: + +;; The main entry point is `pixel-fill-region', but +;; `pixel-fill-find-fill-point' can also be useful by itself. + +;;; Code: + +(require 'kinsoku) + +(defgroup pixel-fill nil + "Filling based on pixel widths." + :group 'fill + :version "29.1") + +(defcustom pixel-fill-respect-kinsoku t + "If nil, fill even if we can't find a good kinsoku point. +Kinsoku is a Japanese word meaning a rule that should not be violated. +In Emacs, it is a term used for characters, e.g. punctuation marks, +parentheses, and so on, that should not be placed in the beginning +of a line or the end of a line." + :type 'boolean + :version "29.1") + +(defun pixel-fill-width (&optional columns window) + "Return the pixel width corresponding to COLUMNS in WINDOW. +If COLUMNS in nil, use the enture window width. + +If WINDOW is nil, this defaults to the current window." + (unless window + (setq window (selected-window))) + (let ((frame (window-frame window))) + (if columns + (* (frame-char-width frame) columns) + (- (window-body-width nil t) + (* 2 (frame-char-width frame)) + ;; 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 (and (fboundp 'fringe-columns) + (or (not (zerop (fringe-columns 'right))) + (not (zerop (fringe-columns 'left))))) + 0 + (* (frame-char-width frame) 2)) + 1)))) + +(defun pixel-fill-region (start end pixel-width) + "Fill the region between START and END. +This will attempt to reformat the text in the region to have no +lines that are visually wider than PIXEL-WIDTH. + +If START isn't at the start of a line, the horizontal position of +START, converted to pixel units, will be used as the indentation +prefix on subsequent lines." + (save-excursion + (goto-char start) + (let ((indentation + (car (window-text-pixel-size nil (line-beginning-position) + (point)))) + (newline-end nil)) + (when (> indentation pixel-width) + (error "The indentation (%s) is wider than the fill width (%s)" + indentation pixel-width)) + (save-restriction + (narrow-to-region start end) + (goto-char (point-max)) + (when (looking-back "\n[ \t]*" (point-min)) + (setq newline-end t)) + (goto-char (point-min)) + ;; First replace all whitespace with space. + (while (re-search-forward "[ \t\n]+" nil t) + (cond + ((or (= (match-beginning 0) start) + (= (match-end 0) end)) + (delete-region (match-beginning 0) (match-end 0))) + ;; If there's just a single space here, don't replace. + ((not (and (= (- (match-end 0) (match-beginning 0)) 1) + (= (char-after (match-beginning 0)) ?\s))) + (replace-match + ;; We need to use a space that has an appropriate width. + (propertize " " 'face + (get-text-property (match-beginning 0) 'face)))))) + (goto-char start) + (pixel-fill--fill-line pixel-width indentation) + (goto-char (point-max)) + (when newline-end + (insert "\n")))))) + +(defun pixel-fill--goto-pixel (width) + (vertical-motion (cons (/ width (frame-char-width)) 0))) + +(defun pixel-fill--fill-line (width &optional indentation) + (let ((start (point))) + (pixel-fill--goto-pixel width) + (while (not (eolp)) + ;; We have to do some folding. First find the first previous + ;; point suitable for folding. + (when (or (not (pixel-fill-find-fill-point (line-beginning-position))) + (= (point) start)) + ;; We had unbreakable text (for this width), so just go to + ;; the first space and carry on. + (beginning-of-line) + (skip-chars-forward " ") + (search-forward " " (line-end-position) 'move)) + (when (= (preceding-char) ?\s) + (delete-char -1)) + (unless (eobp) + (insert ?\n) + (when (> indentation 0) + (insert (propertize " " 'display + (list 'space :align-to (list indentation)))))) + (setq start (point)) + (unless (eobp) + (pixel-fill--goto-pixel width))))) + +(define-inline pixel-fill--char-breakable-p (char) + "Return non-nil if a line can be broken before and after CHAR." + (inline-quote (aref fill-find-break-point-function-table ,char))) + +(define-inline pixel-fill--char-nospace-p (char) + "Return non-nil if no space is required before and after CHAR." + (inline-quote (aref fill-nospace-between-words-table ,char))) + +(define-inline pixel-fill--char-kinsoku-bol-p (char) + "Return non-nil if a line ought not to begin with CHAR." + (inline-letevals (char) + (inline-quote (and (not (eq ,char ?')) + (aref (char-category-set ,char) ?>))))) + +(define-inline pixel-fill--char-kinsoku-eol-p (char) + "Return non-nil if a line ought not to end with CHAR." + (inline-quote (aref (char-category-set ,char) ?<))) + +(defun pixel-fill-find-fill-point (start) + "Find a place suitable for breaking the current line. +START should be the earliest buffer position that should be considered +(typically the start of the line), and this function will search +backward in the current buffer from the current position." + (let ((bp (point)) + (end (point)) + failed) + (while (not + (or (setq failed (<= (point) start)) + (eq (preceding-char) ?\s) + (eq (following-char) ?\s) + (pixel-fill--char-breakable-p (preceding-char)) + (pixel-fill--char-breakable-p (following-char)) + (and (pixel-fill--char-kinsoku-bol-p (preceding-char)) + (pixel-fill--char-breakable-p (following-char)) + (not (pixel-fill--char-kinsoku-bol-p (following-char)))) + (pixel-fill--char-kinsoku-eol-p (following-char)) + (bolp))) + (backward-char 1)) + (if failed + ;; There's no breakable point, so we give it up. + (let (found) + (goto-char bp) + ;; Don't overflow the window edge, even if + ;; `pixel-fill-respect-kinsoku' is t. + (when pixel-fill-respect-kinsoku + (while (setq found (re-search-forward + "\\(\\c>\\)\\| \\|\\c<\\|\\c|" + (line-end-position) 'move))) + (if (and found + (not (match-beginning 1))) + (goto-char (match-beginning 0))))) + (or + (eolp) + ;; Don't put kinsoku-bol characters at the beginning of a line, + ;; or kinsoku-eol characters at the end of a line. + (cond + ;; Don't overflow the window edge, even if `pixel-fill-respect-kinsoku' + ;; is t. + ((not pixel-fill-respect-kinsoku) + (while (and (not (eq (preceding-char) ?\s)) + (or (pixel-fill--char-kinsoku-eol-p (preceding-char)) + (pixel-fill--char-kinsoku-bol-p (following-char)))) + (backward-char 1)) + (when (setq failed (<= (point) start)) + ;; There's no breakable point that doesn't violate kinsoku, + ;; so we look for the second best position. + (while (and (progn + (forward-char 1) + (<= (point) end)) + (progn + (setq bp (point)) + (pixel-fill--char-kinsoku-eol-p (following-char))))) + (goto-char bp))) + ((pixel-fill--char-kinsoku-eol-p (preceding-char)) + ;; Find backward the point where kinsoku-eol characters begin. + (let ((count 4)) + (while + (progn + (backward-char 1) + (and (> (setq count (1- count)) 0) + (not (eq (preceding-char) ?\s)) + (or (pixel-fill--char-kinsoku-eol-p (preceding-char)) + (pixel-fill--char-kinsoku-bol-p (following-char))))))) + (when (setq failed (<= (point) start)) + ;; There's no breakable point that doesn't violate kinsoku, + ;; so we go to the second best position. + (if (looking-at "\\(\\c<+\\)\\c<") + (goto-char (match-end 1)) + (forward-char 1)))) + ((pixel-fill--char-kinsoku-bol-p (following-char)) + ;; Find forward the point where kinsoku-bol characters end. + (let ((count 4)) + (while (progn + (forward-char 1) + (and (>= (setq count (1- count)) 0) + (pixel-fill--char-kinsoku-bol-p (following-char)) + (pixel-fill--char-breakable-p (following-char)))))))) + (when (eq (following-char) ?\s) + (forward-char 1)))) + (not failed))) + +(provide 'pixel-fill) + +;;; pixel-fill.el ends here diff --git a/lisp/textmodes/reftex-global.el b/lisp/textmodes/reftex-global.el index b90c21339cc..f787f5f3e56 100644 --- a/lisp/textmodes/reftex-global.el +++ b/lisp/textmodes/reftex-global.el @@ -148,8 +148,10 @@ No active TAGS table is required." (erase-buffer) (insert " MULTIPLE LABELS IN CURRENT DOCUMENT:\n") (insert - " Move point to label and type `r' to run a query-replace on the label\n" - " and its references. Type `q' to exit this buffer.\n\n") + (substitute-command-keys + " Move point to label and type \\`r' to run a query-replace on the label\n") + (substitute-command-keys + " and its references. Type \\`q' to exit this buffer.\n\n")) (insert " LABEL FILE\n") (insert " -------------------------------------------------------------\n") (use-local-map (make-sparse-keymap)) diff --git a/lisp/textmodes/reftex-index.el b/lisp/textmodes/reftex-index.el index 9d9eab4d7b5..357f7da2f9d 100644 --- a/lisp/textmodes/reftex-index.el +++ b/lisp/textmodes/reftex-index.el @@ -29,9 +29,7 @@ (require 'reftex) -;; START remove for XEmacs release (defvar TeX-master) -;; END remove for XEmacs release ;;;###autoload (defun reftex-index-selection-or-word (&optional arg phrase) diff --git a/lisp/textmodes/reftex-parse.el b/lisp/textmodes/reftex-parse.el index c521a07f192..b8c75cb21b6 100644 --- a/lisp/textmodes/reftex-parse.el +++ b/lisp/textmodes/reftex-parse.el @@ -345,7 +345,17 @@ of master file." ;; Find external document specifications (goto-char 1) - (while (re-search-forward "[\n\r][ \t]*\\\\externaldocument\\(\\[\\([^]]*\\)\\]\\)?{\\([^}]+\\)}" nil t) + (while (re-search-forward + (concat "[\n\r][ \t]*" + ;; Support \externalcitedocument macro + "\\\\external\\(?:cite\\)?document" + ;; The optional prefix + "\\(\\[\\([^]]*\\)\\]\\)?" + ;; The 2nd opt. arg can only be nocite + "\\(?:\\[nocite\\]\\)?" + ;; Mandatory file argument + "{\\([^}]+\\)}") + nil t) (push (list 'xr-doc (reftex-match-string 2) (reftex-match-string 3)) docstruct)) diff --git a/lisp/textmodes/reftex-vars.el b/lisp/textmodes/reftex-vars.el index d57a7678553..dedd74607ae 100644 --- a/lisp/textmodes/reftex-vars.el +++ b/lisp/textmodes/reftex-vars.el @@ -70,12 +70,16 @@ ("tabwindow" ?f nil nil 1))) (rotating "Sidewaysfigure and table" - (("sidewaysfigure" ?f nil nil caption) - ("sidewaystable" ?t nil nil caption))) + (("sidewaysfigure" ?f nil nil caption) + ("sidewaysfigure*" ?f nil nil caption) + ("sidewaystable" ?t nil nil caption) + ("sidewaystable*" ?t nil nil caption))) - (sidecap "CSfigure and SCtable" - (("SCfigure" ?f nil nil caption) - ("SCtable" ?t nil nil caption))) + (sidecap "SCfigure and SCtable" + (("SCfigure" ?f nil nil caption) + ("SCfigure*" ?f nil nil caption) + ("SCtable" ?t nil nil caption) + ("SCtable*" ?t nil nil caption))) (subfigure "Subfigure environments/macro" (("subfigure" ?f nil nil caption) @@ -392,19 +396,19 @@ that the *toc* window fills half the frame." (defcustom reftex-toc-include-file-boundaries nil "Non-nil means, include file boundaries in *toc* buffer. -This flag can be toggled from within the *toc* buffer with the `F' key." +This flag can be toggled from within the *toc* buffer with the \\`F' key." :group 'reftex-table-of-contents-browser :type 'boolean) (defcustom reftex-toc-include-labels nil "Non-nil means, include labels in *toc* buffer. -This flag can be toggled from within the *toc* buffer with the `l' key." +This flag can be toggled from within the *toc* buffer with the \\`l' key." :group 'reftex-table-of-contents-browser :type 'boolean) (defcustom reftex-toc-include-index-entries nil "Non-nil means, include index entries in *toc* buffer. -This flag can be toggled from within the *toc* buffer with the `i' key." +This flag can be toggled from within the *toc* buffer with the \\`i' key." :group 'reftex-table-of-contents-browser :type 'boolean) @@ -422,14 +426,14 @@ changed." (defcustom reftex-toc-include-context nil "Non-nil means, include context with labels in the *toc* buffer. Context will only be shown when labels are visible as well. -This flag can be toggled from within the *toc* buffer with the `c' key." +This flag can be toggled from within the *toc* buffer with the \\`c' key." :group 'reftex-table-of-contents-browser :type 'boolean) (defcustom reftex-toc-follow-mode nil "Non-nil means, point in *toc* buffer will cause other window to follow. The other window will show the corresponding part of the document. -This flag can be toggled from within the *toc* buffer with the `f' key." +This flag can be toggled from within the *toc* buffer with the \\`f' key." :group 'reftex-table-of-contents-browser :type 'boolean) @@ -1627,14 +1631,14 @@ to that section." (defcustom reftex-index-include-context nil "Non-nil means, display the index definition context in the index buffer. -This flag may also be toggled from the index buffer with the `c' key." +This flag may also be toggled from the index buffer with the \\`c' key." :group 'reftex-index-support :type 'boolean) (defcustom reftex-index-follow-mode nil "Non-nil means, point in *Index* buffer will cause other window to follow. The other window will show the corresponding part of the document. -This flag can be toggled from within the *Index* buffer with the `f' key." +This flag can be toggled from within the *Index* buffer with the \\`f' key." :group 'reftex-table-of-contents-browser :type 'boolean) @@ -1863,10 +1867,11 @@ of the regular expressions in this list, that file is not parsed by RefTeX." (defcustom reftex-enable-partial-scans nil "Non-nil means, re-parse only 1 file when asked to re-parse. Re-parsing is normally requested with a \\[universal-argument] prefix to many RefTeX commands, -or with the `r' key in menus. When this option is t in a multifile document, +or with the \\`r' key in menus. When this option is t in a multifile document, we will only parse the current buffer, or the file associated with the label or section heading near point in a menu. Requesting re-parsing of an entire -multifile document then requires a \\[universal-argument] \\[universal-argument] prefix or the capital `R' key +multifile document then requires a \\[universal-argument] \ +\\[universal-argument] prefix or the capital \\`R' key in menus." :group 'reftex-optimizations-for-large-documents :type 'boolean) @@ -1912,7 +1917,7 @@ when new labels in its category are added. See the variable When a new label is defined with `reftex-label', all selection buffers associated with that label category are emptied, in order to force an update upon next use. When nil, the buffers are left alone and have to be -updated by hand, with the `g' key from the label selection process. +updated by hand, with the \\`g' key from the label selection process. The value of this variable will only have any effect when `reftex-use-multiple-selection-buffers' is non-nil." :group 'reftex-optimizations-for-large-documents @@ -1964,7 +1969,7 @@ instead or as well. The variable may have one of these values: both Both cursor and mouse trigger highlighting. Changing this variable requires rebuilding the selection and *toc* buffers -to become effective (keys `g' or `r')." +to become effective (keys \\`g' or \\`r')." :group 'reftex-fontification-configurations :type '(choice (const :tag "Never" nil) diff --git a/lisp/textmodes/sgml-mode.el b/lisp/textmodes/sgml-mode.el index 7ef8161ab5c..dedc3882199 100644 --- a/lisp/textmodes/sgml-mode.el +++ b/lisp/textmodes/sgml-mode.el @@ -440,7 +440,8 @@ These have to be run via `sgml-syntax-propertize'")) ;; internal (defvar sgml-face-tag-alist () - "Alist of face and tag name for facemenu.") + "Alist of face and tag name for facemenu. +The tag name can be a string or a list of strings.") (defvar sgml-tag-face-alist () "Tag names and face or list of faces to fontify with when invisible. @@ -528,11 +529,13 @@ an optional alist of possible values." (comment-indent-new-line soft))) (defun sgml-mode-facemenu-add-face-function (face _end) - (let ((tag-face (cdr (assq face sgml-face-tag-alist)))) + "Add \"face\" tags with `facemenu-keymap' commands." + (let ((tag-face (ensure-list (cdr (assq face sgml-face-tag-alist))))) (cond (tag-face (setq tag-face (funcall skeleton-transformation-function tag-face)) - (setq facemenu-end-add-face (concat "</" tag-face ">")) - (concat "<" tag-face ">")) + (setq facemenu-end-add-face + (mapconcat (lambda (f) (concat "</" f ">")) (reverse tag-face) "")) + (mapconcat (lambda (f) (concat "<" f ">")) tag-face "")) ((and (consp face) (consp (car face)) (null (cdr face)) @@ -1868,6 +1871,7 @@ This takes effect when first loading the library.") (defvar html-face-tag-alist '((bold . "strong") (italic . "em") + (bold-italic . ("strong" "em")) (underline . "u") (mode-line . "rev")) "Value of `sgml-face-tag-alist' for HTML mode.") @@ -2411,6 +2415,8 @@ To work around that, do: (setq-local css-id-list-function #'html-current-buffer-ids)) (setq imenu-create-index-function 'html-imenu-index) + (yank-media-handler 'text/html #'html-mode--html-yank-handler) + (yank-media-handler "image/.*" #'html-mode--image-yank-handler) (setq-local sgml-empty-tags ;; From HTML-4.01's loose.dtd, parsed with @@ -2426,6 +2432,30 @@ To work around that, do: ;; (setq imenu-sort-function nil) ; sorting the menu defeats the purpose ) +(defun html-mode--html-yank-handler (_type html) + (save-restriction + (insert html) + (ignore-errors + (sgml-pretty-print (point-min) (point-max))))) + +(defun html-mode--image-yank-handler (type image) + (let ((file (read-file-name (format "Save %s image to: " type)))) + (when (file-directory-p file) + (user-error "%s is a directory")) + (when (and (file-exists-p file) + (not (yes-or-no-p (format "%s exists; overwrite?" file)))) + (user-error "%s exists")) + (with-temp-buffer + (set-buffer-multibyte nil) + (insert image) + (write-region (point-min) (point-max) file)) + (insert (format "<img src=%S>\n" (file-relative-name file))) + (insert-image + (create-image file (mailcap-mime-type-to-extension type) nil + :max-width 200 + :max-height 200) + " "))) + (defvar html-imenu-regexp "\\s-*<h\\([1-9]\\)[^\n<>]*>\\(<[^\n<>]*>\\)*\\s-*\\([^\n<>]*\\)" "A regular expression matching a head line to be added to the menu. diff --git a/lisp/textmodes/table.el b/lisp/textmodes/table.el index fef5ad2c7ac..ca99d562e40 100644 --- a/lisp/textmodes/table.el +++ b/lisp/textmodes/table.el @@ -1195,6 +1195,21 @@ executing body forms.") (easy-menu-add-item (current-global-map) '("menu-bar" "tools") table-global-menu-map) +;;;###autoload +(define-minor-mode table-fixed-width-mode + "Cell width is fixed when this is non-nil. +Normally it should be nil for allowing automatic cell width expansion +that widens a cell when it is necessary. When non-nil, typing in a +cell does not automatically expand the cell width. A word that is too +long to fit in a cell is chopped into multiple lines. The chopped +location is indicated by `table-word-continuation-char'. This +variable's value can be toggled by \\[table-fixed-width-mode] at +run-time." + :tag "Fix Cell Width" + :group 'table + (table--finish-delayed-tasks) + (table--update-cell-face)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Macros @@ -1219,43 +1234,49 @@ original buffer's point is moved to the location that corresponds to the last cache point coordinate." (declare (debug (body)) (indent 0)) (let ((height-expansion (make-symbol "height-expansion-var-symbol")) - (width-expansion (make-symbol "width-expansion-var-symbol"))) - `(let (,height-expansion ,width-expansion) + (width-expansion (make-symbol "width-expansion-var-symbol")) + (fixed-width (make-symbol "fixed-width"))) + `(let ((,fixed-width table-fixed-width-mode) + ,height-expansion ,width-expansion) ;; make sure cache has valid data unless it is explicitly inhibited. (unless table-inhibit-update (table-recognize-cell)) (with-current-buffer (get-buffer-create table-cache-buffer-name) - ;; goto the cell coordinate based on `table-cell-cache-point-coordinate'. - (set-mark (table--goto-coordinate table-cell-cache-mark-coordinate)) - (table--goto-coordinate table-cell-cache-point-coordinate) - (table--untabify-line) - ;; always reset before executing body forms because auto-fill behavior is the default. - (setq table-inhibit-auto-fill-paragraph nil) - ;; do the body - ,@body - ;; fill paragraph unless the body does not want to by setting `table-inhibit-auto-fill-paragraph'. - (unless table-inhibit-auto-fill-paragraph - (if (and table-cell-info-justify - (not (eq table-cell-info-justify 'left))) - (table--fill-region (point-min) (point-max)) - (table--fill-region - (save-excursion (forward-paragraph -1) (point)) - (save-excursion (forward-paragraph 1) (point))))) - ;; keep the updated cell coordinate. - (setq table-cell-cache-point-coordinate (table--get-coordinate)) - ;; determine the cell width expansion. - (setq ,width-expansion (table--measure-max-width)) - (if (<= ,width-expansion table-cell-info-width) nil - (table--fill-region (point-min) (point-max) ,width-expansion) - ;; keep the updated cell coordinate. - (setq table-cell-cache-point-coordinate (table--get-coordinate))) - (setq ,width-expansion (- ,width-expansion table-cell-info-width)) - ;; determine the cell height expansion. - (if (looking-at "\\s *\\'") nil - (goto-char (point-min)) - (if (re-search-forward "\\(\\s *\\)\\'" nil t) - (goto-char (match-beginning 1)))) - (setq ,height-expansion (- (cdr (table--get-coordinate)) (1- table-cell-info-height)))) + (let ((table-fixed-width-mode ,fixed-width)) + ;; Go to the cell coordinate based on + ;; `table-cell-cache-point-coordinate'. + (set-mark (table--goto-coordinate table-cell-cache-mark-coordinate)) + (table--goto-coordinate table-cell-cache-point-coordinate) + (table--untabify-line) + ;; Always reset before executing body forms because + ;; auto-fill behavior is the default. + (setq table-inhibit-auto-fill-paragraph nil) + ;; Do the body + ,@body + ;; Fill paragraph unless the body does not want to by + ;; setting `table-inhibit-auto-fill-paragraph'. + (unless table-inhibit-auto-fill-paragraph + (if (and table-cell-info-justify + (not (eq table-cell-info-justify 'left))) + (table--fill-region (point-min) (point-max)) + (table--fill-region + (save-excursion (forward-paragraph -1) (point)) + (save-excursion (forward-paragraph 1) (point))))) + ;; Keep the updated cell coordinate. + (setq table-cell-cache-point-coordinate (table--get-coordinate)) + ;; Determine the cell width expansion. + (setq ,width-expansion (table--measure-max-width)) + (if (<= ,width-expansion table-cell-info-width) nil + (table--fill-region (point-min) (point-max) ,width-expansion) + ;; Keep the updated cell coordinate. + (setq table-cell-cache-point-coordinate (table--get-coordinate))) + (setq ,width-expansion (- ,width-expansion table-cell-info-width)) + ;; Determine the cell height expansion. + (if (looking-at "\\s *\\'") nil + (goto-char (point-min)) + (if (re-search-forward "\\(\\s *\\)\\'" nil t) + (goto-char (match-beginning 1)))) + (setq ,height-expansion (- (cdr (table--get-coordinate)) (1- table-cell-info-height))))) ;; now back to the table buffer. ;; expand the cell width in the table buffer if necessary. (if (> ,width-expansion 0) @@ -2823,21 +2844,6 @@ or `top', `middle', `bottom' or `none' for vertical." (table--justify-cell-contents justify)))))) ;;;###autoload -(define-minor-mode table-fixed-width-mode - "Cell width is fixed when this is non-nil. -Normally it should be nil for allowing automatic cell width expansion -that widens a cell when it is necessary. When non-nil, typing in a -cell does not automatically expand the cell width. A word that is too -long to fit in a cell is chopped into multiple lines. The chopped -location is indicated by `table-word-continuation-char'. This -variable's value can be toggled by \\[table-fixed-width-mode] at -run-time." - :tag "Fix Cell Width" - :group 'table - (table--finish-delayed-tasks) - (table--update-cell-face)) - -;;;###autoload (defun table-query-dimension (&optional where) "Return the dimension of the current cell and the current table. The result is a list (cw ch tw th c r cells) where cw is the cell diff --git a/lisp/textmodes/tex-mode.el b/lisp/textmodes/tex-mode.el index 6fd66b2502f..5fba93c76eb 100644 --- a/lisp/textmodes/tex-mode.el +++ b/lisp/textmodes/tex-mode.el @@ -2457,7 +2457,7 @@ Only applies the FSPEC to the args part of FORMAT." (default (tex-compile-default fspec))) (list default-directory (completing-read - (format "Command [%s]: " (tex-summarize-command default)) + (format-prompt "Command" (tex-summarize-command default)) (mapcar (lambda (x) (list (tex-format-cmd (eval (car x) t) fspec))) tex-compile-commands) diff --git a/lisp/textmodes/texinfo.el b/lisp/textmodes/texinfo.el index 7876a87a281..dbf30dabe59 100644 --- a/lisp/textmodes/texinfo.el +++ b/lisp/textmodes/texinfo.el @@ -4,7 +4,6 @@ ;; Foundation, Inc. ;; Author: Robert J. Chassell -;; Date: [See date below for texinfo-version] ;; Maintainer: emacs-devel@gnu.org ;; Keywords: maint, tex, docs @@ -411,13 +410,13 @@ value of `texinfo-mode-hook'." "\\)\\>")) (setq-local require-final-newline mode-require-final-newline) (setq-local indent-tabs-mode nil) - (setq-local paragraph-separate - (concat "@[a-zA-Z]*[ \n]\\|" - paragraph-separate)) (setq-local paragraph-start (concat "@[a-zA-Z]*[ \n]\\|" paragraph-start)) + (setq-local fill-paragraph-function 'texinfo--fill-paragraph) (setq-local sentence-end-base "\\(@\\(end\\)?dots{}\\|[.?!]\\)[]\"'”)}]*") (setq-local fill-column 70) + (setq-local beginning-of-defun-function #'texinfo--beginning-of-defun) + (setq-local end-of-defun-function #'texinfo--end-of-defun) (setq-local comment-start "@c ") (setq-local comment-start-skip "@c +\\|@comment +") (setq-local words-include-escapes t) @@ -457,6 +456,58 @@ value of `texinfo-mode-hook'." prevent-filling (concat auto-fill-inhibit-regexp "\\|" prevent-filling))))) +(defvar texinfo-fillable-commands '("@noindent") + "A list of commands that can be filled.") + +(defun texinfo--fill-paragraph (justify) + "Function to fill a paragraph in `texinfo-mode'." + (let ((command-re "\\(@[a-zA-Z]+\\)[ \t\n]")) + (catch 'no-fill + (save-restriction + ;; First check whether we're on a command line that can be + ;; filled by itself. + (or + (save-excursion + (beginning-of-line) + (when (looking-at command-re) + (let ((command (match-string 1))) + (if (member command texinfo-fillable-commands) + (progn + (narrow-to-region (point) (progn (forward-line 1) (point))) + t) + (throw 'no-fill nil))))) + ;; We're not on such a line, so fill the region. + (save-excursion + (let ((regexp (concat command-re "\\|^[ \t]*$\\|\f"))) + (narrow-to-region + (if (re-search-backward regexp nil t) + (progn + (forward-line 1) + (point)) + (point-min)) + (if (re-search-forward regexp nil t) + (match-beginning 0) + (point-max))) + (goto-char (point-min))))) + ;; We've now narrowed to the region we want to fill. + (let ((fill-paragraph-function nil) + (adaptive-fill-mode nil)) + (fill-paragraph justify)))) + t)) + +(defun texinfo--beginning-of-defun (&optional arg) + "Go to the previous @node line." + (while (and (> arg 0) + (re-search-backward "^@node " nil t)) + (setq arg (1- arg)))) + +(defun texinfo--end-of-defun () + "Go to the start of the next @node line." + (when (looking-at-p "@node") + (forward-line)) + (if (re-search-forward "^@node " nil t) + (goto-char (match-beginning 0)) + (goto-char (point-max)))) ;;; Insert string commands diff --git a/lisp/thingatpt.el b/lisp/thingatpt.el index 32e66184d70..2d1bf2013e1 100644 --- a/lisp/thingatpt.el +++ b/lisp/thingatpt.el @@ -106,8 +106,17 @@ valid THING. Return a cons cell (START . END) giving the start and end positions of the thing found." - (if (get thing 'bounds-of-thing-at-point) - (funcall (get thing 'bounds-of-thing-at-point)) + (cond + ((get thing 'bounds-of-thing-at-point) + (funcall (get thing 'bounds-of-thing-at-point))) + ;; If the buffer is totally empty, give up. + ((and (not (eq thing 'whitespace)) + (save-excursion + (goto-char (point-min)) + (not (re-search-forward "[^\t\n ]" nil t)))) + nil) + ;; Find the thing. + (t (let ((orig (point))) (ignore-errors (save-excursion @@ -149,7 +158,7 @@ positions of the thing found." (lambda () (forward-thing thing -1)))) (point)))) (if (and (<= real-beg orig) (<= orig end) (< real-beg end)) - (cons real-beg end)))))))))) + (cons real-beg end))))))))))) ;;;###autoload (defun thing-at-point (thing &optional no-properties) diff --git a/lisp/thumbs.el b/lisp/thumbs.el index 4c863883ba4..001b2c8e770 100644 --- a/lisp/thumbs.el +++ b/lisp/thumbs.el @@ -91,7 +91,7 @@ When it reaches that size (in bytes), a warning is sent." (defcustom thumbs-conversion-program (if (eq system-type 'windows-nt) ;; FIXME is this necessary, or can a sane PATHEXE be assumed? - ;; Eg find-program does not do this. + ;; E.g. find-program does not do this. "convert.exe" "convert") "Name of conversion program for thumbnails generation. @@ -292,22 +292,11 @@ smaller according to whether INCREMENT is 1 or -1." (thumbs-call-convert fn tn "sample" thumbs-geometry)) tn)) -(defun thumbs-image-type (img) - "Return image type from filename IMG." - (cond ((string-match ".*\\.jpe?g\\'" img) 'jpeg) - ((string-match ".*\\.xpm\\'" img) 'xpm) - ((string-match ".*\\.xbm\\'" img) 'xbm) - ((string-match ".*\\.pbm\\'" img) 'pbm) - ((string-match ".*\\.gif\\'" img) 'gif) - ((string-match ".*\\.bmp\\'" img) 'bmp) - ((string-match ".*\\.png\\'" img) 'png) - ((string-match ".*\\.tiff?\\'" img) 'tiff))) - (declare-function image-size "image.c" (spec &optional pixels frame)) (defun thumbs-file-size (img) (let ((i (image-size - (find-image `((:type ,(thumbs-image-type img) :file ,img))) t))) + (find-image `((:type ,(image-type-from-file-name img) :file ,img))) t))) (concat (number-to-string (round (car i))) "x" (number-to-string (round (cdr i)))))) @@ -410,7 +399,7 @@ and SAME-WINDOW to show thumbs in the same window." thumbs-image-num (or num 0)) (delete-region (point-min)(point-max)) (save-excursion - (thumbs-insert-image img (thumbs-image-type img) 0))))) + (thumbs-insert-image img (image-type-from-file-name img) 0))))) (defun thumbs-find-image-at-point (&optional img otherwin) "Display image IMG for thumbnail at point. @@ -544,7 +533,7 @@ Open another window." " - " (number-to-string num))) (let ((inhibit-read-only t)) (erase-buffer) - (thumbs-insert-image img (thumbs-image-type img) 0) + (thumbs-insert-image img (image-type-from-file-name img) 0) (goto-char (point-min)))) (setq thumbs-image-num num thumbs-current-image-filename img)))) @@ -775,6 +764,9 @@ ACTION and ARG should be a valid convert command." (define-key dired-mode-map "\C-tm" 'thumbs-dired-show-marked) (define-key dired-mode-map "\C-tw" 'thumbs-dired-setroot) +(define-obsolete-function-alias 'thumbs-image-type + #'image-type-from-file-name "29.1") + (provide 'thumbs) ;;; thumbs.el ends here diff --git a/lisp/time.el b/lisp/time.el index 8496adec228..fcea064b4cf 100644 --- a/lisp/time.el +++ b/lisp/time.el @@ -343,7 +343,7 @@ Switches from the 1 to 5 to 15 minute load average, and then back to 1." "Update the `display-time' info for the mode line. However, don't redisplay right now. -This is used for things like Rmail `g' that want to force an +This is used for things like Rmail \\`g' that want to force an update which can wait for the next redisplay." (let* ((now (current-time)) (time (current-time-string now)) @@ -526,11 +526,9 @@ If the value is t instead of an alist, use the value of '((t :inherit font-lock-variable-name-face)) "Face for time zone label in `world-clock' buffer.") -(defvar world-clock-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "n" #'next-line) - (define-key map "p" #'previous-line) - map)) +(defvar-keymap world-clock-mode-map + "n" #'next-line + "p" #'previous-line) (define-derived-mode world-clock-mode special-mode "World clock" "Major mode for buffer that displays times in various time zones. diff --git a/lisp/timezone.el b/lisp/timezone.el index 2c96343a74b..0fcdbdbc16c 100644 --- a/lisp/timezone.el +++ b/lisp/timezone.el @@ -95,10 +95,7 @@ if nil, the local time zone is assumed." Optional argument TIMEZONE specifies a time zone." (let ((zone (if (listp timezone) - (let* ((m (timezone-zone-to-minute timezone)) - (absm (if (< m 0) (- m) m))) - (format "%c%02d%02d" - (if (< m 0) ?- ?+) (/ absm 60) (% absm 60))) + (format-time-string "%z" 0 (or timezone 0)) timezone))) (format "%02d %s %04d %s %s" day diff --git a/lisp/tooltip.el b/lisp/tooltip.el index 23b67ee2cab..6cc482d012a 100644 --- a/lisp/tooltip.el +++ b/lisp/tooltip.el @@ -368,10 +368,15 @@ It is also called if Tooltip mode is on, for text-only displays." ((equal-including-properties tooltip-help-message (current-message)) (message nil))))) +(declare-function menu-or-popup-active-p "xmenu.c" ()) + (defun tooltip-show-help (msg) "Function installed as `show-help-function'. MSG is either a help string to display, or nil to cancel the display." - (if (display-graphic-p) + (if (and (display-graphic-p) + (or (not (eq window-system 'haiku)) ;; On Haiku, there isn't a reliable way to show tooltips + ;; above menus. + (not (menu-or-popup-active-p)))) (let ((previous-help tooltip-help-message)) (setq tooltip-help-message msg) (cond ((null msg) diff --git a/lisp/tree-widget.el b/lisp/tree-widget.el index d40a628b994..8691f03f86d 100644 --- a/lisp/tree-widget.el +++ b/lisp/tree-widget.el @@ -214,8 +214,8 @@ Give the image the specified properties PROPS." See also the option `widget-image-conversion'." (delq nil (mapcar - #'(lambda (fmt) - (and (image-type-available-p (car fmt)) fmt)) + (lambda (fmt) + (and (image-type-available-p (car fmt)) fmt)) widget-image-conversion))) ;; Buffer local cache of theme data. diff --git a/lisp/tutorial.el b/lisp/tutorial.el index 186bf35fe7e..bf985280d80 100644 --- a/lisp/tutorial.el +++ b/lisp/tutorial.el @@ -423,11 +423,9 @@ where ;; Handle prefix definitions specially ;; so that a mode that rebinds some subcommands ;; won't make it appear that the whole prefix is gone. - (key-fun (if (eq def-fun 'ESC-prefix) - (lookup-key global-map [27]) - (if (eq def-fun 'Control-X-prefix) - (lookup-key global-map [24]) - (key-binding key)))) + (key-fun (if (keymapp def-fun) + (lookup-key global-map key) + (key-binding key))) (where (where-is-internal (if rem-fun rem-fun def-fun))) cwhere) diff --git a/lisp/userlock.el b/lisp/userlock.el index 348ccc6f8ec..9a2d45a8468 100644 --- a/lisp/userlock.el +++ b/lisp/userlock.el @@ -39,10 +39,6 @@ (define-error 'file-locked "File is locked" 'file-error) -(defun userlock--fontify-key (key) - "Add the `help-key-binding' face to string KEY." - (propertize key 'face 'help-key-binding)) - ;;;###autoload (defun ask-user-about-lock (file opponent) "Ask user what to do when he wants to edit FILE but it is locked by OPPONENT. @@ -68,12 +64,9 @@ in any way you like." (match-string 0 opponent))) opponent)) (while (null answer) - (message "%s locked by %s: (%s, %s, %s, %s)? " - short-file short-opponent - (userlock--fontify-key "s") - (userlock--fontify-key "q") - (userlock--fontify-key "p") - (userlock--fontify-key "?")) + (message (substitute-command-keys + "%s locked by %s: (\\`s', \\`q', \\`p', \\`?'? ") + short-file short-opponent) (if noninteractive (error "Cannot resolve lock conflict in batch mode")) (let ((tem (let ((inhibit-quit t) (cursor-in-echo-area t)) @@ -88,12 +81,9 @@ in any way you like." (?? . help)))) (cond ((null answer) (beep) - (message "Please type %s, %s, or %s; or %s for help" - (userlock--fontify-key "q") - (userlock--fontify-key "s") - (userlock--fontify-key "p") - ;; FIXME: Why do we use "?" here and "C-h" below? - (userlock--fontify-key "?")) + ;; FIXME: Why do we use "?" here and "C-h" below? + (message (substitute-command-keys + "Please type \\`q', \\`s', or \\`p'; or \\`?' for help")) (sit-for 3)) ((eq (cdr answer) 'help) (ask-user-about-lock-help) @@ -106,17 +96,14 @@ in any way you like." (with-output-to-temp-buffer "*Help*" (with-current-buffer standard-output (insert - (format + (substitute-command-keys "It has been detected that you want to modify a file that someone else has already started modifying in Emacs. -You can <%s>teal the file; the other user becomes the +You can <\\`s'>teal the file; the other user becomes the intruder if (s)he ever unmodifies the file and then changes it again. -You can <%s>roceed; you edit at your own (and the other user's) risk. -You can <%s>uit; don't modify this file." - (userlock--fontify-key "s") - (userlock--fontify-key "p") - (userlock--fontify-key "q"))) +You can <\\`p'>roceed; you edit at your own (and the other user's) risk. +You can <\\`q'>uit; don't modify this file.")) (help-mode)))) (define-error 'file-supersession nil 'file-error) @@ -169,14 +156,11 @@ The buffer in question is current when this function is called." (discard-input) (save-window-excursion (let ((prompt - (format "%s changed on disk; \ -really edit the buffer? (%s, %s, %s or %s) " - (file-name-nondirectory filename) - (userlock--fontify-key "y") - (userlock--fontify-key "n") - (userlock--fontify-key "r") - ;; FIXME: Why do we use "C-h" here and "?" above? - (userlock--fontify-key "C-h"))) + ;; FIXME: Why do we use "C-h" here and "?" above? + (format (substitute-command-keys + "%s changed on disk; \ +really edit the buffer? (\\`y', \\`n', \\`r' or \\`C-h') ") + (file-name-nondirectory filename))) (choices '(?y ?n ?r ?? ?\C-h)) answer) (when noninteractive @@ -205,22 +189,18 @@ really edit the buffer? (%s, %s, %s or %s) " (with-output-to-temp-buffer "*Help*" (with-current-buffer standard-output (insert - (format + (substitute-command-keys "You want to modify a buffer whose disk file has changed since you last read it in or saved it with this buffer. -If you say %s to go ahead and modify this buffer, +If you say \\`y' to go ahead and modify this buffer, you risk ruining the work of whoever rewrote the file. -If you say %s to revert, the contents of the buffer are refreshed +If you say \\`r' to revert, the contents of the buffer are refreshed from the file on disk. -If you say %s, the change you started to make will be aborted. - -Usually, you should type %s to get the latest version of the -file, then make the change again." - (userlock--fontify-key "y") - (userlock--fontify-key "r") - (userlock--fontify-key "n") - (userlock--fontify-key "r"))) +If you say \\`n', the change you started to make will be aborted. + +Usually, you should type \\`r' to get the latest version of the +file, then make the change again.")) (help-mode)))) ;;;###autoload diff --git a/lisp/vc/cvs-status.el b/lisp/vc/cvs-status.el index 63b886362ba..7886cc1eae2 100644 --- a/lisp/vc/cvs-status.el +++ b/lisp/vc/cvs-status.el @@ -29,23 +29,22 @@ ;;; Code: (require 'cl-lib) -(require 'pcvs-util) +(require 'pcvs) +(require 'easy-mmode) ;;; -(easy-mmode-defmap cvs-status-mode-map - '(("n" . next-line) - ("p" . previous-line) - ("N" . cvs-status-next) - ("P" . cvs-status-prev) - ("\M-n" . cvs-status-next) - ("\M-p" . cvs-status-prev) - ("t" . cvs-status-cvstrees) - ("T" . cvs-status-trees) - (">" . cvs-mode-checkout)) - "CVS-Status' keymap." - :group 'cvs-status - :inherit 'cvs-mode-map) +(defvar-keymap cvs-status-mode-map + :parent 'cvs-mode-map + "n" #'next-line + "p" #'previous-line + "N" #'cvs-status-next + "P" #'cvs-status-prev + "M-n" #'cvs-status-next + "M-p" #'cvs-status-prev + "t" #'cvs-status-cvstrees + "T" #'cvs-status-trees + ">" #'cvs-mode-checkout) ;;(easy-menu-define cvs-status-menu cvs-status-mode-map ;; "Menu for `cvs-status-mode'." diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index 057ffcd06e3..8f83aa580e4 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -55,6 +55,7 @@ ;;; Code: (eval-when-compile (require 'cl-lib)) (eval-when-compile (require 'subr-x)) +(require 'easy-mmode) (autoload 'vc-find-revision "vc") (autoload 'vc-find-revision-no-save "vc") @@ -162,57 +163,55 @@ and hunk-based syntax highlighting otherwise as a fallback." ;;;; keymap, menu, ... ;;;; -(easy-mmode-defmap diff-mode-shared-map - '(("n" . diff-hunk-next) - ("N" . diff-file-next) - ("p" . diff-hunk-prev) - ("P" . diff-file-prev) - ("\t" . diff-hunk-next) - ([backtab] . diff-hunk-prev) - ("k" . diff-hunk-kill) - ("K" . diff-file-kill) - ("}" . diff-file-next) ; From compilation-minor-mode. - ("{" . diff-file-prev) - ("\C-m" . diff-goto-source) - ([mouse-2] . diff-goto-source) - ("W" . widen) - ("o" . diff-goto-source) ; other-window - ("A" . diff-ediff-patch) - ("r" . diff-restrict-view) - ("R" . diff-reverse-direction) - ([remap undo] . diff-undo)) - "Basic keymap for `diff-mode', bound to various prefix keys." - :inherit special-mode-map) - -(easy-mmode-defmap diff-mode-map - `(("\e" . ,(let ((map (make-sparse-keymap))) - ;; We want to inherit most bindings from diff-mode-shared-map, - ;; but not all since they may hide useful M-<foo> global - ;; bindings when editing. - (set-keymap-parent map diff-mode-shared-map) - (dolist (key '("A" "r" "R" "g" "q" "W" "z")) - (define-key map key nil)) - map)) - ;; From compilation-minor-mode. - ("\C-c\C-c" . diff-goto-source) - ;; By analogy with the global C-x 4 a binding. - ("\C-x4A" . diff-add-change-log-entries-other-window) - ;; Misc operations. - ("\C-c\C-a" . diff-apply-hunk) - ("\C-c\C-e" . diff-ediff-patch) - ("\C-c\C-n" . diff-restrict-view) - ("\C-c\C-s" . diff-split-hunk) - ("\C-c\C-t" . diff-test-hunk) - ("\C-c\C-r" . diff-reverse-direction) - ("\C-c\C-u" . diff-context->unified) - ;; `d' because it duplicates the context :-( --Stef - ("\C-c\C-d" . diff-unified->context) - ("\C-c\C-w" . diff-ignore-whitespace-hunk) - ;; `l' because it "refreshes" the hunk like C-l refreshes the screen - ("\C-c\C-l" . diff-refresh-hunk) - ("\C-c\C-b" . diff-refine-hunk) ;No reason for `b' :-( - ("\C-c\C-f" . next-error-follow-minor-mode)) - "Keymap for `diff-mode'. See also `diff-mode-shared-map'.") +(defvar-keymap diff-mode-shared-map + :parent special-mode-map + "n" #'diff-hunk-next + "N" #'diff-file-next + "p" #'diff-hunk-prev + "P" #'diff-file-prev + "TAB" #'diff-hunk-next + "<backtab>" #'diff-hunk-prev + "k" #'diff-hunk-kill + "K" #'diff-file-kill + "}" #'diff-file-next ; From compilation-minor-mode. + "{" #'diff-file-prev + "RET" #'diff-goto-source + "<mouse-2>" #'diff-goto-source + "W" #'widen + "o" #'diff-goto-source ; other-window + "A" #'diff-ediff-patch + "r" #'diff-restrict-view + "R" #'diff-reverse-direction + "<remap> <undo>" #'diff-undo) + +(defvar-keymap diff-mode-map + :doc "Keymap for `diff-mode'. See also `diff-mode-shared-map'." + "ESC" (let ((map (define-keymap :parent diff-mode-shared-map))) + ;; We want to inherit most bindings from + ;; `diff-mode-shared-map', but not all since they may hide + ;; useful `M-<foo>' global bindings when editing. + (dolist (key '("A" "r" "R" "g" "q" "W" "z")) + (keymap-set map key nil)) + map) + ;; From compilation-minor-mode. + "C-c C-c" #'diff-goto-source + ;; By analogy with the global C-x 4 a binding. + "C-x 4 A" #'diff-add-change-log-entries-other-window + ;; Misc operations. + "C-c C-a" #'diff-apply-hunk + "C-c C-e" #'diff-ediff-patch + "C-c C-n" #'diff-restrict-view + "C-c C-s" #'diff-split-hunk + "C-c C-t" #'diff-test-hunk + "C-c C-r" #'diff-reverse-direction + "C-c C-u" #'diff-context->unified + ;; `d' because it duplicates the context :-( --Stef + "C-c C-d" #'diff-unified->context + "C-c C-w" #'diff-ignore-whitespace-hunk + ;; `l' because it "refreshes" the hunk like C-l refreshes the screen + "C-c C-l" #'diff-refresh-hunk + "C-c C-b" #'diff-refine-hunk ;No reason for `b' :-( + "C-c C-f" #'next-error-follow-minor-mode) (easy-menu-define diff-mode-menu diff-mode-map "Menu for `diff-mode'." @@ -267,11 +266,12 @@ and hunk-based syntax highlighting otherwise as a fallback." (defcustom diff-minor-mode-prefix "\C-c=" "Prefix key for `diff-minor-mode' commands." - :type '(choice (string "\e") (string "C-c=") string)) + :type '(choice (string "ESC") + (string "\C-c=") string)) -(easy-mmode-defmap diff-minor-mode-map - `((,diff-minor-mode-prefix . ,diff-mode-shared-map)) - "Keymap for `diff-minor-mode'. See also `diff-mode-shared-map'.") +(defvar-keymap diff-minor-mode-map + :doc "Keymap for `diff-minor-mode'. See also `diff-mode-shared-map'." + (key-description diff-minor-mode-prefix) diff-mode-shared-map) (define-minor-mode diff-auto-refine-mode "Toggle automatic diff hunk finer highlighting (Diff Auto Refine mode). @@ -894,6 +894,9 @@ data such as \"Index: ...\" and such." ;; Fix the original hunk-header. (diff-fixup-modifs start pos)))) +(defun diff--outline-level () + (if (string-match-p diff-hunk-header-re (match-string 0)) + 2 1)) ;;;; ;;;; jump to other buffers @@ -1494,7 +1497,6 @@ a diff with \\[diff-reverse-direction]. (setq-local font-lock-defaults diff-font-lock-defaults) (add-hook 'font-lock-mode-hook #'diff--font-lock-cleanup nil 'local) - (setq-local outline-regexp diff-outline-regexp) (setq-local imenu-generic-expression diff-imenu-generic-expression) ;; These are not perfect. They would be better done separately for @@ -1539,11 +1541,7 @@ a diff with \\[diff-reverse-direction]. #'diff--filter-substring) (unless buffer-file-name (hack-dir-local-variables-non-file-buffer)) - (save-excursion - (setq-local diff-buffer-type - (if (re-search-forward "^diff --git" nil t) - 'git - nil)))) + (diff-setup-buffer-type)) ;;;###autoload (define-minor-mode diff-minor-mode @@ -1579,6 +1577,21 @@ modified lines of the diff." "^[-+!] .*?\\([\t ]+\\)$" "^[-+!<>].*?\\([\t ]+\\)$")))) +(defun diff-setup-buffer-type () + "Try to guess the `diff-buffer-type' from content of current Diff mode buffer. +`outline-regexp' is updated accordingly." + (save-excursion + (goto-char (point-min)) + (setq-local diff-buffer-type + (if (re-search-forward "^diff --git" nil t) + 'git + nil))) + (when (eq diff-buffer-type 'git) + (setq diff-outline-regexp + (concat "\\(^diff --git.*\n\\|" diff-hunk-header-re "\\)")) + (setq-local outline-level #'diff--outline-level)) + (setq-local outline-regexp diff-outline-regexp)) + (defun diff-delete-if-empty () ;; An empty diff file means there's no more diffs to integrate, so we ;; can just remove the file altogether. Very handy for .rej files if we @@ -2603,13 +2616,15 @@ fixed, visit it in a buffer." (or (match-beginning 2) (match-beginning 1)) 'display (propertize (cond - ((null (match-beginning 1)) "new file ") - ((null (match-beginning 2)) "deleted ") - (t "modified ")) + ((null (match-beginning 1)) + (concat "new file " (match-string 2))) + ((null (match-beginning 2)) + (concat "deleted " (match-string 1))) + (t + (concat "modified " (match-string 1)))) 'face '(diff-file-header diff-header))) - (unless (match-beginning 2) - (put-text-property (match-end 1) (1- (match-end 0)) - 'display ""))))) + (put-text-property (match-end 1) (1- (match-end 0)) + 'display "")))) nil) ;;; Syntax highlighting from font-lock diff --git a/lisp/vc/diff.el b/lisp/vc/diff.el index 352fa693ffb..4061fedd578 100644 --- a/lisp/vc/diff.el +++ b/lisp/vc/diff.el @@ -96,15 +96,15 @@ Non-interactively, OLD and NEW may each be a file or a buffer." (interactive (let* ((newf (if (and buffer-file-name (file-exists-p buffer-file-name)) (read-file-name - (concat "Diff new file (default " - (file-name-nondirectory buffer-file-name) "): ") + (format-prompt "Diff new file" + (file-name-nondirectory buffer-file-name)) nil buffer-file-name t) (read-file-name "Diff new file: " nil nil t))) (oldf (file-newest-backup newf))) (setq oldf (if (and oldf (file-exists-p oldf)) (read-file-name - (concat "Diff original file (default " - (file-name-nondirectory oldf) "): ") + (format-prompt "Diff original file" + (file-name-nondirectory oldf)) (file-name-directory oldf) oldf t) (read-file-name "Diff original file: " (file-name-directory newf) nil t))) diff --git a/lisp/vc/ediff-help.el b/lisp/vc/ediff-help.el index 0450cd7f23b..48e1f15f05c 100644 --- a/lisp/vc/ediff-help.el +++ b/lisp/vc/ediff-help.el @@ -227,7 +227,9 @@ the value of this variable and the variables `ediff-help-message-*' in ((string= cmd "s") (re-search-forward "^['`‘]s['’]")) ((string= cmd "+") (re-search-forward "^['`‘]\\+['’]")) ((string= cmd "=") (re-search-forward "^['`‘]=['’]")) - (t (user-error "Undocumented command! Type `G' in Ediff Control Panel to drop a note to the Ediff maintainer"))) + (t (user-error (substitute-command-keys + "Undocumented command! Type \\`G' in Ediff Control \ +Panel to drop a note to the Ediff maintainer")))) ) ; let case-fold-search )) diff --git a/lisp/vc/ediff-init.el b/lisp/vc/ediff-init.el index eaccb7a98c7..4b352bd34fc 100644 --- a/lisp/vc/ediff-init.el +++ b/lisp/vc/ediff-init.el @@ -615,8 +615,8 @@ Actually, Ediff restores the scope of visibility that existed at startup.") (defcustom ediff-keep-variants t "Nil means prompt to remove unmodified buffers A/B/C at session end. -Supplying a prefix argument to the quit command `q' temporarily reverses the -meaning of this variable." +Supplying a prefix argument to the quit command \\`q' temporarily +reverses the meaning of this variable." :type 'boolean :group 'ediff) diff --git a/lisp/vc/ediff-ptch.el b/lisp/vc/ediff-ptch.el index 4135e8b4702..a03c6a5ed7e 100644 --- a/lisp/vc/ediff-ptch.el +++ b/lisp/vc/ediff-ptch.el @@ -415,7 +415,9 @@ other files, enter `/dev/null'. (with-output-to-temp-buffer ediff-msg-buffer (ediff-with-current-buffer standard-output (fundamental-mode)) - (princ (format-message " + (with-current-buffer standard-output + (insert (format-message + (substitute-command-keys " Ediff has inferred that %s %s @@ -423,10 +425,10 @@ are two possible targets for applying the patch. Both files seem to be plausible alternatives. Please advise: - Type `y' to use %s as the target; - Type `n' to use %s as the target. -" - file1 file2 file1 file2))) + Type \\`y' to use %s as the target; + Type \\`n' to use %s as the target. +") + file1 file2 file1 file2)))) (setcar session-file-object (if (y-or-n-p (format "Use %s ? " file1)) (progn @@ -503,15 +505,11 @@ are two possible targets for this %spatch. However, these files do not exist." patch-file-name) (setq patch-file-name (read-file-name - (format "Patch is in file%s: " - (cond ((and buffer-file-name - (equal (expand-file-name dir) - (file-name-directory buffer-file-name))) - (concat - " (default " - (file-name-nondirectory buffer-file-name) - ")")) - (t ""))) + (format-prompt "Patch is in file" + (and buffer-file-name + (equal (expand-file-name dir) + (file-name-directory buffer-file-name)) + (file-name-nondirectory buffer-file-name))) dir buffer-file-name 'must-match)) (if (file-directory-p patch-file-name) (error "Patch file cannot be a directory: %s" patch-file-name) @@ -827,7 +825,8 @@ you can still examine the changes via M-x ediff-files" ediff-patch-diagnostics patch-diagnostics)) (bury-buffer patch-diagnostics) - (message "Type `P', if you need to see patch diagnostics") + (message (substitute-command-keys + "Type \\`P', if you need to see patch diagnostics")) ctl-buf)) (defun ediff-multi-patch-internal (patch-buf &optional startup-hooks) diff --git a/lisp/vc/ediff-util.el b/lisp/vc/ediff-util.el index c12de02e49f..c2b08bd31af 100644 --- a/lisp/vc/ediff-util.el +++ b/lisp/vc/ediff-util.el @@ -3121,11 +3121,7 @@ Hit \\[ediff-recenter] to reset the windows afterward." (lambda () (when defaults (setq minibuffer-default defaults))) (read-file-name - (format "%s%s " - prompt - (cond (default-file - (concat " (default " default-file "):")) - (t (concat " (default " default-dir "):")))) + (format-prompt prompt (or default-file default-dir)) default-dir (or default-file default-dir) t ; must match, no-confirm diff --git a/lisp/vc/ediff.el b/lisp/vc/ediff.el index 97c84ae5a18..cb4c8d93052 100644 --- a/lisp/vc/ediff.el +++ b/lisp/vc/ediff.el @@ -1558,7 +1558,9 @@ With optional NODE, goes to that node." (info "ediff") (if node (Info-goto-node node) - (message "Type `i' to search for a specific topic")) + (message (substitute-command-keys + (concat "Type \\<Info-mode-map>\\[Info-index] to" + " search for a specific topic")))) (raise-frame)) (error (beep 1) (with-output-to-temp-buffer ediff-msg-buffer diff --git a/lisp/vc/log-edit.el b/lisp/vc/log-edit.el index 4d151d555cc..6e3f302263b 100644 --- a/lisp/vc/log-edit.el +++ b/lisp/vc/log-edit.el @@ -54,21 +54,19 @@ (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) - ("\C-c\C-w" . log-edit-generate-changelog-from-diff) - ("\C-c\C-d" . log-edit-show-diff) - ("\C-c\C-f" . log-edit-show-files) - ("\C-c\C-k" . log-edit-kill-buffer) - ("\C-a" . log-edit-beginning-of-line) - ("\M-n" . log-edit-next-comment) - ("\M-p" . log-edit-previous-comment) - ("\M-r" . log-edit-comment-search-backward) - ("\M-s" . log-edit-comment-search-forward) - ("\C-c?" . log-edit-mode-help)) - "Keymap for the `log-edit-mode' (to edit version control log messages)." - :group 'log-edit) +(defvar-keymap log-edit-mode-map + "C-c C-c" #'log-edit-done + "C-c C-a" #'log-edit-insert-changelog + "C-c C-w" #'log-edit-generate-changelog-from-diff + "C-c C-d" #'log-edit-show-diff + "C-c C-f" #'log-edit-show-files + "C-c C-k" #'log-edit-kill-buffer + "C-a" #'log-edit-beginning-of-line + "M-n" #'log-edit-next-comment + "M-p" #'log-edit-previous-comment + "M-r" #'log-edit-comment-search-backward + "M-s" #'log-edit-comment-search-forward + "C-c ?" #'log-edit-mode-help) (easy-menu-define log-edit-menu log-edit-mode-map "Menu used for `log-edit-mode'." diff --git a/lisp/vc/log-view.el b/lisp/vc/log-view.el index c2f008fc47d..d45c1696a2f 100644 --- a/lisp/vc/log-view.el +++ b/lisp/vc/log-view.el @@ -110,6 +110,7 @@ ;;; Code: (require 'pcvs-util) +(require 'easy-mmode) (autoload 'vc-find-revision "vc") (autoload 'vc-diff-internal "vc") @@ -121,39 +122,23 @@ :group 'pcl-cvs :prefix "log-view-") -(easy-mmode-defmap log-view-mode-map - '( - ("-" . negative-argument) - ("0" . digit-argument) - ("1" . digit-argument) - ("2" . digit-argument) - ("3" . digit-argument) - ("4" . digit-argument) - ("5" . digit-argument) - ("6" . digit-argument) - ("7" . digit-argument) - ("8" . digit-argument) - ("9" . digit-argument) - - ("\C-m" . log-view-toggle-entry-display) - ("m" . log-view-toggle-mark-entry) - ("e" . log-view-modify-change-comment) - ("d" . log-view-diff) - ("=" . log-view-diff) - ("D" . log-view-diff-changeset) - ("a" . log-view-annotate-version) - ("f" . log-view-find-revision) - ("n" . log-view-msg-next) - ("p" . log-view-msg-prev) - ("\t" . log-view-msg-next) - ([backtab] . log-view-msg-prev) - ("N" . log-view-file-next) - ("P" . log-view-file-prev) - ("\M-n" . log-view-file-next) - ("\M-p" . log-view-file-prev)) - "Log-View's keymap." - :inherit special-mode-map - :group 'log-view) +(defvar-keymap log-view-mode-map + "RET" #'log-view-toggle-entry-display + "m" #'log-view-toggle-mark-entry + "e" #'log-view-modify-change-comment + "d" #'log-view-diff + "=" #'log-view-diff + "D" #'log-view-diff-changeset + "a" #'log-view-annotate-version + "f" #'log-view-find-revision + "n" #'log-view-msg-next + "p" #'log-view-msg-prev + "TAB" #'log-view-msg-next + "<backtab>" #'log-view-msg-prev + "N" #'log-view-file-next + "P" #'log-view-file-prev + "M-n" #'log-view-file-next + "M-p" #'log-view-file-prev) (easy-menu-define log-view-mode-menu log-view-mode-map "Log-View Display Menu." diff --git a/lisp/vc/pcvs-defs.el b/lisp/vc/pcvs-defs.el index 54ef06960f9..c3109f7e85b 100644 --- a/lisp/vc/pcvs-defs.el +++ b/lisp/vc/pcvs-defs.el @@ -264,160 +264,6 @@ This variable is buffer local and only used in the *cvs* buffer.") (defconst cvs-vendor-branch "1.1.1" "The default branch used by CVS for vendor code.") -(easy-mmode-defmap cvs-mode-diff-map - '(("E" "imerge" . cvs-mode-imerge) - ("=" . cvs-mode-diff) - ("e" "idiff" . cvs-mode-idiff) - ("2" "other" . cvs-mode-idiff-other) - ("d" "diff" . cvs-mode-diff) - ("b" "backup" . cvs-mode-diff-backup) - ("h" "head" . cvs-mode-diff-head) - ("r" "repository" . cvs-mode-diff-repository) - ("y" "yesterday" . cvs-mode-diff-yesterday) - ("v" "vendor" . cvs-mode-diff-vendor)) - "Keymap for diff-related operations in `cvs-mode'." - :name "Diff") -;; This is necessary to allow correct handling of \\[cvs-mode-diff-map] -;; in substitute-command-keys. -(fset 'cvs-mode-diff-map cvs-mode-diff-map) - -(easy-mmode-defmap cvs-mode-map - ;;(define-prefix-command 'cvs-mode-map-diff-prefix) - ;;(define-prefix-command 'cvs-mode-map-control-c-prefix) - '(;; various - ;; (undo . cvs-mode-undo) - ("?" . cvs-help) - ("h" . cvs-help) - ("q" . cvs-bury-buffer) - ("z" . kill-this-buffer) - ("F" . cvs-mode-set-flags) - ;; ("\M-f" . cvs-mode-force-command) - ("!" . cvs-mode-force-command) - ("\C-c\C-c" . cvs-mode-kill-process) - ;; marking - ("m" . cvs-mode-mark) - ("M" . cvs-mode-mark-all-files) - ("S" . cvs-mode-mark-on-state) - ("u" . cvs-mode-unmark) - ("\C-?". cvs-mode-unmark-up) - ("%" . cvs-mode-mark-matching-files) - ("T" . cvs-mode-toggle-marks) - ("\M-\C-?" . cvs-mode-unmark-all-files) - ;; navigation keys - (" " . cvs-mode-next-line) - ("n" . cvs-mode-next-line) - ("p" . cvs-mode-previous-line) - ("\t" . cvs-mode-next-line) - ([backtab] . cvs-mode-previous-line) - ;; M- keys are usually those that operate on modules - ;;("\M-C". cvs-mode-rcs2log) ; i.e. "Create a ChangeLog" - ;;("\M-t". cvs-rtag) - ;;("\M-l". cvs-rlog) - ("\M-c". cvs-checkout) - ("\M-e". cvs-examine) - ("g" . cvs-mode-revert-buffer) - ("\M-u". cvs-update) - ("\M-s". cvs-status) - ;; diff commands - ("=" . cvs-mode-diff) - ("d" . cvs-mode-diff-map) - ;; keys that operate on individual files - ("\C-k" . cvs-mode-acknowledge) - ("A" . cvs-mode-add-change-log-entry-other-window) - ;;("B" . cvs-mode-byte-compile-files) - ("C" . cvs-mode-commit-setup) - ("O" . cvs-mode-update) - ("U" . cvs-mode-undo) - ("I" . cvs-mode-insert) - ("a" . cvs-mode-add) - ("b" . cvs-set-branch-prefix) - ("B" . cvs-set-secondary-branch-prefix) - ("c" . cvs-mode-commit) - ("e" . cvs-mode-examine) - ("f" . cvs-mode-find-file) - ("\C-m" . cvs-mode-find-file) - ("i" . cvs-mode-ignore) - ("l" . cvs-mode-log) - ("o" . cvs-mode-find-file-other-window) - ("r" . cvs-mode-remove) - ("s" . cvs-mode-status) - ("t" . cvs-mode-tag) - ("v" . cvs-mode-view-file) - ("x" . cvs-mode-remove-handled) - ;; cvstree bindings - ("+" . cvs-mode-tree) - ;; mouse bindings - ([mouse-2] . cvs-mode-find-file) - ([follow-link] . (lambda (pos) - (if (eq (get-char-property pos 'face) 'cvs-filename) t))) - ([(down-mouse-3)] . cvs-menu) - ;; dired-like bindings - ("\C-o" . cvs-mode-display-file) - ;; Emacs-21 toolbar - ;;([tool-bar item1] . (menu-item "Examine" cvs-examine :image (image :file "/usr/share/icons/xpaint.xpm" :type xpm))) - ;;([tool-bar item2] . (menu-item "Update" cvs-update :image (image :file "/usr/share/icons/mail1.xpm" :type xpm))) - ) - "Keymap for `cvs-mode'." - :dense t - :suppress t) - -(fset 'cvs-mode-map cvs-mode-map) - -(easy-menu-define cvs-menu cvs-mode-map "Menu used in `cvs-mode'." - '("CVS" - ["Open file" cvs-mode-find-file t] - ["Open in other window" cvs-mode-find-file-other-window t] - ["Display in other window" cvs-mode-display-file t] - ["Interactive merge" cvs-mode-imerge t] - ("View diff" - ["Interactive diff" cvs-mode-idiff t] - ["Current diff" cvs-mode-diff t] - ["Diff with head" cvs-mode-diff-head t] - ["Diff with vendor" cvs-mode-diff-vendor t] - ["Diff against yesterday" cvs-mode-diff-yesterday t] - ["Diff with backup" cvs-mode-diff-backup t]) - ["View log" cvs-mode-log t] - ["View status" cvs-mode-status t] - ["View tag tree" cvs-mode-tree t] - "----" - ["Insert" cvs-mode-insert] - ["Update" cvs-mode-update (cvs-enabledp 'update)] - ["Re-examine" cvs-mode-examine t] - ["Commit" cvs-mode-commit-setup (cvs-enabledp 'commit)] - ["Tag" cvs-mode-tag (cvs-enabledp (when cvs-force-dir-tag 'tag))] - ["Undo changes" cvs-mode-undo (cvs-enabledp 'undo)] - ["Add" cvs-mode-add (cvs-enabledp 'add)] - ["Remove" cvs-mode-remove (cvs-enabledp 'remove)] - ["Ignore" cvs-mode-ignore (cvs-enabledp 'ignore)] - ["Add ChangeLog" cvs-mode-add-change-log-entry-other-window t] - "----" - ["Mark" cvs-mode-mark t] - ["Mark all" cvs-mode-mark-all-files t] - ["Mark by regexp..." cvs-mode-mark-matching-files t] - ["Mark by state..." cvs-mode-mark-on-state t] - ["Unmark" cvs-mode-unmark t] - ["Unmark all" cvs-mode-unmark-all-files t] - ["Hide handled" cvs-mode-remove-handled t] - "----" - ["PCL-CVS Manual" (lambda () (interactive) - (info "(pcl-cvs)Top")) t] - "----" - ["Quit" cvs-mode-quit t])) - -;;;; -;;;; CVS-Minor mode -;;;; - -(defcustom cvs-minor-mode-prefix "\C-xc" - "Prefix key for the `cvs-mode' bindings in `cvs-minor-mode'." - :type 'string) - -(easy-mmode-defmap cvs-minor-mode-map - `((,cvs-minor-mode-prefix . cvs-mode-map) - ("e" . (menu-item nil cvs-mode-edit-log - :filter (lambda (x) (if (derived-mode-p 'log-view-mode) x))))) - "Keymap for `cvs-minor-mode', used in buffers related to PCL-CVS.") - (defvar cvs-buffer nil "(Buffer local) The *cvs* buffer associated with this buffer.") (put 'cvs-buffer 'permanent-local t) diff --git a/lisp/vc/pcvs.el b/lisp/vc/pcvs.el index bbc81ef195d..2d7b8cb2ef7 100644 --- a/lisp/vc/pcvs.el +++ b/lisp/vc/pcvs.el @@ -117,11 +117,11 @@ (require 'cl-lib) (require 'ewoc) ;Ewoc was once cookie -(require 'pcvs-defs) (require 'pcvs-util) (require 'pcvs-parse) (require 'pcvs-info) (require 'vc-cvs) +(require 'easy-mmode) ;;;; @@ -138,6 +138,147 @@ (defvar cvs-from-vc nil "Bound to t inside VC advice.") +(defvar-keymap cvs-mode-diff-map + :name "Diff" + "E" (cons "imerge" #'cvs-mode-imerge) + "=" #'cvs-mode-diff + "e" (cons "idiff" #'cvs-mode-idiff) + "2" (cons "other" #'cvs-mode-idiff-other) + "d" (cons "diff" #'cvs-mode-diff) + "b" (cons "backup" #'cvs-mode-diff-backup) + "h" (cons "head" #'cvs-mode-diff-head) + "r" (cons "repository" #'cvs-mode-diff-repository) + "y" (cons "yesterday" #'cvs-mode-diff-yesterday) + "v" (cons "vendor" #'cvs-mode-diff-vendor)) +;; This is necessary to allow correct handling of \\[cvs-mode-diff-map] +;; in substitute-command-keys. +(fset 'cvs-mode-diff-map cvs-mode-diff-map) + +(defvar-keymap cvs-mode-map + :full t + :suppress t + ;; various + "?" #'cvs-help + "h" #'cvs-help + "q" #'cvs-bury-buffer + "z" #'kill-this-buffer + "F" #'cvs-mode-set-flags + "!" #'cvs-mode-force-command + "C-c C-c" #'cvs-mode-kill-process + ;; marking + "m" #'cvs-mode-mark + "M" #'cvs-mode-mark-all-files + "S" #'cvs-mode-mark-on-state + "u" #'cvs-mode-unmark + "DEL" #'cvs-mode-unmark-up + "%" #'cvs-mode-mark-matching-files + "T" #'cvs-mode-toggle-marks + "M-DEL" #'cvs-mode-unmark-all-files + ;; navigation keys + "SPC" #'cvs-mode-next-line + "n" #'cvs-mode-next-line + "p" #'cvs-mode-previous-line + "TAB" #'cvs-mode-next-line + "<backtab>" #'cvs-mode-previous-line + ;; M- keys are usually those that operate on modules + "M-c" #'cvs-checkout + "M-e" #'cvs-examine + "g" #'cvs-mode-revert-buffer + "M-u" #'cvs-update + "M-s" #'cvs-status + ;; diff commands + "=" #'cvs-mode-diff + "d" cvs-mode-diff-map + ;; keys that operate on individual files + "C-k" #'cvs-mode-acknowledge + "A" #'cvs-mode-add-change-log-entry-other-window + "C" #'cvs-mode-commit-setup + "O" #'cvs-mode-update + "U" #'cvs-mode-undo + "I" #'cvs-mode-insert + "a" #'cvs-mode-add + "b" #'cvs-set-branch-prefix + "B" #'cvs-set-secondary-branch-prefix + "c" #'cvs-mode-commit + "e" #'cvs-mode-examine + "f" #'cvs-mode-find-file + "RET" #'cvs-mode-find-file + "i" #'cvs-mode-ignore + "l" #'cvs-mode-log + "o" #'cvs-mode-find-file-other-window + "r" #'cvs-mode-remove + "s" #'cvs-mode-status + "t" #'cvs-mode-tag + "v" #'cvs-mode-view-file + "x" #'cvs-mode-remove-handled + ;; cvstree bindings + "+" #'cvs-mode-tree + ;; mouse bindings + "<mouse-2>" #'cvs-mode-find-file + "<follow-link>" (lambda (pos) + (eq (get-char-property pos 'face) 'cvs-filename)) + "<down-mouse-3>" #'cvs-menu + ;; dired-like bindings + "C-o" #'cvs-mode-display-file) + +(easy-menu-define cvs-menu cvs-mode-map "Menu used in `cvs-mode'." + '("CVS" + ["Open file" cvs-mode-find-file t] + ["Open in other window" cvs-mode-find-file-other-window t] + ["Display in other window" cvs-mode-display-file t] + ["Interactive merge" cvs-mode-imerge t] + ("View diff" + ["Interactive diff" cvs-mode-idiff t] + ["Current diff" cvs-mode-diff t] + ["Diff with head" cvs-mode-diff-head t] + ["Diff with vendor" cvs-mode-diff-vendor t] + ["Diff against yesterday" cvs-mode-diff-yesterday t] + ["Diff with backup" cvs-mode-diff-backup t]) + ["View log" cvs-mode-log t] + ["View status" cvs-mode-status t] + ["View tag tree" cvs-mode-tree t] + "----" + ["Insert" cvs-mode-insert] + ["Update" cvs-mode-update (cvs-enabledp 'update)] + ["Re-examine" cvs-mode-examine t] + ["Commit" cvs-mode-commit-setup (cvs-enabledp 'commit)] + ["Tag" cvs-mode-tag (cvs-enabledp (when cvs-force-dir-tag 'tag))] + ["Undo changes" cvs-mode-undo (cvs-enabledp 'undo)] + ["Add" cvs-mode-add (cvs-enabledp 'add)] + ["Remove" cvs-mode-remove (cvs-enabledp 'remove)] + ["Ignore" cvs-mode-ignore (cvs-enabledp 'ignore)] + ["Add ChangeLog" cvs-mode-add-change-log-entry-other-window t] + "----" + ["Mark" cvs-mode-mark t] + ["Mark all" cvs-mode-mark-all-files t] + ["Mark by regexp..." cvs-mode-mark-matching-files t] + ["Mark by state..." cvs-mode-mark-on-state t] + ["Unmark" cvs-mode-unmark t] + ["Unmark all" cvs-mode-unmark-all-files t] + ["Hide handled" cvs-mode-remove-handled t] + "----" + ["PCL-CVS Manual" (lambda () (interactive) + (info "(pcl-cvs)Top")) t] + "----" + ["Quit" cvs-mode-quit t])) + +;;;; +;;;; CVS-Minor mode +;;;; + +(defcustom cvs-minor-mode-prefix "\C-xc" + "Prefix key for the `cvs-mode' bindings in `cvs-minor-mode'." + :type 'string + :group 'pcl-cvs) + +(defvar-keymap cvs-minor-mode-map + (key-description cvs-minor-mode-prefix) 'cvs-mode-map + "e" '(menu-item nil cvs-mode-edit-log + :filter (lambda (x) + (and (derived-mode-p 'log-view-mode) x)))) + +(require 'pcvs-defs) + ;;;; ;;;; flags variables ;;;; @@ -758,6 +899,7 @@ clear what alternative to use. - `DOUBLE' is the generic case." (declare (debug (&define sexp lambda-list stringp ("interactive" interactive) def-body)) + (indent defun) (doc-string 3)) (let ((style (cvs-cdr fun)) (fun (cvs-car fun))) @@ -1284,8 +1426,7 @@ marked instead. A directory can never be marked." (intern (upcase (completing-read - (concat - "Mark files in state" (if default (concat " [" default "]")) ": ") + (format-prompt "Mark files in state" default) (mapcar (lambda (x) (list (downcase (symbol-name (car x))))) cvs-states) diff --git a/lisp/vc/smerge-mode.el b/lisp/vc/smerge-mode.el index b2a875c81ff..6c1b8cc95b3 100644 --- a/lisp/vc/smerge-mode.el +++ b/lisp/vc/smerge-mode.el @@ -47,6 +47,7 @@ (require 'diff) ;For diff-check-labels. (require 'diff-mode) ;For diff-refine. (require 'newcomment) +(require 'easy-mmode) ;;; The real definition comes later. (defvar smerge-mode) @@ -142,36 +143,34 @@ Used in `smerge-diff-base-upper' and related functions." "Face used for added characters shown by `smerge-refine'." :version "24.3") -(easy-mmode-defmap smerge-basic-map - `(("n" . smerge-next) - ("p" . smerge-prev) - ("r" . smerge-resolve) - ("a" . smerge-keep-all) - ("b" . smerge-keep-base) - ("o" . smerge-keep-lower) ; for the obsolete keep-other - ("l" . smerge-keep-lower) - ("m" . smerge-keep-upper) ; for the obsolete keep-mine - ("u" . smerge-keep-upper) - ("E" . smerge-ediff) - ("C" . smerge-combine-with-next) - ("R" . smerge-refine) - ("\C-m" . smerge-keep-current) - ("=" . ,(make-sparse-keymap "Diff")) - ("=<" "base-upper" . smerge-diff-base-upper) - ("=>" "base-lower" . smerge-diff-base-lower) - ("==" "upper-lower" . smerge-diff-upper-lower)) - "The base keymap for `smerge-mode'.") +(defvar-keymap smerge-basic-map + "n" #'smerge-next + "p" #'smerge-prev + "r" #'smerge-resolve + "a" #'smerge-keep-all + "b" #'smerge-keep-base + "o" #'smerge-keep-lower ; for the obsolete keep-other + "l" #'smerge-keep-lower + "m" #'smerge-keep-upper ; for the obsolete keep-mine + "u" #'smerge-keep-upper + "E" #'smerge-ediff + "C" #'smerge-combine-with-next + "R" #'smerge-refine + "C-m" #'smerge-keep-current + "=" (define-keymap :name "Diff" + "<" (cons "base-upper" #'smerge-diff-base-upper) + ">" (cons "base-lower" #'smerge-diff-base-lower) + "=" (cons "upper-lower" #'smerge-diff-upper-lower))) (defcustom smerge-command-prefix "\C-c^" "Prefix for `smerge-mode' commands." :type '(choice (const :tag "ESC" "\e") - (const :tag "C-c ^" "\C-c^" ) + (const :tag "C-c ^" "\C-c^") (const :tag "none" "") string)) -(easy-mmode-defmap smerge-mode-map - `((,smerge-command-prefix . ,smerge-basic-map)) - "Keymap for `smerge-mode'.") +(defvar-keymap smerge-mode-map + (key-description smerge-command-prefix) smerge-basic-map) (defvar-local smerge-check-cache nil) (defun smerge-check (n) diff --git a/lisp/vc/vc-cvs.el b/lisp/vc/vc-cvs.el index 6f921ac2a04..c8954472245 100644 --- a/lisp/vc/vc-cvs.el +++ b/lisp/vc/vc-cvs.el @@ -309,10 +309,11 @@ to the CVS command." (defun vc-cvs-responsible-p (file) "Return non-nil if CVS thinks it is responsible for FILE." - (file-directory-p (expand-file-name "CVS" - (if (file-directory-p file) - file - (file-name-directory file))))) + (let ((dir (if (file-directory-p file) + file + (file-name-directory file)))) + (and (file-directory-p (expand-file-name "CVS" dir)) + (file-name-directory (expand-file-name "CVS" dir))))) (defun vc-cvs-could-register (file) "Return non-nil if FILE could be registered in CVS. diff --git a/lisp/vc/vc-dav.el b/lisp/vc/vc-dav.el index fe631ee09a7..49a8af10e78 100644 --- a/lisp/vc/vc-dav.el +++ b/lisp/vc/vc-dav.el @@ -136,10 +136,10 @@ It should return a status of either 0 (no differences found), or "Find the version control state of all files in DIR in a fast way." ) -(defun vc-dav-responsible-p (_url) +(defun vc-dav-responsible-p (url) "Return non-nil if DAV considers itself `responsible' for URL." ;; Check for DAV support on the web server. - t) + (and t url)) ;;; Unimplemented functions ;; diff --git a/lisp/vc/vc-dir.el b/lisp/vc/vc-dir.el index 8165d5e09f1..32e492171d3 100644 --- a/lisp/vc/vc-dir.el +++ b/lisp/vc/vc-dir.el @@ -1427,7 +1427,12 @@ These are the commands available for use in the file status buffer: (vc-dir-refresh) ;; FIXME: find a better way to pass the backend to `vc-dir-mode'. (let ((use-vc-backend backend)) - (vc-dir-mode)))) + (vc-dir-mode) + ;; Activate the backend-specific minor mode, if any. + (when-let ((minor-mode + (intern-soft (format "vc-dir-%s-mode" + (downcase (symbol-name backend)))))) + (funcall minor-mode 1))))) (defun vc-default-dir-extra-headers (_backend _dir) ;; Be loud by default to remind people to add code to display diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 2d35061b269..5c6a39aec96 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -298,12 +298,14 @@ included in the completions." (vc-git--run-command-string nil "version"))) (setq vc-git--program-version (if (and version-string - ;; Git for Windows appends ".windows.N" to the - ;; numerical version reported by Git. - (string-match - "git version \\([0-9.]+\\)\\(\\.windows\\.[0-9]+\\)?$" - version-string)) - (match-string 1 version-string) + ;; Some Git versions append additional strings + ;; to the numerical version string. E.g., Git + ;; for Windows appends ".windows.N", while Git + ;; for Mac appends " (Apple Git-N)". Capture + ;; numerical version and ignore the rest. + (string-match "git version \\([0-9][0-9.]+\\)" + version-string)) + (string-trim-right (match-string 1 version-string) "\\.") "0"))))) (defun vc-git--git-status-to-vc-state (code-list) @@ -1688,7 +1690,7 @@ This command shares argument histories with \\[rgrep] and \\[grep]." (let ((stash (completing-read prompt (split-string - (or (vc-git--run-command-string nil "stash" "list") "") "\n") + (or (vc-git--run-command-string nil "stash" "list") "") "\n" t) nil :require-match nil 'vc-git-stash-read-history))) (if (string-equal stash "") (user-error "Not a stash") @@ -1733,12 +1735,11 @@ This command shares argument histories with \\[rgrep] and \\[grep]." (defun vc-git-stash-list () (when-let ((out (vc-git--run-command-string nil "stash" "list"))) - (delete - "" - (split-string - (replace-regexp-in-string - "^stash@" " " out) - "\n")))) + (split-string + (replace-regexp-in-string + "^stash@" " " out) + "\n" + t))) (defun vc-git-stash-get-at-point (point) (save-excursion @@ -1871,6 +1872,17 @@ Returns nil if not possible." (1- (point-max))))))) (and name (not (string= name "undefined")) name)))) +(defvar-keymap vc-dir-git-mode-map + "z c" #'vc-git-stash + "z s" #'vc-git-stash-snapshot + "z p" #'vc-git-stash-pop) + +(define-minor-mode vc-dir-git-mode + "A minor mode for git-specific commands in `vc-dir-mode' buffers. +Also note that there are git stash commands available in the +\"Stash\" section at the head of the buffer." + :lighter " Git") + (provide 'vc-git) ;;; vc-git.el ends here diff --git a/lisp/vc/vc-hg.el b/lisp/vc/vc-hg.el index 0ed9f7c31fe..6bec9edbf35 100644 --- a/lisp/vc/vc-hg.el +++ b/lisp/vc/vc-hg.el @@ -672,7 +672,6 @@ Return the byte's value as an integer." (let* ((result nil) (flen (length fname)) (case-fold-search nil) - (inhibit-changing-match-data t) ;; Find a conservative bound for the loop below by using ;; Boyer-Moore on the raw dirstate without parsing it; we ;; know we can't possibly find fname _after_ the last place @@ -976,10 +975,9 @@ REPO must be the directory name of an hg repository." "Test whether the ignore pattern set HGIP says to ignore FILENAME. FILENAME must be the file's true absolute name." (let ((patterns (vc-hg--ignore-patterns-ignore-patterns hgip)) - (inhibit-changing-match-data t) (ignored nil)) (while (and patterns (not ignored)) - (setf ignored (string-match (pop patterns) filename))) + (setf ignored (string-match-p (pop patterns) filename))) ignored)) (defvar vc-hg--cached-ignore-patterns nil @@ -1043,7 +1041,8 @@ Avoids the need to repeatedly scan dirstate on repeated calls to (equal size (pop cache)) (equal ascii-fname (pop cache))) (pop cache) - (let ((result (vc-hg--raw-dirstate-search dirstate ascii-fname))) + (let ((result (save-match-data + (vc-hg--raw-dirstate-search dirstate ascii-fname)))) (setf vc-hg--dirstate-scan-cache (list dirstate mtime size ascii-fname result)) result)))) diff --git a/lisp/vc/vc-hooks.el b/lisp/vc/vc-hooks.el index b7760e3bba5..cd5b11d840b 100644 --- a/lisp/vc/vc-hooks.el +++ b/lisp/vc/vc-hooks.el @@ -864,7 +864,8 @@ In the latter case, VC mode is deactivated for this buffer." (defvar vc-prefix-map (let ((map (make-sparse-keymap))) (define-key map "a" #'vc-update-change-log) - (define-key map "b" #'vc-switch-backend) + (with-suppressed-warnings ((obsolete vc-switch-backend)) + (define-key map "b" #'vc-switch-backend)) (define-key map "d" #'vc-dir) (define-key map "g" #'vc-annotate) (define-key map "G" #'vc-ignore) diff --git a/lisp/vc/vc-rcs.el b/lisp/vc/vc-rcs.el index e38469ba9f0..2422e99d3da 100644 --- a/lisp/vc/vc-rcs.el +++ b/lisp/vc/vc-rcs.el @@ -290,10 +290,11 @@ to the RCS command." (defun vc-rcs-responsible-p (file) "Return non-nil if RCS thinks it would be responsible for registering FILE." ;; TODO: check for all the patterns in vc-rcs-master-templates - (file-directory-p (expand-file-name "RCS" - (if (file-directory-p file) - file - (file-name-directory file))))) + (let ((dir (if (file-directory-p file) + file + (file-name-directory file)))) + (and (file-directory-p (expand-file-name "RCS" dir)) + (file-name-directory (expand-file-name "RCS" dir))))) (defun vc-rcs-receive-file (file rev) "Implementation of receive-file for RCS." diff --git a/lisp/vc/vc-sccs.el b/lisp/vc/vc-sccs.el index bcbb87eba8e..4b56fbf28ef 100644 --- a/lisp/vc/vc-sccs.el +++ b/lisp/vc/vc-sccs.el @@ -214,9 +214,13 @@ to the SCCS command." (defun vc-sccs-responsible-p (file) "Return non-nil if SCCS thinks it would be responsible for registering FILE." ;; TODO: check for all the patterns in vc-sccs-master-templates - (or (file-directory-p (expand-file-name "SCCS" (file-name-directory file))) - (stringp (vc-sccs-search-project-dir (or (file-name-directory file) "") - (file-name-nondirectory file))))) + (or (and (file-directory-p + (expand-file-name "SCCS" (file-name-directory file))) + (file-name-directory file)) + (let ((dir (vc-sccs-search-project-dir (or (file-name-directory file) "") + (file-name-nondirectory file)))) + (and (stringp dir) + dir)))) (defun vc-sccs-checkin (files comment &optional rev) "SCCS-specific version of `vc-backend-checkin'." diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index 67003c83926..64f752f248d 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -739,6 +739,7 @@ (require 'cl-lib) (declare-function diff-setup-whitespace "diff-mode" ()) +(declare-function diff-setup-buffer-type "diff-mode" ()) (eval-when-compile (require 'dired)) @@ -937,11 +938,20 @@ repository, prompting for the directory and the VC backend to use." (catch 'found ;; First try: find a responsible backend, it must be a backend - ;; under which FILE is not yet registered. - (dolist (backend vc-handled-backends) - (and (not (vc-call-backend backend 'registered file)) - (vc-call-backend backend 'responsible-p file) - (throw 'found backend))) + ;; under which FILE is not yet registered and with the most + ;; specific path to FILE. + (let ((max 0) + bk) + (dolist (backend vc-handled-backends) + (when (not (vc-call-backend backend 'registered file)) + (let* ((dir-name (vc-call-backend backend 'responsible-p file)) + (len (and dir-name + (length (file-name-split + (expand-file-name dir-name)))))) + (when (and len (> len max)) + (setq max len bk backend))))) + (when bk + (throw 'found bk))) ;; no responsible backend (let* ((possible-backends (let (pos) @@ -969,7 +979,7 @@ use." (message "arg %s" arg) (and (file-directory-p arg) (string-prefix-p (expand-file-name arg) def-dir))))))) - (let ((default-directory repo-dir)) + (let ((default-directory repo-dir)) (vc-call-backend bk 'create-repo)) (throw 'found bk)))) @@ -1188,7 +1198,11 @@ For old-style locking-based version control systems, like RCS: *vc-log* buffer to check in the changes. Leave a read-only copy of each changed file after checking in. If every file is locked by you and unchanged, unlock them. - If every file is locked by someone else, offer to steal the lock." + If every file is locked by someone else, offer to steal the lock. + +When using this command to register a new file (or files), it +will automatically deduce which VC repository to register it +with, using the most specific one." (interactive "P") (let* ((vc-fileset (vc-deduce-fileset nil t 'state-model-only-files)) (backend (car vc-fileset)) @@ -1728,6 +1742,7 @@ to override the value of `vc-diff-switches' and `diff-switches'." (insert (cdr messages) ".\n") (message "%s" (cdr messages)))) (diff-setup-whitespace) + (diff-setup-buffer-type) (goto-char (point-min)) (when window (shrink-window-if-larger-than-buffer window))) @@ -1863,13 +1878,10 @@ Return t if the buffer had changes, nil otherwise." (vc-working-revision first)))) (when (string= rev1-default "") (setq rev1-default nil)))) ;; construct argument list - (let* ((rev1-prompt (if rev1-default - (concat "Older revision (default " - rev1-default "): ") - "Older revision: ")) - (rev2-prompt (concat "Newer revision (default " - ;; (or rev2-default - "current source): ")) + (let* ((rev1-prompt (format-prompt "Older revision" rev1-default)) + (rev2-prompt (format-prompt "Newer revision" + ;; (or rev2-default + "current source")) (rev1 (vc-read-revision rev1-prompt files backend rev1-default)) (rev2 (vc-read-revision rev2-prompt files backend nil))) ;; rev2-default (when (string= rev1 "") (setq rev1 nil)) @@ -2082,7 +2094,7 @@ If `F.~REV~' already exists, use it instead of checking it out again." (with-current-buffer (or (buffer-base-buffer) (current-buffer)) (vc-ensure-vc-buffer) (list - (vc-read-revision "Revision to visit (default is working revision): " + (vc-read-revision (format-prompt "Revision to visit" "working revision") (list buffer-file-name))))) (set-buffer (or (buffer-base-buffer) (current-buffer))) (vc-ensure-vc-buffer) @@ -2378,7 +2390,7 @@ This function runs the hook `vc-retrieve-tag-hook' when finished." (read-directory-name "Directory: " default-directory nil t)))) (list dir - (vc-read-revision "Tag name to retrieve (default latest revisions): " + (vc-read-revision (format-prompt "Tag name to retrieve" "latest revisions") (list dir) (vc-responsible-backend dir))))) (let* ((backend (vc-responsible-backend dir)) diff --git a/lisp/vcursor.el b/lisp/vcursor.el index e219dc2d1a5..df65db39e38 100644 --- a/lisp/vcursor.el +++ b/lisp/vcursor.el @@ -788,9 +788,9 @@ out how much to copy." (vcursor-check) (with-current-buffer (overlay-buffer vcursor-overlay) - (let ((start (goto-char (overlay-start vcursor-overlay)))) - (- (progn (apply func args) (point)) start))) - ) + (save-excursion + (let ((start (goto-char (overlay-start vcursor-overlay)))) + (- (progn (apply func args) (point)) start))))) ;; Make sure the virtual cursor is active. Unless arg is non-nil, ;; report an error if it is not. diff --git a/lisp/version.el b/lisp/version.el index 3a3093fdd4a..5d0a1ae37dc 100644 --- a/lisp/version.el +++ b/lisp/version.el @@ -53,6 +53,8 @@ developing Emacs.") (defvar ns-version-string) (defvar cairo-version-string) +(declare-function haiku-get-version-string "haikufns.c") + (defun emacs-version (&optional here) "Return string describing the version of Emacs that is running. If optional argument HERE is non-nil, insert string at point. @@ -71,6 +73,8 @@ to the system configuration; look at `system-configuration' instead." ((featurep 'x-toolkit) ", X toolkit") ((featurep 'ns) (format ", NS %s" ns-version-string)) + ((featurep 'haiku) + (format ", Haiku %s" (haiku-get-version-string))) (t "")) (if (featurep 'cairo) (format ", cairo version %s" cairo-version-string) diff --git a/lisp/view.el b/lisp/view.el index 3476ced3f79..321bc5f5660 100644 --- a/lisp/view.el +++ b/lisp/view.el @@ -36,8 +36,8 @@ ;;; Suggested key bindings: ;; -;; (define-key ctl-x-4-map "v" #'view-file-other-window) ; ^x4v -;; (define-key ctl-x-5-map "v" #'view-file-other-frame) ; ^x5v +;; (keymap-set ctl-x-4-map "v" #'view-file-other-window) ; C-x 4 v +;; (keymap-set ctl-x-5-map "v" #'view-file-other-frame) ; C-x 5 v ;; ;; You could also bind `view-file', `view-buffer', `view-buffer-other-window' and ;; `view-buffer-other-frame' to keys. @@ -142,68 +142,68 @@ that use View mode automatically.") (defvar-local view-overlay nil "Overlay used to display where a search operation found its match. This is local in each buffer, once it is used.") + -;; Define keymap inside defvar to make it easier to load changes. ;; Some redundant "less"-like key bindings below have been commented out. -(defvar view-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "C" #'View-kill-and-leave) - (define-key map "c" #'View-leave) - (define-key map "Q" #'View-quit-all) - (define-key map "E" #'View-exit-and-edit) - ;; (define-key map "v" #'View-exit) - (define-key map "e" #'View-exit) - (define-key map "q" #'View-quit) - ;; (define-key map "N" #'View-search-last-regexp-backward) - (define-key map "p" #'View-search-last-regexp-backward) - (define-key map "n" #'View-search-last-regexp-forward) - ;; (define-key map "?" #'View-search-regexp-backward) ; Less does this. - (define-key map "\\" #'View-search-regexp-backward) - (define-key map "/" #'View-search-regexp-forward) - (define-key map "r" #'isearch-backward) - (define-key map "s" #'isearch-forward) - (define-key map "m" #'point-to-register) - (define-key map "'" #'register-to-point) - (define-key map "x" #'exchange-point-and-mark) - (define-key map "@" #'View-back-to-mark) - (define-key map "." #'set-mark-command) - (define-key map "%" #'View-goto-percent) - ;; (define-key map "G" #'View-goto-line-last) - (define-key map "g" #'View-goto-line) - (define-key map "=" #'what-line) - (define-key map "F" #'View-revert-buffer-scroll-page-forward) - ;; (define-key map "k" #'View-scroll-line-backward) - (define-key map "y" #'View-scroll-line-backward) - ;; (define-key map "j" #'View-scroll-line-forward) - (define-key map "\n" #'View-scroll-line-forward) - (define-key map "\r" #'View-scroll-line-forward) - (define-key map "u" #'View-scroll-half-page-backward) - (define-key map "d" #'View-scroll-half-page-forward) - (define-key map "z" #'View-scroll-page-forward-set-page-size) - (define-key map "w" #'View-scroll-page-backward-set-page-size) - ;; (define-key map "b" #'View-scroll-page-backward) - (define-key map "\C-?" #'View-scroll-page-backward) - ;; (define-key map "f" #'View-scroll-page-forward) - (define-key map " " #'View-scroll-page-forward) - (define-key map [?\S-\ ] #'View-scroll-page-backward) - (define-key map "o" #'View-scroll-to-buffer-end) - (define-key map ">" #'end-of-buffer) - (define-key map "<" #'beginning-of-buffer) - (define-key map "-" #'negative-argument) - (define-key map "9" #'digit-argument) - (define-key map "8" #'digit-argument) - (define-key map "7" #'digit-argument) - (define-key map "6" #'digit-argument) - (define-key map "5" #'digit-argument) - (define-key map "4" #'digit-argument) - (define-key map "3" #'digit-argument) - (define-key map "2" #'digit-argument) - (define-key map "1" #'digit-argument) - (define-key map "0" #'digit-argument) - (define-key map "H" #'describe-mode) - (define-key map "?" #'describe-mode) ; Maybe do as less instead? See above. - (define-key map "h" #'describe-mode) - map)) +(defvar-keymap view-mode-map + :doc "Keymap for ‘view-mode’." + "C" #'View-kill-and-leave + "c" #'View-leave + "Q" #'View-quit-all + "E" #'View-exit-and-edit + ;; "v" #'View-exit + "e" #'View-exit + "q" #'View-quit + ;; "N" #'View-search-last-regexp-backward + "p" #'View-search-last-regexp-backward + "n" #'View-search-last-regexp-forward + ;; "?" #'View-search-regexp-backward ; Less does this. + "\\" #'View-search-regexp-backward + "/" #'View-search-regexp-forward + "r" #'isearch-backward + "s" #'isearch-forward + "m" #'point-to-register + "'" #'register-to-point + "x" #'exchange-point-and-mark + "@" #'View-back-to-mark + "." #'set-mark-command + "%" #'View-goto-percent + ;; "G" #'View-goto-line-last + "g" #'View-goto-line + "=" #'what-line + "F" #'View-revert-buffer-scroll-page-forward + ;; "k" #'View-scroll-line-backward + "y" #'View-scroll-line-backward + ;; "j" #'View-scroll-line-forward + "C-j" #'View-scroll-line-forward + "RET" #'View-scroll-line-forward + "u" #'View-scroll-half-page-backward + "d" #'View-scroll-half-page-forward + "z" #'View-scroll-page-forward-set-page-size + "w" #'View-scroll-page-backward-set-page-size + ;; "b" #'View-scroll-page-backward + "DEL" #'View-scroll-page-backward + ;; "f" #'View-scroll-page-forward + "SPC" #'View-scroll-page-forward + "S-SPC" #'View-scroll-page-backward + "o" #'View-scroll-to-buffer-end + ">" #'end-of-buffer + "<" #'beginning-of-buffer + "-" #'negative-argument + "9" #'digit-argument + "8" #'digit-argument + "7" #'digit-argument + "6" #'digit-argument + "5" #'digit-argument + "4" #'digit-argument + "3" #'digit-argument + "2" #'digit-argument + "1" #'digit-argument + "0" #'digit-argument + "H" #'describe-mode + "?" #'describe-mode ; Maybe do as less instead? See above. + "h" #'describe-mode) + ;;; Commands that enter or exit view mode. diff --git a/lisp/whitespace.el b/lisp/whitespace.el index 017409d6a42..5a482c5253a 100644 --- a/lisp/whitespace.el +++ b/lisp/whitespace.el @@ -1687,32 +1687,32 @@ cleaning up these problems." (or whitespace-active-style whitespace-style))) (bogus-list (mapcar - #'(lambda (option) - (when force - (push (car option) style)) - (goto-char rstart) - (let ((regexp - (cond - ((eq (car option) 'indentation) - (whitespace-indentation-regexp)) - ((eq (car option) 'indentation::tab) - (whitespace-indentation-regexp 'tab)) - ((eq (car option) 'indentation::space) - (whitespace-indentation-regexp 'space)) - ((eq (car option) 'space-after-tab) - (whitespace-space-after-tab-regexp)) - ((eq (car option) 'space-after-tab::tab) - (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) - (unless has-bogus - (setq has-bogus (memq (car option) style))) - t))) + (lambda (option) + (when force + (push (car option) style)) + (goto-char rstart) + (let ((regexp + (cond + ((eq (car option) 'indentation) + (whitespace-indentation-regexp)) + ((eq (car option) 'indentation::tab) + (whitespace-indentation-regexp 'tab)) + ((eq (car option) 'indentation::space) + (whitespace-indentation-regexp 'space)) + ((eq (car option) 'space-after-tab) + (whitespace-space-after-tab-regexp)) + ((eq (car option) 'space-after-tab::tab) + (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) + (unless has-bogus + (setq has-bogus (memq (car option) style))) + t))) whitespace-report-list))) (when (pcase report-if-bogus ('nil t) ('never nil) (_ has-bogus)) (whitespace-kill-buffer whitespace-report-buffer-name) @@ -2463,5 +2463,4 @@ It should be added buffer-locally to `write-file-functions'." "use `with-eval-after-load' instead." "28.1") (run-hooks 'whitespace-load-hook) - ;;; whitespace.el ends here diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index a2e9bf41ade..a53add7d084 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -131,16 +131,21 @@ This exists as a variable so it can be set locally in certain buffers.") (((class grayscale color) (background light)) :background "gray85" + ;; We use negative thickness of the horizontal box border line to + ;; avoid making lines taller when fields become visible. + :box (:line-width (1 . -1) :color "gray80") :extend t) (((class grayscale color) (background dark)) :background "dim gray" + :box (:line-width (1 . -1) :color "gray46") :extend t) (t :slant italic :extend t)) "Face used for editable fields." - :group 'widget-faces) + :group 'widget-faces + :version "28.1") (defface widget-single-line-field '((((type tty)) :background "green3" @@ -2963,7 +2968,8 @@ Save CHILD into the :last-deleted list, so it can be inserted later." "A widget which groups other widgets inside." :convert-widget 'widget-types-convert-widget :copy 'widget-types-copy - :format ":\n%v" + :format (concat (propertize ":" 'display "") + "\n%v") :value-create 'widget-group-value-create :value-get 'widget-editable-list-value-get :default-get 'widget-group-default-get @@ -3320,7 +3326,7 @@ It reads a file name from an editable text field." ;;; (file (file-name-nondirectory value)) ;;; (menu-tag (widget-apply widget :menu-tag-get)) ;;; (must-match (widget-get widget :must-match)) -;;; (answer (read-file-name (concat menu-tag " (default " value "): ") +;;; (answer (read-file-name (format-prompt menu-tag value) ;;; dir nil must-match file))) ;;; (widget-value-set widget (abbreviate-file-name answer)) ;;; (widget-setup) diff --git a/lisp/widget.el b/lisp/widget.el index 393fe6c21b3..0232f6cf93f 100644 --- a/lisp/widget.el +++ b/lisp/widget.el @@ -44,7 +44,7 @@ ;; (list 'or (list 'boundp (list 'car 'keywords)) ;; (list 'set (list 'car 'keywords) (list 'car 'keywords))) ;; (list 'setq 'keywords (list 'cdr 'keywords))))) - (declare (obsolete nil "27.1")) + (declare (obsolete nil "27.1") (indent defun)) nil) ;;(define-widget-keywords :documentation-indent @@ -83,7 +83,7 @@ create identical widgets: * (apply #\\='widget-create CLASS ARGS) The third argument DOC is a documentation string for the widget." - (declare (doc-string 3)) + (declare (doc-string 3) (indent defun)) ;; (unless (or (null doc) (stringp doc)) (error "Widget documentation must be nil or a string")) diff --git a/lisp/windmove.el b/lisp/windmove.el index 658e59af198..8904f5cbf70 100644 --- a/lisp/windmove.el +++ b/lisp/windmove.el @@ -700,7 +700,7 @@ where PREFIX is a prefix key and MODIFIERS is either a list of modifiers or a single modifier. If PREFIX is `none', no prefix is used. If MODIFIERS is `none', the keybindings are directly bound to the arrow keys. -Default value of PREFIX is `C-x' and MODIFIERS is `shift'." +Default value of PREFIX is \\`C-x' and MODIFIERS is `shift'." (interactive) (unless prefix (setq prefix '(?\C-x))) (when (eq prefix 'none) (setq prefix nil)) diff --git a/lisp/window.el b/lisp/window.el index d12232641e3..0f17bb28b4c 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -108,11 +108,14 @@ Return the buffer." ;; Return the buffer. buffer))) +;; Defined in help.el. +(defvar resize-temp-buffer-window-inhibit) + (defun temp-buffer-window-show (buffer &optional action) "Show temporary buffer BUFFER in a window. Return the window showing BUFFER. Pass ACTION as action argument to `display-buffer'." - (let (window frame) + (let (resize-temp-buffer-window-inhibit window) (with-current-buffer buffer (set-buffer-modified-p nil) (setq buffer-read-only t) @@ -130,9 +133,9 @@ to `display-buffer'." t window-combination-limit))) (setq window (display-buffer buffer action))) - (setq frame (window-frame window)) - (unless (eq frame (selected-frame)) - (raise-frame frame)) + ;; We used to raise the window's frame here. Do not do that + ;; since it would override an `inhibit-switch-frame' entry + ;; specified for the action alist used by `display-buffer'. (setq minibuffer-scroll-window window) (set-window-hscroll window 0) (with-selected-window window @@ -1514,21 +1517,11 @@ Emacs won't change the size of any window displaying that buffer, unless it has no other choice (like when deleting a neighboring window).") -(defun window--preservable-size (window &optional horizontal) - "Return height of WINDOW as `window-preserve-size' would preserve it. -Optional argument HORIZONTAL non-nil means to return the width of -WINDOW as `window-preserve-size' would preserve it." - (if horizontal - (window-body-width window t) - (+ (window-body-height window t) - (window-header-line-height window) - (window-mode-line-height window)))) - (defun window-preserve-size (&optional window horizontal preserve) - "Preserve height of window WINDOW. + "Preserve height of specified WINDOW's body. WINDOW must be a live window and defaults to the selected one. -Optional argument HORIZONTAL non-nil means preserve the width of -WINDOW. +Optional argument HORIZONTAL non-nil means to preserve the width +of WINDOW's body. PRESERVE t means to preserve the current height/width of WINDOW's body in frame and window resizing operations whenever possible. @@ -1545,21 +1538,15 @@ WINDOW as argument also removes the respective restraint. Other values of PRESERVE are reserved for future use." (setq window (window-normalize-window window t)) (let* ((parameter (window-parameter window 'window-preserved-size)) - (width (nth 1 parameter)) - (height (nth 2 parameter))) - (if horizontal - (set-window-parameter - window 'window-preserved-size - (list - (window-buffer window) - (and preserve (window--preservable-size window t)) - height)) - (set-window-parameter - window 'window-preserved-size - (list - (window-buffer window) - width - (and preserve (window--preservable-size window))))))) + (width (if horizontal + (and preserve (window-body-width window t)) + (nth 1 parameter))) + (height (if horizontal + (nth 2 parameter) + (and preserve (window-body-height window t))))) + (set-window-parameter + window 'window-preserved-size + (list (window-buffer window) width height)))) (defun window-preserved-size (&optional window horizontal) "Return preserved height of window WINDOW. @@ -1567,12 +1554,9 @@ WINDOW must be a live window and defaults to the selected one. Optional argument HORIZONTAL non-nil means to return preserved width of WINDOW." (setq window (window-normalize-window window t)) - (let* ((parameter (window-parameter window 'window-preserved-size)) - (buffer (nth 0 parameter)) - (width (nth 1 parameter)) - (height (nth 2 parameter))) - (when (eq buffer (window-buffer window)) - (if horizontal width height)))) + (let ((parameter (window-parameter window 'window-preserved-size))) + (when (eq (nth 0 parameter) (window-buffer window)) + (nth (if horizontal 1 2) parameter)))) (defun window--preserve-size (window horizontal) "Return non-nil when the height of WINDOW shall be preserved. @@ -1580,7 +1564,7 @@ Optional argument HORIZONTAL non-nil means to return non-nil when the width of WINDOW shall be preserved." (let ((size (window-preserved-size window horizontal))) (and (numberp size) - (= size (window--preservable-size window horizontal))))) + (= size (window-body-size window horizontal t))))) (defun window-safe-min-size (&optional window horizontal pixelwise) "Return safe minimum size of WINDOW. @@ -7250,11 +7234,15 @@ Return WINDOW if BUFFER and WINDOW are live." (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))) - (size (cdr (assq 'window-size alist))) - (preserve-size (cdr (assq 'preserve-size alist)))) + (let* ((frame (window-frame window)) + (quit-restore (window-parameter window 'quit-restore)) + (window-height (assq 'window-height alist)) + (height (cdr window-height)) + (window-width (assq 'window-width alist)) + (width (cdr window-width)) + (window-size (assq 'window-size alist)) + (size (cdr window-size)) + (preserve-size (cdr (assq 'preserve-size alist)))) (cond ((or (eq type 'frame) (and (eq (car quit-restore) 'same) @@ -7265,29 +7253,43 @@ Return WINDOW if BUFFER and WINDOW are live." ;; Adjust size of frame if asked for. We probably should do ;; that only for a single window frame. (cond - ((not size)) + ((not size) + (when window-size + (setq resize-temp-buffer-window-inhibit t))) ((consp size) - (let ((width (car size)) - (height (cdr size)) - (frame (window-frame window))) - (when (and (numberp width) (numberp height)) - (set-frame-height - frame (+ (frame-height frame) - (- height (window-total-height window)))) - (set-frame-width - frame (+ (frame-width frame) - (- width (window-total-width window))))))) - ((functionp size) - (ignore-errors (funcall size window))))) + ;; Modifying the parameters of a newly created frame might + ;; not work everywhere, but then `temp-buffer-resize-mode' + ;; will certainly fail in a similar fashion. + (if (eq (car size) 'body-chars) + (let ((width (+ (frame-text-width frame) + (* (frame-char-width frame) (cadr size)) + (- (window-body-width window t)))) + (height (+ (frame-text-height frame) + (* (frame-char-height frame) (cddr size)) + (- (window-body-height window t))))) + (modify-frame-parameters + frame `((height . (text-pixels . ,height)) + (width . (text-pixels . ,width))))) + (let ((width (- (+ (frame-width frame) (car size)) + (window-total-width window))) + (height (- (+ (frame-height frame) (cdr size)) + (window-total-height window)))) + (modify-frame-parameters + frame `((height . ,height) (width . ,width))))) + (setq resize-temp-buffer-window-inhibit t)) + ((functionp size) + (ignore-errors (funcall size window)) + (setq resize-temp-buffer-window-inhibit t)))) ((or (eq type 'window) (and (eq (car quit-restore) 'same) (eq (nth 1 quit-restore) 'window))) ;; A window that never showed another buffer but BUFFER ever - ;; since it was created on an existing frame. - ;; - ;; Adjust width and/or height of window if asked for. + ;; since it was created on an existing frame. Adjust its width + ;; and/or height if asked for. (cond - ((not height)) + ((not height) + (when window-height + (setq resize-temp-buffer-window-inhibit 'vertical))) ((numberp height) (let* ((new-height (if (integerp height) @@ -7298,12 +7300,23 @@ Return WINDOW if BUFFER and WINDOW are live." (delta (- new-height (window-total-height window)))) (when (and (window--resizable-p window delta nil 'safe) (window-combined-p window)) - (window-resize window delta nil 'safe)))) - ((functionp height) - (ignore-errors (funcall height window)))) + (window-resize window delta nil 'safe))) + (setq resize-temp-buffer-window-inhibit 'vertical)) + ((and (consp height) (eq (car height) 'body-lines)) + (let* ((delta (- (* (frame-char-height frame) (cdr height)) + (window-body-height window t)))) + (and (window--resizable-p window delta nil 'safe nil nil nil t) + (window-combined-p window) + (window-resize window delta nil 'safe t))) + (setq resize-temp-buffer-window-inhibit 'vertical)) + ((functionp height) + (ignore-errors (funcall height window)) + (setq resize-temp-buffer-window-inhibit 'vertical))) ;; Adjust width of window if asked for. (cond - ((not width)) + ((not width) + (when window-width + (setq resize-temp-buffer-window-inhibit 'horizontal))) ((numberp width) (let* ((new-width (if (integerp width) @@ -7314,13 +7327,24 @@ Return WINDOW if BUFFER and WINDOW are live." (delta (- new-width (window-total-width window)))) (when (and (window--resizable-p window delta t 'safe) (window-combined-p window t)) - (window-resize window delta t 'safe)))) + (window-resize window delta t 'safe))) + (setq resize-temp-buffer-window-inhibit 'horizontal)) + ((and (consp width) (eq (car width) 'body-columns)) + (let* ((delta (- (* (frame-char-width frame) (cdr width)) + (window-body-width window t)))) + (and (window--resizable-p window delta t 'safe nil nil nil t) + (window-combined-p window t) + (window-resize window delta t 'safe t))) + (setq resize-temp-buffer-window-inhibit 'horizontal)) ((functionp width) - (ignore-errors (funcall width window)))) + (ignore-errors (funcall width window)) + (setq resize-temp-buffer-window-inhibit 'horizontal))) + ;; Preserve window size if asked for. (when (consp preserve-size) (window-preserve-size window t (car preserve-size)) (window-preserve-size window nil (cdr preserve-size))))) + ;; Assign any window parameters specified. (let ((parameters (cdr (assq 'window-parameters alist)))) (dolist (parameter parameters) @@ -7563,6 +7587,9 @@ Action alist entries are: window from being used for display. `inhibit-switch-frame' -- A non-nil value prevents any frame used for showing the buffer from being raised or selected. + Note that a window manager may still raise a new frame and + give it focus, effectively overriding the value specified + here. `reusable-frames' -- The value specifies the set of frames to search for a window that already displays the buffer. Possible values are nil (the selected frame), t (any live @@ -7572,20 +7599,33 @@ Action alist entries are: frame parameters to give a new frame, if one is created. `window-height' -- The value specifies the desired height of the window chosen and is either an integer (the total height of - the window), a floating point number (the fraction of its - total height with respect to the total height of the frame's - root window) or a function to be called with one argument - - the chosen window. The function is supposed to adjust the - height of the window; its return value is ignored. Suitable - functions are `shrink-window-if-larger-than-buffer' and - `fit-window-to-buffer'. + the window specified in frame lines), a floating point + number (the fraction of its total height with respect to the + total height of the frame's root window), a cons cell whose + car is 'body-lines' and whose cdr is an integer that + specifies the height of the window's body in frame lines, or + a function to be called with one argument - the chosen + window. That function is supposed to adjust the height of + the window. Suitable functions are `fit-window-to-buffer' + and `shrink-window-if-larger-than-buffer'. `window-width' -- The value specifies the desired width of the window chosen and is either an integer (the total width of - the window), a floating point number (the fraction of its - total width with respect to the width of the frame's root - window) or a function to be called with one argument - the - chosen window. The function is supposed to adjust the width - of the window; its return value is ignored. + the window specified in frame lines), a floating point + number (the fraction of its total width with respect to the + width of the frame's root window), a cons cell whose car is + 'body-columns' and whose cdr is an integer that specifies the + width of the window's body in frame columns, or a function to + be called with one argument - the chosen window. That + function is supposed to adjust the width of the window. + `window-size' -- This entry is only useful for windows appearing + alone on their frame and specifies the desired size of that + window either as a cons of integers (the total width and + height of the window on that frame), a cons cell whose car is + 'body-chars' and whose cdr is a cons of integers (the desired + width and height of the window's body in columns and lines of + its frame), or a function to be called with one argument - + the chosen window. That function is supposed to adjust the + size of the frame. `preserve-size' -- The value should be either (t . nil) to preserve the width of the chosen window, (nil . t) to preserve its height or (t . t) to preserve its height and @@ -7601,9 +7641,9 @@ Action alist entries are: 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 -never showed another buffer before. +The entries `window-height', `window-width', `window-size' and +`preserve-size' are applied only when the window used for +displaying the buffer never showed another buffer before. The ACTION argument can also have a non-nil and non-list value. This means to display the buffer in a window other than the @@ -8534,7 +8574,7 @@ from the list of completions and default values." (let ((rbts-completion-table (internal-complete-buffer-except))) (minibuffer-with-setup-hook (lambda () - (setq minibuffer-completion-table rbts-completion-table) + (setq-local minibuffer-completion-table rbts-completion-table) ;; Since rbts-completion-table is built dynamically, we ;; can't just add it to the default value of ;; icomplete-with-completion-tables, so we add it diff --git a/lisp/xdg.el b/lisp/xdg.el index ee5d292ce65..60558982146 100644 --- a/lisp/xdg.el +++ b/lisp/xdg.el @@ -41,13 +41,11 @@ ;; XDG Base Directory Specification ;; https://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html -(defmacro xdg--dir-home (environ default-path) - (declare (debug (stringp stringp))) - (let ((env (make-symbol "env"))) - `(let ((,env (getenv ,environ))) - (if (or (null ,env) (not (file-name-absolute-p ,env))) - (expand-file-name ,default-path) - ,env)))) +(defun xdg--dir-home (environ default-path) + (let ((env (getenv environ))) + (if (or (null env) (not (file-name-absolute-p env))) + (expand-file-name default-path) + env))) (defun xdg-config-home () "Return the base directory for user specific configuration files. @@ -85,6 +83,23 @@ According to the XDG Base Directory Specification version should be used.\"" (xdg--dir-home "XDG_DATA_HOME" "~/.local/share")) +(defun xdg-state-home () + "Return the base directory for user-specific state data. + +According to the XDG Base Directory Specification version +0.8 (8th May 2021): + + \"The $XDG_STATE_HOME contains state data that should persist + between (application) restarts, but that is not important or + portable enough to the user that it should be stored in + $XDG_DATA_HOME. It may contain: + + * actions history (logs, history, recently used files, …) + + * current state of the application that can be reused on a + restart (view, layout, open files, undo history, …)\"" + (xdg--dir-home "XDG_STATE_HOME" "~/.local/state")) + (defun xdg-runtime-dir () "Return the value of $XDG_RUNTIME_DIR. diff --git a/lisp/xml.el b/lisp/xml.el index 0282e3741c0..e2ba02e1952 100644 --- a/lisp/xml.el +++ b/lisp/xml.el @@ -612,8 +612,8 @@ references." (if (setq ref (match-string 2)) (progn ; Numeric char reference (setq val (save-match-data - (decode-char 'ucs (string-to-number - ref (if (match-string 1) 16))))) + (string-to-number + ref (if (match-string 1) 16)))) (and (null val) xml-validating-parser (error "XML: (Validity) Invalid character reference `%s'" @@ -898,11 +898,11 @@ references and parameter-entity references." ref val) (cond ((setq ref (match-string 1 string)) ;; Decimal character reference - (setq val (decode-char 'ucs (string-to-number ref))) + (setq val (string-to-number ref)) (if val (push (string val) children))) ;; Hexadecimal character reference ((setq ref (match-string 2 string)) - (setq val (decode-char 'ucs (string-to-number ref 16))) + (setq val (string-to-number ref 16)) (if val (push (string val) children))) ;; Parameter entity reference ((setq ref (match-string 3 string)) @@ -962,7 +962,7 @@ STRING is assumed to occur in an XML attribute value." (if ref ;; [4.6] Character references are included as ;; character data. - (let ((val (decode-char 'ucs (string-to-number ref (if is-hex 16))))) + (let ((val (string-to-number ref (if is-hex 16)))) (push (cond (val (string val)) (xml-validating-parser (error "XML: (Validity) Undefined character `x%s'" ref)) diff --git a/lisp/xwidget.el b/lisp/xwidget.el index 8c593abea88..ce9839ebd34 100644 --- a/lisp/xwidget.el +++ b/lisp/xwidget.el @@ -33,10 +33,12 @@ (require 'cl-lib) (require 'bookmark) +(require 'format-spec) (declare-function make-xwidget "xwidget.c" - (type title width height arguments &optional buffer)) + (type title width height arguments &optional buffer related)) (declare-function xwidget-buffer "xwidget.c" (xwidget)) +(declare-function set-xwidget-buffer "xwidget.c" (xwidget buffer)) (declare-function xwidget-size-request "xwidget.c" (xwidget)) (declare-function xwidget-resize "xwidget.c" (xwidget new-width new-height)) (declare-function xwidget-webkit-execute-script "xwidget.c" @@ -53,31 +55,33 @@ (declare-function delete-xwidget-view "xwidget.c" (xwidget-view)) (declare-function get-buffer-xwidgets "xwidget.c" (buffer)) (declare-function xwidget-query-on-exit-flag "xwidget.c" (xwidget)) +(declare-function xwidget-webkit-back-forward-list "xwidget.c" (xwidget &optional limit)) +(declare-function xwidget-webkit-estimated-load-progress "xwidget.c" (xwidget)) +(declare-function xwidget-webkit-set-cookie-storage-file "xwidget.c" (xwidget file)) +(declare-function xwidget-live-p "xwidget.c" (xwidget)) +(declare-function xwidget-webkit-stop-loading "xwidget.c" (xwidget)) (defgroup xwidget nil "Displaying native widgets in Emacs buffers." :group 'widgets) -(defun xwidget-insert (pos type title width height &optional args) +(defun xwidget-insert (pos type title width height &optional args related) "Insert an xwidget at position POS. -Supply the xwidget's TYPE, TITLE, WIDTH, and HEIGHT. +Supply the xwidget's TYPE, TITLE, WIDTH, HEIGHT, and RELATED. See `make-xwidget' for the possible TYPE values. The usage of optional argument ARGS depends on the xwidget. This returns the result of `make-xwidget'." (goto-char pos) - (let ((id (make-xwidget type title width height args))) + (let ((id (make-xwidget type title width height args nil related))) (put-text-property (point) (+ 1 (point)) 'display (list 'xwidget ':xwidget id)) id)) (defun xwidget-at (pos) "Return xwidget at POS." - ;; TODO this function is a bit tedious because the C layer isn't well - ;; protected yet and xwidgetp apparently doesn't work yet. (let* ((disp (get-text-property pos 'display)) - (xw (car (cdr (cdr disp))))) - ;;(if (xwidgetp xw) xw nil) - (if (equal 'xwidget (car disp)) xw))) + (xw (car (cdr (cdr disp))))) + (when (xwidget-live-p xw) xw))) @@ -88,6 +92,29 @@ This returns the result of `make-xwidget'." (require 'seq) (require 'url-handlers) +(defgroup xwidget-webkit nil + "Displaying webkit xwidgets in Emacs buffers." + :version "29.1" + :group 'web + :prefix "xwidget-webkit-") + +(defcustom xwidget-webkit-buffer-name-format "*xwidget-webkit: %T*" + "Template for naming `xwidget-webkit' buffers. +It can use the following special constructs: + + %T -- the title of the Web page loaded by the xwidget. + %U -- the URI of the Web page loaded by the xwidget." + :type 'string + :version "29.1") + +(defcustom xwidget-webkit-cookie-file nil + "The name of the file where `xwidget-webkit-browse-url' will store cookies. +They will be stored as plain text in Mozilla \"cookies.txt\" +format. If nil, do not store cookies. You must kill all xwidget-webkit +buffers for this setting to take effect after setting it to nil." + :type '(choice (const :tag "Do not store cookies" nil) file) + :version "29.1") + ;;;###autoload (defun xwidget-webkit-browse-url (url &optional new-session) "Ask xwidget-webkit to browse URL. @@ -124,6 +151,45 @@ in `split-window-right' with a new xwidget webkit session." (with-selected-window (split-window-right) (xwidget-webkit-new-session url)))) +(declare-function xwidget-perform-lispy-event "xwidget.c") + +(defvar xwidget-webkit--input-method-events nil + "Internal variable used to store input method events.") + +(defvar-local xwidget-webkit--loading-p nil + "Whether or not a page is being loaded.") + +(defvar-local xwidget-webkit--progress-update-timer nil + "Timer that updates the display of page load progress in the header line.") + +(defun xwidget-webkit-pass-command-event-with-input-method () + "Handle a `with-input-method' event." + (interactive) + (let ((key (pop unread-command-events))) + (setq xwidget-webkit--input-method-events + (funcall input-method-function key)) + (exit-minibuffer))) + +(defun xwidget-webkit-pass-command-event () + "Pass `last-command-event' to the current buffer's WebKit widget. +If `current-input-method' is non-nil, consult `input-method-function' +for the actual events that will be sent." + (interactive) + (if (and current-input-method + (characterp last-command-event)) + (let ((xwidget-webkit--input-method-events nil) + (minibuffer-local-map (make-keymap))) + (define-key minibuffer-local-map [with-input-method] + 'xwidget-webkit-pass-command-event-with-input-method) + (push last-command-event unread-command-events) + (push 'with-input-method unread-command-events) + (read-from-minibuffer "" nil nil nil nil nil t) + (dolist (event xwidget-webkit--input-method-events) + (xwidget-perform-lispy-event (xwidget-webkit-current-session) + event))) + (xwidget-perform-lispy-event (xwidget-webkit-current-session) + last-command-event))) + ;;todo. ;; - check that the webkit support is compiled in (defvar xwidget-webkit-mode-map @@ -133,11 +199,14 @@ in `split-window-right' with a new xwidget webkit session." (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) (define-key map "w" 'xwidget-webkit-current-url) (define-key map "+" 'xwidget-webkit-zoom-in) (define-key map "-" 'xwidget-webkit-zoom-out) + (define-key map "e" 'xwidget-webkit-edit-mode) + (define-key map "\C-r" 'xwidget-webkit-isearch-mode) + (define-key map "\C-s" 'xwidget-webkit-isearch-mode) + (define-key map "H" 'xwidget-webkit-browse-history) ;;similar to image mode bindings (define-key map (kbd "SPC") 'xwidget-webkit-scroll-up) @@ -164,6 +233,70 @@ in `split-window-right' with a new xwidget webkit session." map) "Keymap for `xwidget-webkit-mode'.") +(easy-menu-define nil xwidget-webkit-mode-map "Xwidget WebKit menu." + (list "Xwidget WebKit" + ["Browse URL" xwidget-webkit-browse-url + :active t + :help "Prompt for a URL, then instruct WebKit to browse it"] + ["Back" xwidget-webkit-back t] + ["Forward" xwidget-webkit-forward t] + ["Reload" xwidget-webkit-reload t] + ["History" xwidget-webkit-browse-history t] + ["Insert String" xwidget-webkit-insert-string + :active t + :help "Insert a string into the currently active field"] + ["Zoom In" xwidget-webkit-zoom-in t] + ["Zoom Out" xwidget-webkit-zoom-out t] + ["Edit Mode" xwidget-webkit-edit-mode + :active t + :style toggle + :selected xwidget-webkit-edit-mode + :help "Send self inserting characters to the WebKit widget"] + ["Save Selection" xwidget-webkit-copy-selection-as-kill + :active t + :help "Save the browser's selection in the kill ring"] + ["Incremental Search" xwidget-webkit-isearch-mode + :active (not xwidget-webkit-isearch-mode) + :help "Perform incremental search inside the WebKit widget"] + ["Stop Loading" xwidget-webkit-stop + :active xwidget-webkit--loading-p])) + +(defvar xwidget-webkit-tool-bar-map + (let ((map (make-sparse-keymap))) + (prog1 map + (tool-bar-local-item-from-menu 'xwidget-webkit-stop + "cancel" + map + xwidget-webkit-mode-map) + (tool-bar-local-item-from-menu 'xwidget-webkit-back + "left-arrow" + map + xwidget-webkit-mode-map) + (tool-bar-local-item-from-menu 'xwidget-webkit-forward + "right-arrow" + map + xwidget-webkit-mode-map) + (tool-bar-local-item-from-menu 'xwidget-webkit-reload + "refresh" + map + xwidget-webkit-mode-map) + (tool-bar-local-item-from-menu 'xwidget-webkit-zoom-in + "zoom-in" + map + xwidget-webkit-mode-map) + (tool-bar-local-item-from-menu 'xwidget-webkit-zoom-out + "zoom-out" + map + xwidget-webkit-mode-map) + (tool-bar-local-item-from-menu 'xwidget-webkit-browse-url + "connect-to-url" + map + xwidget-webkit-mode-map) + (tool-bar-local-item-from-menu 'xwidget-webkit-isearch-mode + "search" + map + xwidget-webkit-mode-map)))) + (defun xwidget-webkit-zoom-in () "Increase webkit view zoom factor." (interactive nil xwidget-webkit-mode) @@ -246,10 +379,13 @@ If N is omitted or nil, scroll backwards by one char." (xwidget-webkit-current-session) "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. -;; TODO this needs to use callbacks and consider different xwidget event types. -(define-key (current-global-map) [xwidget-event] #'xwidget-event-handler) +;; The xwidget event needs to go in the special map. To receive +;; xwidget events, you should place a callback in the property list of +;; the xwidget, instead of handling these events manually. +;; +;; See `xwidget-webkit-new-session' for an example of how to do this. +(define-key special-event-map [xwidget-event] #'xwidget-event-handler) + (defun xwidget-log (&rest msg) "Log MSG to a buffer." (let ((buf (get-buffer-create " *xwidget-log*"))) @@ -265,7 +401,18 @@ If N is omitted or nil, scroll backwards by one char." ((xwidget-event-type (nth 1 last-input-event)) (xwidget (nth 2 last-input-event)) (xwidget-callback (xwidget-get xwidget 'callback))) - (funcall xwidget-callback xwidget xwidget-event-type))) + (when xwidget-callback + (funcall xwidget-callback xwidget xwidget-event-type)))) + +(defun xwidget-webkit--update-progress-timer-function (xwidget) + "Force an update of the header line of XWIDGET's buffer." + (with-current-buffer (xwidget-buffer xwidget) + (force-mode-line-update))) + +(defun xwidget-webkit-buffer-kill () + "Clean up an xwidget-webkit buffer before it is killed." + (when (timerp xwidget-webkit--progress-update-timer) + (cancel-timer xwidget-webkit--progress-update-timer))) (defun xwidget-webkit-callback (xwidget xwidget-event-type) "Callback for xwidgets. @@ -273,30 +420,58 @@ XWIDGET instance, XWIDGET-EVENT-TYPE depends on the originating xwidget." (if (not (buffer-live-p (xwidget-buffer xwidget))) (xwidget-log "error: callback called for xwidget with dead buffer") - (with-current-buffer (xwidget-buffer xwidget) - (cond ((eq xwidget-event-type 'load-changed) - (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))) - (funcall proc arg))) - (t (xwidget-log "unhandled event:%s" xwidget-event-type)))))) + (cond ((eq xwidget-event-type 'load-changed) + (let ((title (xwidget-webkit-title xwidget)) + (uri (xwidget-webkit-uri xwidget))) + (when-let ((buffer (get-buffer "*Xwidget WebKit History*"))) + (with-current-buffer buffer + (revert-buffer))) + (with-current-buffer (xwidget-buffer xwidget) + (if (string-equal (nth 3 last-input-event) + "load-finished") + (progn + (setq xwidget-webkit--loading-p nil) + (cancel-timer xwidget-webkit--progress-update-timer)) + (unless xwidget-webkit--loading-p + (setq xwidget-webkit--loading-p t + xwidget-webkit--progress-update-timer + (run-at-time 0.5 0.5 #'xwidget-webkit--update-progress-timer-function + xwidget))))) + ;; This funciton will be called multi times, so only + ;; change buffer name when the load actually completes + ;; this can limit buffer-name flicker in mode-line. + (when (or (string-equal (nth 3 last-input-event) + "load-finished") + (> (length title) 0)) + (with-current-buffer (xwidget-buffer xwidget) + (force-mode-line-update) + (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-spec + xwidget-webkit-buffer-name-format + `((?T . ,title) + (?U . ,uri))) + 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))) + (funcall proc arg))) + (t (xwidget-log "unhandled event:%s" xwidget-event-type))))) (defvar bookmark-make-record-function) (when (memq window-system '(mac ns)) @@ -309,8 +484,21 @@ 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) + (add-hook 'kill-buffer-hook #'xwidget-webkit-buffer-kill) + (setq-local tool-bar-map xwidget-webkit-tool-bar-map) (setq-local bookmark-make-record-function #'xwidget-webkit-bookmark-make-record) + (setq-local header-line-format + (list "WebKit: " + '(:eval + (xwidget-webkit-title (xwidget-webkit-current-session))) + '(:eval + (when xwidget-webkit--loading-p + (let ((session (xwidget-webkit-current-session))) + (format " [%d%%%%]" + (* 100 + (xwidget-webkit-estimated-load-progress + session)))))))) ;; Keep track of [vh]scroll when switching buffers (image-mode-setup-winprops)) @@ -386,6 +574,10 @@ The latter might be nil." (let ((size (xwidget-size-request xw))) (xwidget-resize xw (car size) (cadr size)))) +(defun xwidget-webkit-stop () + "Stop trying to load the current page." + (interactive) + (xwidget-webkit-stop-loading (xwidget-webkit-current-session))) (defvar xwidget-webkit-activeelement-js" function findactiveelement(doc){ @@ -606,10 +798,15 @@ For example, use this to display an anchor." (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) + (let* ((bufname + ;; Generate a temp-name based on current buffer name. it + ;; will be renamed by `xwidget-webkit-callback' in the + ;; future. This approach can limit flicker of buffer-name in + ;; mode-line. + (generate-new-buffer-name (buffer-name))) + (callback (or callback #'xwidget-webkit-callback)) + (current-session (xwidget-webkit-current-session)) + 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 @@ -621,17 +818,62 @@ For example, use this to display an anchor." (setq xw (xwidget-insert start 'webkit bufname (xwidget-window-inside-pixel-width (selected-window)) - (xwidget-window-inside-pixel-height (selected-window))))) + (xwidget-window-inside-pixel-height (selected-window)) + nil current-session))) + (when xwidget-webkit-cookie-file + (xwidget-webkit-set-cookie-storage-file + xw (expand-file-name xwidget-webkit-cookie-file))) (xwidget-put xw 'callback callback) + (xwidget-put xw 'display-callback #'xwidget-webkit-display-callback) (xwidget-webkit-mode) (xwidget-webkit-goto-uri (xwidget-webkit-last-session) url))) +(defun xwidget-webkit-import-widget (xwidget) + "Create a new webkit session buffer from XWIDGET, an existing xwidget. +Return the buffer." + (let* ((bufname + ;; Generate a temp-name based on current buffer name. it + ;; will be renamed by `xwidget-webkit-callback' in the + ;; future. This approach can limit flicker of buffer-name in + ;; mode-line. + (generate-new-buffer-name (buffer-name))) + (callback #'xwidget-webkit-callback) + (buffer (get-buffer-create bufname))) + (with-current-buffer buffer + (setq xwidget-webkit-last-session-buffer buffer) + (save-excursion + (erase-buffer) + (insert ".") + (put-text-property (point-min) (point-max) + 'display (list 'xwidget :xwidget xwidget))) + (xwidget-put xwidget 'callback callback) + (xwidget-put xwidget 'display-callback + #'xwidget-webkit-display-callback) + (set-xwidget-buffer xwidget buffer) + (xwidget-webkit-mode)) + buffer)) + +(defun xwidget-webkit-display-event (event) + "Trigger display callback for EVENT." + (interactive "e") + (let ((xwidget (cadr event)) + (source (caddr event))) + (when (xwidget-get source 'display-callback) + (funcall (xwidget-get source 'display-callback) + xwidget source)))) + +(defun xwidget-webkit-display-callback (xwidget _source) + "Import XWIDGET and display it." + (display-buffer (xwidget-webkit-import-widget xwidget))) + +(define-key special-event-map [xwidget-display-event] 'xwidget-webkit-display-event) (defun xwidget-webkit-goto-url (url) "Goto URL with xwidget webkit." (if (xwidget-webkit-current-session) (progn - (xwidget-webkit-goto-uri (xwidget-webkit-current-session) url)) + (xwidget-webkit-goto-uri (xwidget-webkit-current-session) url) + (switch-to-buffer (xwidget-buffer (xwidget-webkit-current-session)))) (xwidget-webkit-new-session url))) (defun xwidget-webkit-back () @@ -655,6 +897,15 @@ For example, use this to display an anchor." (let ((url (xwidget-webkit-uri (xwidget-webkit-current-session)))) (message "URL: %s" (kill-new (or url ""))))) +(defun xwidget-webkit-browse-history () + "Display a buffer containing the history of page loads." + (interactive) + (setq xwidget-webkit-last-session-buffer (current-buffer)) + (let ((buffer (get-buffer-create "*Xwidget WebKit History*"))) + (with-current-buffer buffer + (xwidget-webkit-history-mode)) + (display-buffer buffer))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun xwidget-webkit-get-selection (proc) "Get the webkit selection and pass it to PROC." @@ -684,7 +935,275 @@ You can retrieve the value with `xwidget-get'." (set-xwidget-plist xwidget (plist-put (xwidget-plist xwidget) propname value))) +(defvar xwidget-webkit-edit-mode-map (make-keymap)) + +(define-key xwidget-webkit-edit-mode-map [backspace] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [tab] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [left] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [right] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [up] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [down] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [return] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [C-left] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [C-right] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [C-up] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [C-down] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [C-return] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [S-left] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [S-right] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [S-up] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [S-down] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [S-return] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [M-left] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [M-right] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [M-up] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [M-down] 'xwidget-webkit-pass-command-event) +(define-key xwidget-webkit-edit-mode-map [M-return] 'xwidget-webkit-pass-command-event) + +(define-minor-mode xwidget-webkit-edit-mode + "Minor mode for editing the content of WebKit buffers. + +This defines most self-inserting characters and some common +keyboard shortcuts to `xwidget-webkit-pass-command-event', which +will pass the key events corresponding to these characters to the +WebKit widget." + :keymap xwidget-webkit-edit-mode-map) + +(substitute-key-definition 'self-insert-command + 'xwidget-webkit-pass-command-event + xwidget-webkit-edit-mode-map + global-map) + +(declare-function xwidget-webkit-search "xwidget.c") +(declare-function xwidget-webkit-next-result "xwidget.c") +(declare-function xwidget-webkit-previous-result "xwidget.c") +(declare-function xwidget-webkit-finish-search "xwidget.c") + +(defvar-local xwidget-webkit-isearch--string "" + "The current search query.") +(defvar-local xwidget-webkit-isearch--is-reverse nil + "Whether or not the current isearch should be reverse.") +(defvar xwidget-webkit-isearch--read-string-buffer nil + "The buffer we are reading input method text for, if any.") + +(defun xwidget-webkit-isearch--update (&optional only-message) + "Update the current buffer's WebKit widget's search query. +If ONLY-MESSAGE is non-nil, the query will not be sent to the +WebKit widget. The query will be set to the contents of +`xwidget-webkit-isearch--string'." + (unless only-message + (xwidget-webkit-search xwidget-webkit-isearch--string + (xwidget-webkit-current-session) + t xwidget-webkit-isearch--is-reverse t)) + (let ((message-log-max nil)) + (message "%s" (concat (propertize "Search contents: " 'face 'minibuffer-prompt) + xwidget-webkit-isearch--string)))) + +(defun xwidget-webkit-isearch-erasing-char (count) + "Erase the last COUNT characters of the current query." + (interactive (list (prefix-numeric-value current-prefix-arg))) + (when (> (length xwidget-webkit-isearch--string) 0) + (setq xwidget-webkit-isearch--string + (substring xwidget-webkit-isearch--string 0 + (- (length xwidget-webkit-isearch--string) count)))) + (xwidget-webkit-isearch--update)) + +(defun xwidget-webkit-isearch-with-input-method () + "Handle a request to use the input method to modify the search query." + (interactive) + (let ((key (car unread-command-events)) + events) + (setq unread-command-events (cdr unread-command-events) + events (funcall input-method-function key)) + (dolist (k events) + (with-current-buffer xwidget-webkit-isearch--read-string-buffer + (setq xwidget-webkit-isearch--string + (concat xwidget-webkit-isearch--string + (char-to-string k))))) + (exit-minibuffer))) + +(defun xwidget-webkit-isearch-printing-char-with-input-method (char) + "Handle printing char CHAR with the current input method." + (let ((minibuffer-local-map (make-keymap)) + (xwidget-webkit-isearch--read-string-buffer (current-buffer))) + (define-key minibuffer-local-map [with-input-method] + 'xwidget-webkit-isearch-with-input-method) + (setq unread-command-events + (cons 'with-input-method + (cons char unread-command-events))) + (read-string "Search contents: " + xwidget-webkit-isearch--string + 'junk-hist nil t) + (xwidget-webkit-isearch--update))) + +(defun xwidget-webkit-isearch-printing-char (char &optional count) + "Add ordinary character CHAR to the search string and search. +With argument, add COUNT copies of CHAR." + (interactive (list last-command-event + (prefix-numeric-value current-prefix-arg))) + (if current-input-method + (xwidget-webkit-isearch-printing-char-with-input-method char) + (setq xwidget-webkit-isearch--string (concat xwidget-webkit-isearch--string + (make-string (or count 1) char)))) + (xwidget-webkit-isearch--update)) + +(defun xwidget-webkit-isearch-forward (count) + "Move to the next search result COUNT times." + (interactive (list (prefix-numeric-value current-prefix-arg))) + (let ((was-reverse xwidget-webkit-isearch--is-reverse)) + (setq xwidget-webkit-isearch--is-reverse nil) + (when was-reverse + (xwidget-webkit-isearch--update) + (setq count (1- count)))) + (let ((i 0)) + (while (< i count) + (xwidget-webkit-next-result (xwidget-webkit-current-session)) + (cl-incf i))) + (xwidget-webkit-isearch--update t)) + +(defun xwidget-webkit-isearch-backward (count) + "Move to the previous search result COUNT times." + (interactive (list (prefix-numeric-value current-prefix-arg))) + (let ((was-reverse xwidget-webkit-isearch--is-reverse)) + (setq xwidget-webkit-isearch--is-reverse t) + (unless was-reverse + (xwidget-webkit-isearch--update) + (setq count (1- count)))) + (let ((i 0)) + (while (< i count) + (xwidget-webkit-previous-result (xwidget-webkit-current-session)) + (cl-incf i))) + (xwidget-webkit-isearch--update t)) + +(defun xwidget-webkit-isearch-exit () + "Exit incremental search of a WebKit buffer." + (interactive) + (xwidget-webkit-isearch-mode 0)) + +(defvar xwidget-webkit-isearch-mode-map (make-keymap) + "The keymap used inside xwidget-webkit-isearch-mode.") + +(set-char-table-range (nth 1 xwidget-webkit-isearch-mode-map) + (cons 0 (max-char)) + 'xwidget-webkit-isearch-exit) + +(substitute-key-definition 'self-insert-command + 'xwidget-webkit-isearch-printing-char + xwidget-webkit-isearch-mode-map + global-map) + +(define-key xwidget-webkit-isearch-mode-map (kbd "DEL") + 'xwidget-webkit-isearch-erasing-char) +(define-key xwidget-webkit-isearch-mode-map [backspace] 'xwidget-webkit-isearch-erasing-char) +(define-key xwidget-webkit-isearch-mode-map [return] 'xwidget-webkit-isearch-exit) +(define-key xwidget-webkit-isearch-mode-map "\r" 'xwidget-webkit-isearch-exit) +(define-key xwidget-webkit-isearch-mode-map "\C-g" 'xwidget-webkit-isearch-exit) +(define-key xwidget-webkit-isearch-mode-map "\C-r" 'xwidget-webkit-isearch-backward) +(define-key xwidget-webkit-isearch-mode-map "\C-s" 'xwidget-webkit-isearch-forward) +(define-key xwidget-webkit-isearch-mode-map "\C-y" 'xwidget-webkit-isearch-yank-kill) +(define-key xwidget-webkit-isearch-mode-map "\C-\\" 'toggle-input-method) +(define-key xwidget-webkit-isearch-mode-map "\t" 'xwidget-webkit-isearch-printing-char) + +(let ((meta-map (make-keymap))) + (set-char-table-range (nth 1 meta-map) + (cons 0 (max-char)) + 'xwidget-webkit-isearch-exit) + (define-key xwidget-webkit-isearch-mode-map (char-to-string meta-prefix-char) meta-map)) + +(define-minor-mode xwidget-webkit-isearch-mode + "Minor mode for performing incremental search inside WebKit buffers. + +This resembles the regular incremental search, but it does not +support recursive edits. + +If this mode is activated with `\\<xwidget-webkit-isearch-mode-map>\\[xwidget-webkit-isearch-backward]', then the search will by default +start in the reverse direction. + +To navigate around the search results, type +\\<xwidget-webkit-isearch-mode-map>\\[xwidget-webkit-isearch-forward] to move forward, and +\\<xwidget-webkit-isearch-mode-map>\\[xwidget-webkit-isearch-backward] to move backward. + +To insert the string at the front of the kill ring into the +search query, type \\<xwidget-webkit-isearch-mode-map>\\[xwidget-webkit-isearch-yank-kill]. + +Press \\<xwidget-webkit-isearch-mode-map>\\[xwidget-webkit-isearch-exit] to exit incremental search." + :keymap xwidget-webkit-isearch-mode-map + (if xwidget-webkit-isearch-mode + (progn + (setq xwidget-webkit-isearch--string "") + (setq xwidget-webkit-isearch--is-reverse (eq last-command-event ?\C-r)) + (xwidget-webkit-isearch--update)) + (xwidget-webkit-finish-search (xwidget-webkit-current-session)))) +(defun xwidget-webkit-isearch-yank-kill () + "Append the most recent kill from `kill-ring' to the current query." + (interactive) + (unless xwidget-webkit-isearch-mode + (xwidget-webkit-isearch-mode t)) + (setq xwidget-webkit-isearch--string + (concat xwidget-webkit-isearch--string + (current-kill 0))) + (xwidget-webkit-isearch--update)) + +(defvar-local xwidget-webkit-history--session nil + "The xwidget this history buffer controls.") + +(define-button-type 'xwidget-webkit-history 'action #'xwidget-webkit-history-select-item) + +(defun xwidget-webkit-history--insert-item (item) + "Insert specified ITEM into the current buffer." + (let ((idx (car item)) + (title (cadr item)) + (uri (caddr item))) + (push (list idx (vector (list (number-to-string idx) + :type 'xwidget-webkit-history) + (list title :type 'xwidget-webkit-history) + (list uri :type 'xwidget-webkit-history))) + tabulated-list-entries))) + +(defun xwidget-webkit-history-select-item (pos) + "Navigate to the history item underneath POS." + (interactive "P") + (let ((id (tabulated-list-get-id pos))) + (xwidget-webkit-goto-history xwidget-webkit-history--session id)) + (xwidget-webkit-history-reload)) + +(defun xwidget-webkit-history-reload (&rest ignored) + "Reload the current history buffer." + (interactive) + (setq tabulated-list-entries nil) + (let* ((back-forward-list + (xwidget-webkit-back-forward-list xwidget-webkit-history--session)) + (back-list (car back-forward-list)) + (here (cadr back-forward-list)) + (forward-list (caddr back-forward-list))) + (mapc #'xwidget-webkit-history--insert-item (nreverse forward-list)) + (xwidget-webkit-history--insert-item here) + (mapc #'xwidget-webkit-history--insert-item back-list) + (tabulated-list-print t nil) + (goto-char (point-min)) + (let ((position (line-beginning-position (1+ (length back-list))))) + (goto-char position) + (setq-local overlay-arrow-position (make-marker)) + (set-marker overlay-arrow-position position)))) + +(define-derived-mode xwidget-webkit-history-mode tabulated-list-mode + "Xwidget Webkit History" + "Major mode for browsing the history of an Xwidget Webkit buffer. +Each line describes an entry in history." + (setq truncate-lines t) + (setq buffer-read-only t) + (setq tabulated-list-format [("Index" 10 nil) + ("Title" 50 nil) + ("URL" 100 nil)]) + (setq tabulated-list-entries nil) + (setq xwidget-webkit-history--session (xwidget-webkit-current-session)) + (xwidget-webkit-history-reload) + (setq-local revert-buffer-function #'xwidget-webkit-history-reload) + (tabulated-list-init-header)) + +(define-key xwidget-webkit-history-mode-map (kbd "RET") + #'xwidget-webkit-history-select-item) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar xwidget-view-list) ; xwidget.c diff --git a/lisp/yank-media.el b/lisp/yank-media.el new file mode 100644 index 00000000000..decab3b3625 --- /dev/null +++ b/lisp/yank-media.el @@ -0,0 +1,194 @@ +;;; yank-media.el --- Yanking images and HTML -*- lexical-binding:t -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; Author: Lars Ingebrigtsen <larsi@gnus.org> +;; Keywords: utility + +;; 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: + +(require 'cl-lib) +(require 'seq) + +(defvar yank-media--registered-handlers nil) + +;;;###autoload +(defun yank-media () + "Yank media (images, HTML and the like) from the clipboard. +This command depends on the current major mode having support for +accepting the media type. The mode has to register itself using +the `yank-media-handler' mechanism. + +Also see `yank-media-types' for a command that lets you explore +all the different selection types." + (interactive) + (unless yank-media--registered-handlers + (user-error "The `%s' mode hasn't registered any handlers" major-mode)) + (let ((all-types nil)) + (pcase-dolist (`(,handled-type . ,handler) + yank-media--registered-handlers) + (dolist (type (yank-media--find-matching-media handled-type)) + (push (cons type handler) all-types))) + (unless all-types + (user-error + "No handler in the current buffer for anything on the clipboard")) + ;; We have a handler in the current buffer; if there's just + ;; matching type, just call the handler. + (if (length= all-types 1) + (funcall (cdar all-types) (caar all-types) + (yank-media--get-selection (caar all-types))) + ;; More than one type the user for what type to insert. + (let ((type + (intern + (completing-read "Several types available, choose one: " + (mapcar #'car all-types) nil t)))) + (funcall (alist-get type all-types) + type (yank-media--get-selection type)))))) + +(defun yank-media--find-matching-media (handled-type) + (seq-filter + (lambda (type) + (pcase-let ((`(,major ,minor) (split-string (symbol-name type) "/"))) + (if (and (equal major "image") + (not (image-type-available-p (intern minor)))) + ;; Just filter out all the image types that Emacs doesn't + ;; support, because the clipboard is full of things like + ;; `image/x-win-bitmap'. + nil + ;; Check that the handler wants this type. + (and (if (symbolp handled-type) + (eq handled-type type) + (string-match-p handled-type (symbol-name type))) + ;; An element may be in TARGETS but be empty. + (yank-media--get-selection type))))) + (gui-get-selection 'CLIPBOARD 'TARGETS))) + +(defun yank-media--get-selection (data-type) + (when-let ((data (gui-backend-get-selection 'CLIPBOARD data-type))) + (if (string-match-p "\\`text/" (symbol-name data-type)) + (yank-media-types--format data-type data) + data))) + +;;;###autoload +(defun yank-media-handler (types handler) + "Register HANDLER for dealing with `yank-media' actions for TYPES. +TYPES should be a MIME media type symbol, a regexp, or a list +that can contain both symbols and regexps. + +HANDLER is a function that will be called with two arguments: The +MIME type (a symbol on the form `image/png') and the selection +data (a string)." + (make-local-variable 'yank-media--registered-handlers) + (dolist (type (ensure-list types)) + (setf (alist-get type yank-media--registered-handlers nil nil #'equal) + handler))) + +(defun yank-media-types (&optional all) + "Yank any element present in the primary selection or the clipboard. +This is primarily meant as a debugging tool -- many of the +elements (like images) will be inserted as raw data into the +current buffer. See `yank-media' instead for a command that +inserts images as images. + +By default, data types that aren't supported by +`gui-get-selection' (i.e., that returns nothing if you actually +try to look at the selection) are not included by this command. +If ALL (interactively, the prefix), also include these +non-supported selection data types." + (interactive "P") + (let ((elements nil)) + ;; First gather all the data. + (dolist (type '(PRIMARY CLIPBOARD)) + (when-let ((data-types (gui-get-selection type 'TARGETS))) + (when (vectorp data-types) + (seq-do (lambda (data-type) + (unless (memq data-type '( TARGETS MULTIPLE + DELETE SAVE_TARGETS)) + (let ((data (gui-get-selection type data-type))) + (when (or data all) + ;; Remove duplicates -- the data in PRIMARY and + ;; CLIPBOARD are sometimes (mostly) identical, + ;; and sometimes not. + (let ((old (assq data-type elements))) + (when (or (not old) + (not (equal (nth 2 old) data))) + (push (list data-type type data) + elements))))))) + data-types)))) + ;; Then query the user. + (unless elements + (user-error "No elements in the primary selection or the clipboard")) + (let ((spec + (completing-read + "Yank type: " + (mapcar (lambda (e) + (format "%s:%s" (downcase (symbol-name (cadr e))) + (car e))) + elements) + nil t))) + (dolist (elem elements) + (when (equal (format "%s:%s" (downcase (symbol-name (cadr elem))) + (car elem)) + spec) + (insert (yank-media-types--format (car elem) (nth 2 elem)))))))) + +(defun yank-media-types--format (data-type data) + (cond + ((not (stringp data)) + (format "%s" data)) + ((string-match-p "\\`text/" (symbol-name data-type)) + ;; We may have utf-16, which Emacs won't detect automatically. + (let ((coding-system + (and (zerop (mod (length data) 2)) + (let ((stats (vector 0 0))) + (dotimes (i (length data)) + (when (zerop (elt data i)) + (setf (aref stats (mod i 2)) + (1+ (aref stats (mod i 2)))))) + ;; If we have more than 90% every-other nul, then it's + ;; pretty likely to be utf-16. + (cond + ((> (if (zerop (elt stats 1)) + 1 + (/ (float (elt stats 0)) + (float (elt stats 1)))) + 0.9) + ;; Big endian. + 'utf-16-be) + ((> (if (zerop (elt stats 0)) + 1 + (/ (float (elt stats 1)) + (float (elt stats 0)))) + 0.9) + ;; Little endian. + 'utf-16-le)))))) + (if coding-system + (decode-coding-string data coding-system) + ;; Some programs add a nul character at the end of text/* + ;; selections. Remove that. + (if (zerop (elt data (1- (length data)))) + (substring data 0 (1- (length data))) + data)))) + (t + data))) + +(provide 'yank-media) + +;;; yank-media.el ends here |