diff options
Diffstat (limited to 'lisp')
734 files changed, 52411 insertions, 28626 deletions
diff --git a/lisp/Makefile.in b/lisp/Makefile.in index 80955abfb5b..8728467977a 100644 --- a/lisp/Makefile.in +++ b/lisp/Makefile.in @@ -59,15 +59,6 @@ BYTE_COMPILE_EXTRA_FLAGS = # BYTE_COMPILE_EXTRA_FLAGS = --eval '(setq byte-compile-warnings (quote (not unresolved)))' # 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 -# (eg calc/calc-loaddefs.el). -LOADDEFS = $(lisp)/calendar/cal-loaddefs.el \ - $(lisp)/calendar/diary-loaddefs.el \ - $(lisp)/calendar/hol-loaddefs.el \ - $(lisp)/mh-e/mh-loaddefs.el \ - $(lisp)/net/tramp-loaddefs.el - # All generated autoload files. loaddefs = $(shell find ${srcdir} -name '*loaddefs.el' ! -name '.*') # Elisp files auto-generated. @@ -77,13 +68,18 @@ AUTOGENEL = ${loaddefs} ${srcdir}/cus-load.el ${srcdir}/finder-inf.el \ # Set load-prefer-newer for the benefit of the non-bootstrappers. BYTE_COMPILE_FLAGS = \ --eval '(setq load-prefer-newer t)' $(BYTE_COMPILE_EXTRA_FLAGS) +# ... but we must prefer .elc files for those in the early bootstrap. +# A larger `max-specpdl-size' is needed for emacs-lisp/comp.el. +compile-first: BYTE_COMPILE_FLAGS = \ + --eval '(setq max-specpdl-size 5000)' $(BYTE_COMPILE_EXTRA_FLAGS) # Files to compile before others during a bootstrap. This is done to # speed up the bootstrap process. They're ordered by size, so we use -# the slowest-compiler on the smallest file and move to larger files as the -# compiler gets faster. 'autoload.elc' comes last because it is not used by -# the compiler (so its compilation does not speed up subsequent compilations), -# it's only placed here so as to speed up generation of the loaddefs.el file. +# the slowest-compiler on the smallest file and move to larger files +# as the compiler gets faster. 'loaddefs-gen.elc'/'radix-tree.el' +# comes last because they're not used by the compiler (so its +# compilation does not speed up subsequent compilations), it's only +# placed here so as to speed up generation of the loaddefs.el files. COMPILE_FIRST = \ $(lisp)/emacs-lisp/macroexp.elc \ @@ -91,32 +87,27 @@ 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 +COMPILE_FIRST += $(lisp)/emacs-lisp/loaddefs-gen.elc +COMPILE_FIRST += $(lisp)/emacs-lisp/radix-tree.elc # Files to compile early in compile-main. Works around bug#25556. +# Also compile the ja-dic file used to convert the Japanese dictionary +# to speed things up. The org files are used to convert org files to +# texi files. MAIN_FIRST = ./emacs-lisp/eieio.el ./emacs-lisp/eieio-base.el \ - ./cedet/semantic/db.el + ./cedet/semantic/db.el ./emacs-lisp/cconv.el \ + ./international/ja-dic-cnv.el \ + ./org/ox.el ./org/ox-texinfo.el ./org/org-macro.el ./org/org-element.el \ + ./org/oc.el ./org/ol.el ./emacs-lisp/cl-lib.el # Prevent any settings in the user environment causing problems. -unexport EMACSDATA EMACSDOC EMACSPATH +unexport EMACSDATA EMACSDOC EMACSLOADPATH EMACSPATH # The actual Emacs command run in the targets below. -# Prevent any setting of EMACSLOADPATH in user environment causing problems. -emacs = EMACSLOADPATH= '$(EMACS)' $(EMACSOPT) +emacs = '$(EMACS)' $(EMACSOPT) ## Subdirectories, relative to builddir. SUBDIRS = $(sort $(shell find ${srcdir} -type d -print)) @@ -133,10 +124,12 @@ SUBDIRS_SUBDIRS = $(filter-out ${srcdir}/cedet% ${srcdir}/leim%,${SUBDIRS}) # cus-load and finder-inf are not explicitly requested by anything, so # we add them here to make sure they get built. -all: compile-main $(lisp)/cus-load.el $(lisp)/finder-inf.el +all: compile-main $(lisp)/cus-load.el $(lisp)/finder-inf.el generate-ja-dic \ + org-manuals PHONY_EXTRAS = -.PHONY: all custom-deps finder-data autoloads update-subdirs $(PHONY_EXTRAS) +.PHONY: all custom-deps finder-data autoloads update-subdirs $(PHONY_EXTRAS) \ + generate-ja-dic org-manuals # custom-deps and finder-data both used to scan _all_ the *.el files. # This could lead to problems in parallel builds if automatically @@ -167,6 +160,14 @@ $(lisp)/finder-inf.el: --eval '(setq generated-finder-keywords-file (unmsys--file-name "$(srcdir)/finder-inf.el"))' \ -f finder-compile-keywords-make-dist ${SUBDIRS_FINDER} +# This is the OKURO-NASI compilation trigger. +generate-ja-dic: main-first + $(AM_V_at)$(MAKE) -C ../leim generate-ja-dic EMACS="$(EMACS)" + $(AM_V_at)$(MAKE) compile-targets TARGETS="./leim/ja-dic/ja-dic.elc" + +org-manuals: main-first + $(AM_V_at)$(MAKE) -C ../doc/misc org.texi modus-themes.texi + ## Comments on loaddefs generation: # loaddefs depends on gen-lisp for two reasons: @@ -175,6 +176,9 @@ $(lisp)/finder-inf.el: # gets created before the final emacs is dumped. Having leim # dependencies in ../src as well would create a parallel race condition. # +# FIXME: 2) is no longer correct, so perhaps we could add unidata to +# gen-lisp now? +# # 2) Files that are marked no-update-autoloads still get recorded in loaddefs. # So those files should be generated before we make autoloads, if we # don't want a successive make autoloads to change the output file. @@ -194,19 +198,13 @@ $(lisp)/finder-inf.el: # We make $(lisp)/loaddefs.el a dependency of .PHONY to cause Make to # ignore its time stamp. That's because the real dependencies of # loaddefs.el aren't known to Make, they are implemented in -# batch-update-autoloads, which only updates the autoloads whose -# sources have changed. - -# Use expand-file-name rather than $abs_scrdir so that Emacs does not -# get confused when it compares file-names for equality. +# loaddefs-generate--emacs-batch. autoloads .PHONY: $(lisp)/loaddefs.el -$(lisp)/loaddefs.el: gen-lisp $(LOADDEFS) - $(AM_V_GEN)$(emacs) -l autoload \ - --eval '(setq autoload-ensure-writable t)' \ - --eval '(setq autoload-builtin-package-versions t)' \ - --eval '(setq generated-autoload-file (expand-file-name (unmsys--file-name "$@")))' \ - -f batch-update-autoloads ${SUBDIRS_ALMOST} +$(lisp)/loaddefs.el: gen-lisp $(LOADDEFS) $(lisp)/emacs-lisp/loaddefs-gen.elc + $(AM_V_GEN)$(emacs) \ + -l $(lisp)/emacs-lisp/loaddefs-gen.elc \ + -f loaddefs-generate--emacs-batch ${SUBDIRS_ALMOST} # autoloads only runs when loaddefs.el is nonexistent, although it # generates a number of different files. Provide a force option to enable @@ -216,6 +214,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: @@ -263,9 +264,9 @@ ${ETAGS}: FORCE ## compile-main. But maybe this is not even necessary any more now ## that this uses relative filenames. TAGS: ${ETAGS} ${tagsfiles} - $(AM_V_at)rm -f $@ + $(AM_V_GEN)rm -f $@ $(AM_V_at)touch $@ - $(AM_V_GEN)ls ${tagsfiles} | xargs $(XARGS_LIMIT) "${ETAGS}" -a -o $@ + $(AM_V_at)ls ${tagsfiles} | xargs $(XARGS_LIMIT) "${ETAGS}" -a -o $@ # The src/Makefile.in has its own set of dependencies and when they decide @@ -312,9 +313,23 @@ endif # An old-fashioned suffix rule, which, according to the GNU Make manual, # cannot have prerequisites. ifeq ($(HAVE_NATIVE_COMP),yes) +ifeq ($(ANCIENT),yes) +# The first compilation of compile-first, using an interpreted compiler: +# The resulting .elc files get given a date of 1971-01-01 so that their +# date stamp is earlier than the source files, causing these to be compiled +# into native code at the second recursive invocation of this $(MAKE), +# using these .elc's. This is faster than just compiling the native code +# directly using the interpreted compile-first files. (Note: 1970-01-01 +# fails on some systems.) +.el.elc: + $(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) \ + -l comp -f batch-byte-compile $< + touch -t 197101010000 $@ +else .el.elc: $(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) \ -l comp -f batch-byte+native-compile $< +endif else .el.elc: $(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $< @@ -346,10 +361,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 +377,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: @@ -435,57 +462,6 @@ compile-one-process: $(LOADDEFS) compile-first $(emacs) $(BYTE_COMPILE_FLAGS) \ --eval "(batch-byte-recompile-directory 0)" $(lisp) -# Update MH-E internal autoloads. These are not to be confused with -# the autoloads for the MH-E entry points, which are already in loaddefs.el. -MH_E_DIR = $(lisp)/mh-e -MH_E_SRC = $(sort $(wildcard ${MH_E_DIR}/mh*.el)) -MH_E_SRC := $(filter-out ${MH_E_DIR}/mh-loaddefs.el,${MH_E_SRC}) - -.PHONY: mh-autoloads -mh-autoloads: $(MH_E_DIR)/mh-loaddefs.el -$(MH_E_DIR)/mh-loaddefs.el: $(MH_E_SRC) - $(AM_V_GEN)$(emacs) -l autoload \ - --eval "(setq generate-autoload-cookie \";;;###mh-autoload\")" \ - --eval "(setq generated-autoload-file (expand-file-name (unmsys--file-name \"$@\")))" \ - -f batch-update-autoloads $(MH_E_DIR) - -# Update TRAMP internal autoloads. Maybe we could move tramp*.el into -# an own subdirectory. OTOH, it does not hurt to keep them in -# lisp/net. -TRAMP_DIR = $(lisp)/net -TRAMP_SRC = $(sort $(wildcard ${TRAMP_DIR}/tramp*.el)) -TRAMP_SRC := $(filter-out ${TRAMP_DIR}/tramp-loaddefs.el,${TRAMP_SRC}) - -$(TRAMP_DIR)/tramp-loaddefs.el: $(TRAMP_SRC) - $(AM_V_GEN)$(emacs) -l autoload \ - --eval "(setq generate-autoload-cookie \";;;###tramp-autoload\")" \ - --eval "(setq generated-autoload-file (expand-file-name (unmsys--file-name \"$@\")))" \ - -f batch-update-autoloads $(TRAMP_DIR) - -CAL_DIR = $(lisp)/calendar -## Those files that may contain internal calendar autoload cookies. -CAL_SRC = $(addprefix ${CAL_DIR}/,diary-lib.el holidays.el lunar.el solar.el) -CAL_SRC := $(sort ${CAL_SRC} $(wildcard ${CAL_DIR}/cal-*.el)) -CAL_SRC := $(filter-out ${CAL_DIR}/cal-loaddefs.el,${CAL_SRC}) - -$(CAL_DIR)/cal-loaddefs.el: $(CAL_SRC) - $(AM_V_GEN)$(emacs) -l autoload \ - --eval "(setq generate-autoload-cookie \";;;###cal-autoload\")" \ - --eval "(setq generated-autoload-file (expand-file-name (unmsys--file-name \"$@\")))" \ - -f batch-update-autoloads $(CAL_DIR) - -$(CAL_DIR)/diary-loaddefs.el: $(CAL_SRC) $(CAL_DIR)/cal-loaddefs.el - $(AM_V_GEN)$(emacs) -l autoload \ - --eval "(setq generate-autoload-cookie \";;;###diary-autoload\")" \ - --eval "(setq generated-autoload-file (expand-file-name (unmsys--file-name \"$@\")))" \ - -f batch-update-autoloads $(CAL_DIR) - -$(CAL_DIR)/hol-loaddefs.el: $(CAL_SRC) $(CAL_DIR)/diary-loaddefs.el - $(AM_V_GEN)$(emacs) -l autoload \ - --eval "(setq generate-autoload-cookie \";;;###holiday-autoload\")" \ - --eval "(setq generated-autoload-file (expand-file-name (unmsys--file-name \"$@\")))" \ - -f batch-update-autoloads $(CAL_DIR) - .PHONY: bootstrap-clean distclean maintainer-clean bootstrap-clean: diff --git a/lisp/abbrev.el b/lisp/abbrev.el index b7216f5d633..e875d77faae 100644 --- a/lisp/abbrev.el +++ b/lisp/abbrev.el @@ -68,13 +68,11 @@ be replaced by its expansion." (define-obsolete-variable-alias 'edit-abbrevs-map 'edit-abbrevs-mode-map "24.4") -(defvar edit-abbrevs-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\C-x\C-s" 'abbrev-edit-save-buffer) - (define-key map "\C-x\C-w" 'abbrev-edit-save-to-file) - (define-key map "\C-c\C-c" 'edit-abbrevs-redefine) - map) - "Keymap used in `edit-abbrevs'.") +(defvar-keymap edit-abbrevs-mode-map + :doc "Keymap used in `edit-abbrevs'." + "C-x C-s" #'abbrev-edit-save-buffer + "C-x C-w" #'abbrev-edit-save-to-file + "C-c C-c" #'edit-abbrevs-redefine) (defun kill-all-abbrevs () "Undefine all defined abbrevs." @@ -176,7 +174,7 @@ that may be omitted (it is usually omitted)." (defun edit-abbrevs-redefine () "Redefine abbrevs according to current buffer contents." - (interactive) + (interactive nil edit-abbrevs-mode) (save-restriction (widen) (define-abbrevs t) @@ -279,7 +277,8 @@ abbrevs have been saved." (list (read-file-name "Save abbrevs to file: " (file-name-directory (expand-file-name abbrev-file-name)) - abbrev-file-name))) + abbrev-file-name)) + edit-abbrevs-mode) (edit-abbrevs-redefine) (write-abbrev-file file t)) @@ -287,7 +286,7 @@ abbrevs have been saved." "Save all the user-level abbrev definitions in current buffer. The saved abbrevs are written to the file specified by `abbrev-file-name'." - (interactive) + (interactive nil edit-abbrevs-mode) (abbrev-edit-save-to-file abbrev-file-name)) @@ -491,7 +490,8 @@ PROPS is a list of properties." (defun abbrev-table-p (object) "Return non-nil if OBJECT is an abbrev table." (and (obarrayp object) - (numberp (abbrev-table-get object :abbrev-table-modiff)))) + (numberp (ignore-error 'wrong-type-argument + (abbrev-table-get object :abbrev-table-modiff))))) (defun abbrev-table-empty-p (object &optional ignore-system) "Return nil if there are no abbrev symbols in OBJECT. @@ -604,7 +604,8 @@ PROPS is a property list. The following properties are special: An obsolete but still supported calling form is: -\(define-abbrev TABLE ABBREV EXPANSION &optional HOOK COUNT SYSTEM)." +\(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) @@ -1164,7 +1165,7 @@ Properties with special meaning: - `:enable-function' can be set to a function of no arguments 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'. @@ -1212,7 +1213,30 @@ SORTFUN is passed to `sort' to change the default ordering." (define-derived-mode edit-abbrevs-mode fundamental-mode "Edit-Abbrevs" "Major mode for editing the list of abbrev definitions. This mode is for editing abbrevs in a buffer prepared by `edit-abbrevs', -which see.") +which see." + :interactive nil) + +(defun abbrev--possibly-save (query &optional arg) + ;; Query mode. + (if (eq query 'query) + (and save-abbrevs abbrevs-changed) + ;; Maybe save abbrevs, and record whether we either saved them or + ;; asked to. + (and save-abbrevs + abbrevs-changed + (progn + (if (or arg + (eq save-abbrevs 'silently) + (y-or-n-p (format "Save abbrevs in %s? " abbrev-file-name))) + (progn + (write-abbrev-file nil) + nil) + ;; Don't keep bothering user if they say no. + (setq abbrevs-changed nil) + ;; Inhibit message in `save-some-buffers'. + t))))) + +(add-hook 'save-some-buffers-functions #'abbrev--possibly-save) (provide 'abbrev) diff --git a/lisp/align.el b/lisp/align.el index 5e02520aae0..9364d546654 100644 --- a/lisp/align.el +++ b/lisp/align.el @@ -160,7 +160,8 @@ string), this heuristic is used to determine how far before and after point we should search in looking for a region separator. Larger values can mean slower performance in large files, although smaller values may cause unexpected behavior at times." - :type 'integer + :type '(choice (const :tag "Don't use heuristic when aligning a region" nil) + integer) :group 'align) (defcustom align-highlight-change-face 'highlight @@ -176,7 +177,7 @@ values may cause unexpected behavior at times." (defcustom align-large-region 10000 "If an integer, defines what constitutes a \"large\" region. If nil, then no messages will ever be printed to the minibuffer." - :type 'integer + :type '(choice (const :tag "Align a large region silently" nil) integer) :group 'align) (defcustom align-c++-modes '(c++-mode c-mode java-mode) @@ -356,11 +357,11 @@ The possible settings for `align-region-separate' are: (cons :tag "Valid" (const :tag "(Return non-nil if rule is valid)" valid) - (function :value t)) + (function :value always)) (cons :tag "Run If" (const :tag "(Return non-nil if rule should run)" run-if) - (function :value t)) + (function :value always)) (cons :tag "Column" (const :tag "(Column to fix alignment at)" column) (choice :value comment-column @@ -545,16 +546,16 @@ The possible settings for `align-region-separate' are: (regexp . "\\(\\s-*\\)\\\\\\\\") (modes . align-tex-modes)) - ;; With a numeric prefix argument, or C-u, space delimited text - ;; tables will be aligned. + ;; Align space delimited text as columns. (text-column (regexp . "\\(^\\|\\S-\\)\\([ \t]+\\)\\(\\S-\\|$\\)") (group . 2) (modes . align-text-modes) (repeat . t) (run-if . ,(lambda () - (and current-prefix-arg - (not (eq '- current-prefix-arg)))))) + (and (not (eq '- current-prefix-arg)) + (not (apply #'provided-mode-derived-p + major-mode align-tex-modes)))))) ;; With a negative prefix argument, lists of dollar figures will ;; be aligned. @@ -836,11 +837,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 +901,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 +929,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 +942,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 b49945d85e7..4624c236f5a 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 b379e710940..d5db9ecfed0 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") @@ -234,7 +234,7 @@ This vector holds the faces used for SGR control sequence parameters 0 to 7. This variable is obsolete. To customize the display of faces used by -ansi-color, change 'ansi-color-FACE', e.g. `ansi-color-bold'. To +ansi-color, change `ansi-color-FACE', e.g. `ansi-color-bold'. To customize the actual faces used (e.g. to temporarily display SGR control sequences differently), use `ansi-color-basic-faces-vector'." :type '(vector face face face face face face face face) @@ -249,7 +249,7 @@ This vector holds the colors used for SGR control sequence parameters 30 to 37 (foreground colors) and 40 to 47 (background colors). This variable is obsolete. To customize the display of colors used by -ansi-color, change 'ansi-color-COLOR', e.g. `ansi-color-red'. To +ansi-color, change `ansi-color-COLOR', e.g. `ansi-color-red'. To customize the actual faces used (e.g. to temporarily display SGR control sequences differently), use `ansi-color-normal-colors-vector'." :type '(vector (choice color (cons color color)) @@ -347,6 +347,10 @@ version of that color." "\e\\[[\x30-\x3F]*[\x20-\x2F]*[\x40-\x7E]" "Regexp matching an ANSI control sequence.") +(defconst ansi-color--control-seq-fragment-regexp + "\e\\[[\x30-\x3F]*[\x20-\x2F]*\\|\e" + "Regexp matching a partial ANSI control sequence.") + (defconst ansi-color-parameter-regexp "\\([0-9]*\\)[m;]" "Regexp that matches SGR control sequence parameters.") @@ -458,11 +462,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,43 +484,31 @@ 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) + (if (string-match + (concat "\\(?:" + ansi-color--control-seq-fragment-regexp + "\\)\\'") + string start) (let ((pos (match-beginning 0))) (setq fragment (substring string pos)) 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 +523,159 @@ 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 + (concat "\\(?:" ansi-color--control-seq-fragment-regexp "\\)\\'") + 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,17 +685,23 @@ 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. (while (re-search-forward ansi-color-control-seq-regexp end-marker t) (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 (point)) + (while (re-search-forward ansi-color--control-seq-fragment-regexp + end-marker t)) + (if (and (/= (point) start) + (= (point) end-marker)) + (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 +723,60 @@ 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)))) + (while (re-search-forward ansi-color--control-seq-fragment-regexp + end-marker t)) + (if (and (/= (point) start-marker) + (= (point) end-marker)) + (progn + (goto-char (match-beginning 0)) + (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 +884,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 +913,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 +1043,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 5ff29206d96..0b84f9fa63b 100644 --- a/lisp/apropos.el +++ b/lisp/apropos.el @@ -493,7 +493,12 @@ Intended as a value for `revert-buffer-function'." \\{apropos-mode-map}" (make-local-variable 'apropos--current) - (setq-local revert-buffer-function #'apropos--revert-buffer)) + (setq-local revert-buffer-function #'apropos--revert-buffer) + (setq-local outline-regexp "^[^ \n]+" + outline-level (lambda () 1) + outline-minor-mode-cycle t + outline-minor-mode-highlight t + outline-minor-mode-use-buttons t)) (defvar apropos-multi-type t "If non-nil, this apropos query concerns multiple types. @@ -513,11 +518,11 @@ variables, not just user options." (if (or current-prefix-arg apropos-do-all) "variable" "user option")) current-prefix-arg)) - (apropos-command pattern nil + (apropos-command pattern (or do-all apropos-do-all) (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 @@ -658,7 +663,10 @@ search for matches for any two (or more) of those words. With \\[universal-argument] prefix, or if `apropos-do-all' is non-nil, consider all symbols (if they match PATTERN). -Return list of symbols and documentation found." +Return list of symbols and documentation found. + +The *Apropos* window will be selected if `help-window-select' is +non-nil." (interactive (list (apropos-read-pattern "symbol") current-prefix-arg)) (setq apropos--current (list #'apropos pattern do-all)) @@ -846,7 +854,7 @@ Returns list of symbols and values found." f v p) apropos-accumulator)))))) (let ((apropos-multi-type do-all)) - (apropos-print nil "\n----------------\n"))) + (apropos-print nil "\n"))) ;;;###autoload (defun apropos-local-value (pattern &optional buffer) @@ -866,7 +874,7 @@ Optional arg BUFFER (default: current buffer) is the buffer to check." apropos-all-words apropos-accumulator)) (setq var (apropos-value-internal #'local-variable-if-set-p symb #'symbol-value))) - (when (and (fboundp 'apropos-false-hit-str) (apropos-false-hit-str var)) + (when (apropos-false-hit-str var) (setq var nil)) (when var (setq apropos-accumulator (cons (list symb (apropos-score-str var) nil var) @@ -940,13 +948,14 @@ Returns list of symbols and documentation found." (defun apropos-value-internal (predicate symbol function) (when (funcall predicate symbol) - (setq symbol (prin1-to-string - (if (memq symbol '(command-history minibuffer-history)) - ;; The value we're looking for will always be in - ;; the first element of these two lists, so skip - ;; that value. - (cdr (funcall function symbol)) - (funcall function symbol)))) + (let ((print-escape-newlines t)) + (setq symbol (prin1-to-string + (if (memq symbol '(command-history minibuffer-history)) + ;; The value we're looking for will always be in + ;; the first element of these two lists, so skip + ;; that value. + (cdr (funcall function symbol)) + (funcall function symbol))))) (when (string-match apropos-regexp symbol) (if apropos-match-face (put-text-property (match-beginning 0) (match-end 0) @@ -1046,7 +1055,13 @@ non-nil." (setq sepa (goto-char sepb))))) (defun apropos-documentation-check-elc-file (file) - (if (member file apropos-files-scanned) + ;; .elc files have the location of the file specified as #$, but for + ;; built-in files, that's a relative name (while for the rest, it's + ;; absolute). So expand the name in the former case. + (unless (file-name-absolute-p file) + (setq file (expand-file-name file lisp-directory))) + (if (or (member file apropos-files-scanned) + (not (file-exists-p file))) nil (let (symbol doc beg end this-is-a-variable) (setq apropos-files-scanned (cons file apropos-files-scanned)) @@ -1156,13 +1171,15 @@ as a heading." (old-buffer (current-buffer)) (inhibit-read-only t) (button-end 0) + (first t) symbol item) (set-buffer standard-output) (apropos-mode) (apropos--preamble text) (dolist (apropos-item p) - (when (and spacing (not (bobp))) - (princ spacing)) + (if (and spacing (not first)) + (princ spacing) + (setq first nil)) (setq symbol (car apropos-item)) ;; Insert dummy score element for backwards compatibility with 21.x ;; apropos-item format. @@ -1236,12 +1253,27 @@ as a heading." 'apropos-user-option 'apropos-variable) (not nosubst)) + ;; Insert an excerpt of variable values. + (when (boundp symbol) + (insert " Value: ") + (let* ((print-escape-newlines t) + (value (prin1-to-string (symbol-value symbol))) + (truncated (truncate-string-to-width + value (- (window-width) 20) nil nil t))) + (insert truncated) + (unless (equal value truncated) + (buttonize-region (1- (point)) (point) + (lambda (_) + (message "Value: %s" value)))) + (insert "\n"))) (apropos-print-doc 7 'apropos-group t) (apropos-print-doc 6 'apropos-face t) (apropos-print-doc 5 'apropos-widget t) (apropos-print-doc 4 'apropos-plist nil)) (setq-local truncate-partial-width-windows t) - (setq-local truncate-lines t)))) + (setq-local truncate-lines t))) + (when help-window-select + (select-window (get-buffer-window "*Apropos*")))) (prog1 apropos-accumulator (setq apropos-accumulator ()))) ; permit gc @@ -1249,12 +1281,13 @@ as a heading." (let ((doc (nth i apropos-item))) (when (stringp doc) (if apropos-compact-layout - (insert (propertize "\t" 'display '(space :align-to 32)) " ") - (insert " ")) + (insert (propertize "\t" 'display '(space :align-to 32))) + (insert " ")) (if apropos-multi-type (let ((button-face (button-type-get type 'face))) (unless (consp button-face) (setq button-face (list button-face))) + (insert " ") (insert-text-button (if apropos-compact-layout (format "<%s>" (button-type-get type 'apropos-short-label)) @@ -1276,7 +1309,9 @@ as a heading." (cond ((equal doc "") (setq doc "(not documented)")) (do-keys - (setq doc (substitute-command-keys doc)))) + (setq doc (or (ignore-errors + (substitute-command-keys doc)) + doc)))) (insert doc) (if (equal doc "(not documented)") (put-text-property opoint (point) 'font-lock-face 'shadow)) @@ -1322,17 +1357,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 b1042be348c..1c5faa1152b 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) @@ -621,12 +617,8 @@ OLDMODE will be modified accordingly just like chmod(2) would have done." (defun archive-unixdate (low high) "Stringify Unix (LOW HIGH) date." - (let* ((time (list high low)) - (str (current-time-string time))) - (format "%s-%s-%s" - (substring str 8 10) - (substring str 4 7) - (format-time-string "%Y" time)))) + (let ((system-time-locale "C")) + (format-time-string "%e-%b-%Y" (list high low)))) (defun archive-unixtime (low high) "Stringify Unix (LOW HIGH) time." @@ -1071,7 +1063,8 @@ NEW-NAME." #'archive--file-desc-ext-file-name (or (archive-get-marked ?*) (list (archive-get-descr)))))) (list names - (read-file-name (format "Copy %s to: " (string-join names ", ")))))) + (read-file-name (format "Copy %s to: " (string-join names ", ")) + nil default-directory)))) (unless (consp files) (setq files (list files))) (when (and (> (length files) 1) @@ -1348,7 +1341,8 @@ NEW-NAME." t) (defun archive-*-write-file-member (archive descr command) - (let* ((ename (archive--file-desc-ext-file-name descr)) + (let* ((archive (expand-file-name archive)) + (ename (archive--file-desc-ext-file-name descr)) (tmpfile (expand-file-name ename archive-tmpdir)) (top (directory-file-name (file-name-as-directory archive-tmpdir))) (default-directory (file-name-as-directory top))) @@ -1372,6 +1366,7 @@ NEW-NAME." (setq ename (encode-coding-string ename archive-file-name-coding-system)) (let* ((coding-system-for-write 'no-conversion) + (default-directory (file-name-as-directory archive-tmpdir)) (exitcode (apply #'call-process (car command) nil diff --git a/lisp/array.el b/lisp/array.el index 31cf9cf3028..08c5ff45ddd 100644 --- a/lisp/array.el +++ b/lisp/array.el @@ -767,29 +767,27 @@ Return COLUMN." ;;; Array mode. -(defvar array-mode-map - (let ((map (make-keymap))) - (define-key map "\M-ad" #'array-display-local-variables) - (define-key map "\M-am" #'array-make-template) - (define-key map "\M-ae" #'array-expand-rows) - (define-key map "\M-ar" #'array-reconfigure-rows) - (define-key map "\M-a=" #'array-what-position) - (define-key map "\M-ag" #'array-goto-cell) - (define-key map "\M-af" #'array-fill-rectangle) - (define-key map "\C-n" #'array-next-row) - (define-key map "\C-p" #'array-previous-row) - (define-key map "\C-f" #'array-forward-column) - (define-key map "\C-b" #'array-backward-column) - (define-key map "\M-n" #'array-copy-down) - (define-key map "\M-p" #'array-copy-up) - (define-key map "\M-f" #'array-copy-forward) - (define-key map "\M-b" #'array-copy-backward) - (define-key map "\M-\C-n" #'array-copy-row-down) - (define-key map "\M-\C-p" #'array-copy-row-up) - (define-key map "\M-\C-f" #'array-copy-column-forward) - (define-key map "\M-\C-b" #'array-copy-column-backward) - map) - "Keymap used in array mode.") +(defvar-keymap array-mode-map + :doc "Keymap used in array mode." + "M-a d" #'array-display-local-variables + "M-a m" #'array-make-template + "M-a e" #'array-expand-rows + "M-a r" #'array-reconfigure-rows + "M-a =" #'array-what-position + "M-a g" #'array-goto-cell + "M-a f" #'array-fill-rectangle + "C-n" #'array-next-row + "C-p" #'array-previous-row + "C-f" #'array-forward-column + "C-b" #'array-backward-column + "M-n" #'array-copy-down + "M-p" #'array-copy-up + "M-f" #'array-copy-forward + "M-b" #'array-copy-backward + "C-M-n" #'array-copy-row-down + "C-M-p" #'array-copy-row-up + "C-M-f" #'array-copy-column-forward + "C-M-b" #'array-copy-column-backward) (put 'array-mode 'mode-class 'special) diff --git a/lisp/auth-source.el b/lisp/auth-source.el index dc89622f425..fc62e36dfc2 100644 --- a/lisp/auth-source.el +++ b/lisp/auth-source.el @@ -45,6 +45,9 @@ (require 'cl-lib) (require 'eieio) +(declare-function gnutls-symmetric-decrypt "gnutls.c") +(declare-function gnutls-ciphers "gnutls.c") + (autoload 'secrets-create-item "secrets") (autoload 'secrets-delete-item "secrets") (autoload 'secrets-get-alias "secrets") @@ -253,7 +256,7 @@ can get pretty complex." (choice :tag "Authentication backend choice" (string :tag "Authentication Source (file)") (list - :tag "Secret Service API/KWallet/GNOME Keyring" + :tag "Secret Service API/KWallet/GNOME Keyring/KeyPassXC" (const :format "" :value :secrets) (choice :tag "Collection to use" (string :tag "Collection name") @@ -277,15 +280,16 @@ can get pretty complex." (const :tag "default" default)))) (repeat :tag "Extra Parameters" :inline t (choice :tag "Extra parameter" + :value (:host t) (list - :tag "Host" + :tag "Host" :inline t (const :format "" :value :host) (choice :tag "Host (machine) choice" (const :tag "Any" t) (regexp :tag "Regular expression"))) (list - :tag "Protocol" + :tag "Protocol" :inline t (const :format "" :value :port) (choice :tag "Protocol" @@ -569,19 +573,24 @@ which says: or P. The resulting token will only have keys user, host, and port.\" -:create \\='(A B C) also means to create a token if possible. +:create \\='(A B C) or +:create \\='(:unencrypted A B :encrypted C) +also means to create a token if possible. The behavior is like :create t but if the list contains any parameter, that parameter will be required in the resulting -token. The value for that parameter will be obtained from the -search parameters or from user input. If any queries are needed, -the alist `auth-source-creation-defaults' will be checked for the -default value. If the user, host, or port are missing, the alist -`auth-source-creation-prompts' will be used to look up the -prompts IN THAT ORDER (so the `user' prompt will be queried first, -then `host', then `port', and finally `secret'). Each prompt string -can use %u, %h, and %p to show the user, host, and port. The prompt -is formatted with `format-prompt', a trailing \": \" is removed. +token (the second form is used only with the plstore backend and +specifies if any of the extra parameters should be stored in +encrypted format.) The value for that parameter will be obtained +from the search parameters or from user input. If any queries +are needed, the alist `auth-source-creation-defaults' will be +checked for the default value. If the user, host, or port are +missing, the alist `auth-source-creation-prompts' will be used to +look up the prompts IN THAT ORDER (so the `user' prompt will be +queried first, then `host', then `port', and finally `secret'). +Each prompt string can use %u, %h, and %p to show the user, host, +and port. The prompt is formatted with `format-prompt', a +trailing \": \" is removed. Here's an example: @@ -850,15 +859,17 @@ while \(:host t) would find all host entries." (cl-return 'no))) 'no)))) -(defun auth-source-pick-first-password (&rest spec) - "Pick the first secret found from applying SPEC to `auth-source-search'." - (let* ((result (nth 0 (apply #'auth-source-search (plist-put spec :max 1)))) - (secret (plist-get result :secret))) - +(defun auth-info-password (auth-info) + "Return the :secret password from the AUTH-INFO." + (let ((secret (plist-get auth-info :secret))) (if (functionp secret) (funcall secret) secret))) +(defun auth-source-pick-first-password (&rest spec) + "Pick the first secret found by applying `auth-source-search' to SPEC." + (auth-info-password (car (apply #'auth-source-search (plist-put spec :max 1))))) + (defun auth-source-format-prompt (prompt alist) "Format PROMPT using %x (for any character x) specifiers in ALIST. Remove trailing \": \"." @@ -1797,10 +1808,9 @@ authentication tokens: (plist-put artificial :save-function - (let* ((collection collection) - (item (plist-get artificial :label)) - (secret (plist-get artificial :secret)) - (secret (if (functionp secret) (funcall secret) secret))) + (let ((collection collection) + (item (plist-get artificial :label)) + (secret (auth-info-password artificial))) (lambda () (auth-source-secrets-saver collection item secret args))))) @@ -1948,7 +1958,7 @@ entries for git.gnus.org: (defun auth-source--decode-octal-string (string) - "Convert octal STRING to utf-8 string. E.g: 'a\134b' to 'a\b'." + "Convert octal STRING to utf-8 string. E.g: \"a\134b\" to \"a\b\"." (let ((list (string-to-list string)) (size (length string))) (decode-coding-string @@ -2126,12 +2136,17 @@ entries for git.gnus.org: (let* ((base-required '(host user port secret)) (base-secret '(secret)) ;; we know (because of an assertion in auth-source-search) that the - ;; :create parameter is either t or a list (which includes nil) - (create-extra (if (eq t create) nil create)) + ;; :create parameter is either t, or a list (which includes nil + ;; or a plist) + (create-extra-secret (plist-get create :encrypted)) + (create-extra (if (eq t create) nil + (or (append (plist-get create :unencrypted) + create-extra-secret) create))) (current-data (car (auth-source-search :max 1 :host host :port port))) (required (append base-required create-extra)) + (required-secret (append base-secret create-extra-secret)) ;; `valist' is an alist valist ;; `artificial' will be returned if no creation is needed @@ -2153,10 +2168,11 @@ entries for git.gnus.org: (auth-source--aput valist br br-choice)))))) ;; for extra required elements, see if the spec includes a value for them - (dolist (er create-extra) - (let ((k (auth-source--symbol-keyword er)) - (keys (cl-loop for i below (length spec) by 2 - collect (nth i spec)))) + (let ((keys (cl-loop for i below (length spec) by 2 + collect (nth i spec))) + k) + (dolist (er create-extra) + (setq k (auth-source--symbol-keyword er)) (when (memq k keys) (auth-source--aput valist er (plist-get spec k))))) @@ -2220,7 +2236,7 @@ entries for git.gnus.org: (eval default))))) (when data - (if (member r base-secret) + (if (member r required-secret) (setq secret-artificial (plist-put secret-artificial (auth-source--symbol-keyword r) @@ -2407,9 +2423,7 @@ MODE can be \"login\" or \"password\"." :require '(:user :secret) :create nil)))) (user (plist-get auth-info :user)) - (password (plist-get auth-info :secret))) - (when (functionp password) - (setq password (funcall password))) + (password (auth-info-password auth-info))) (list user password auth-info))) ;;; Tiny mode for editing .netrc/.authinfo modes (that basically just diff --git a/lisp/autoinsert.el b/lisp/autoinsert.el index 727e383bb52..c12c554498b 100644 --- a/lisp/autoinsert.el +++ b/lisp/autoinsert.el @@ -89,9 +89,10 @@ If this contains a %s, that will be replaced by the matching rule." :type 'string :version "28.1") +(declare-function sgml-tag "textmodes/sgml-mode" (&optional str arg)) (defcustom auto-insert-alist - '((("\\.\\([Hh]\\|hh\\|hpp\\|hxx\\|h\\+\\+\\)\\'" . "C / C++ header") + `((("\\.\\([Hh]\\|hh\\|hpp\\|hxx\\|h\\+\\+\\)\\'" . "C / C++ header") (replace-regexp-in-string "[^A-Z0-9]" "_" (string-replace @@ -113,7 +114,7 @@ If this contains a %s, that will be replaced by the matching rule." (("[Mm]akefile\\'" . "Makefile") . "makefile.inc") - (html-mode . (lambda () (sgml-tag "html"))) + (html-mode . ,(lambda () (sgml-tag "html"))) (plain-tex-mode . "tex-insert.tex") (bibtex-mode . "tex-insert.tex") @@ -128,9 +129,9 @@ If this contains a %s, that will be replaced by the matching rule." "\n\\end{document}") (("/bin/.*[^/]\\'" . "Shell-Script mode magic number") . - (lambda () - (if (eq major-mode (default-value 'major-mode)) - (sh-mode)))) + ,(lambda () + (if (eq major-mode (default-value 'major-mode)) + (sh-mode)))) (ada-mode . ada-header) @@ -171,7 +172,7 @@ If this contains a %s, that will be replaced by the matching rule." '(setq v1 (let (modes) (mapatoms (lambda (mode) (let ((name (symbol-name mode))) - (when (string-match "-mode$" name) + (when (string-match "-mode\\'" name) (push name modes))))) (sort modes 'string<))) (completing-read "Local variables for mode: " v1 nil t) @@ -210,7 +211,8 @@ If this contains a %s, that will be replaced by the matching rule." "\n")) ((let ((minibuffer-help-form v2)) (completing-read "Keyword, C-h: " v1 nil t)) - str ", ") & -2 " + str ", ") + & -2 " \;; This program is free software; you can redistribute it and/or modify \;; it under the terms of the GNU General Public License as published by @@ -415,6 +417,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/autorevert.el b/lisp/autorevert.el index 97a122b7bcf..918c0c7f19d 100644 --- a/lisp/autorevert.el +++ b/lisp/autorevert.el @@ -692,7 +692,7 @@ system.") (defun auto-revert-notify-handler (event) "Handle an EVENT returned from file notification." - (with-demoted-errors + (with-demoted-errors "Error while auto-reverting: %S" (let* ((descriptor (car event)) (action (nth 1 event)) (file (nth 2 event)) diff --git a/lisp/avoid.el b/lisp/avoid.el index b53d84d2e8d..2e77c8feff1 100644 --- a/lisp/avoid.el +++ b/lisp/avoid.el @@ -293,6 +293,8 @@ accumulated, and tries to keep it close to zero." (mouse-avoidance-set-mouse-position (cons (+ (car (cdr cur)) deltax) (+ (cdr (cdr cur)) deltay)))))) +(defvar x-pointer-invisible) ; silence byte-compiler + (defun mouse-avoidance-random-shape () "Return a random cursor shape. This assumes that any variable whose name begins with x-pointer- and @@ -300,12 +302,14 @@ has an integer value is a valid cursor shape. You might want to redefine this function to suit your own tastes." (if (null mouse-avoidance-pointer-shapes) (progn - (setq mouse-avoidance-pointer-shapes - (mapcar (lambda (x) (symbol-value (intern x))) - (all-completions "x-pointer-" obarray - (lambda (x) - (and (boundp x) - (integerp (symbol-value x))))))))) + (dolist (i (all-completions "x-pointer-" obarray + (lambda (x) + (and (boundp x) + (integerp (symbol-value x)))))) + (ignore-errors + (let ((value (symbol-value (intern i)))) + (when (< value x-pointer-invisible) + (push value mouse-avoidance-pointer-shapes))))))) (seq-random-elt mouse-avoidance-pointer-shapes)) (defun mouse-avoidance-ignore-p () @@ -317,7 +321,8 @@ redefine this function to suit your own tastes." (not (eq (car mp) (selected-frame))) ;; Don't interfere with ongoing `mouse-drag-and-drop-region' ;; (Bug#36269). - (eq track-mouse 'dropping) + (or (eq track-mouse 'dropping) + (eq track-mouse 'drag-source)) ;; Don't do anything if last event was a mouse event. ;; FIXME: this code fails in the case where the mouse was moved ;; since the last key-press but without generating any event. diff --git a/lisp/battery.el b/lisp/battery.el index c899fb6e438..3cff3167a6c 100644 --- a/lisp/battery.el +++ b/lisp/battery.el @@ -96,12 +96,14 @@ Value does not include \".\" or \"..\"." (cond ((member battery-upower-service (dbus-list-activatable-names)) #'battery-upower) ((and (eq system-type 'gnu/linux) + (file-readable-p "/sys/") (battery--find-linux-sysfs-batteries)) #'battery-linux-sysfs) ((and (eq system-type 'gnu/linux) (file-directory-p "/proc/acpi/battery")) #'battery-linux-proc-acpi) ((and (eq system-type 'gnu/linux) + (file-readable-p "/proc/") (file-readable-p "/proc/apm")) #'battery-linux-proc-apm) ((and (eq system-type 'berkeley-unix) @@ -113,6 +115,10 @@ Value does not include \".\" or \"..\"." (and (eq (call-process "pmset" nil t nil "-g" "ps") 0) (not (bobp)))))) #'battery-pmset) + ((and (eq system-type 'haiku) + ;; TODO: Support the Haiku APM battery driver. + (file-directory-p "/dev/power/acpi_battery")) + #'battery-haiku-acpi-battery) ((fboundp 'w32-battery-status) #'w32-battery-status)) "Function for getting battery status information. @@ -226,6 +232,40 @@ The text being displayed in the echo area is controlled by the variables (funcall battery-status-function)) "Battery status not available"))) +(defcustom battery-update-functions nil + "Functions run by `display-battery-mode' after updating the status. +These functions will be called with one parameter, an alist that +contains data about the current battery status. The keys in the +alist are single characters and the values are strings. +Different battery backends deliver different information, so some +of the following information may or may not be available: + + v: driver-version + V: bios-version + I: bios-interface + L: line-status + B: battery-status + b: battery-status-symbol + p: load-percentage + s: seconds + m: minutes + h: hours + t: remaining-time + +For instance, to play an alarm when the battery power dips below +10%, you could use a function like the following: + +(defvar my-prev-battery nil) +(defun my-battery-alarm (data) + (when (and my-prev-battery + (equal (alist-get ?L data) \"off-line\") + (< (string-to-number (alist-get ?p data)) 10) + (>= (string-to-number (alist-get ?p my-prev-battery)) 10)) + (play-sound-file \"~/alarm.wav\" 5)) + (setq my-prev-battery data))" + :version "29.1" + :type '(repeat function)) + ;;;###autoload (define-minor-mode display-battery-mode "Toggle battery status display in mode line (Display Battery mode). @@ -233,7 +273,11 @@ The text being displayed in the echo area is controlled by the variables The text displayed in the mode line is controlled by `battery-mode-line-format' and `battery-status-function'. The mode line is be updated every `battery-update-interval' -seconds." +seconds. + +The function which updates the mode-line display will call the +functions in `battery-update-functions', which can be used to +trigger actions based on battery-related events." :global t (setq battery-mode-line-string "") (or global-mode-string (setq global-mode-string '(""))) @@ -273,7 +317,8 @@ seconds." ((< percentage battery-load-low) (add-face-text-property 0 len 'battery-load-low t res))) (put-text-property 0 len 'help-echo "Battery status information" res)) - (setq battery-mode-line-string (or res ""))) + (setq battery-mode-line-string (or res "")) + (run-hook-with-args 'battery-update-functions data)) (force-mode-line-update t)) @@ -600,6 +645,103 @@ The following %-sequences are provided: (_ "N/A")))))) +;;; `/dev/power/acpi_battery' interface for Haiku. + +(defun battery--search-haiku-acpi-status () + "Search forward for battery status in the current buffer. +Return a property list once all relevant properties are found. +The following properties may be inside the list: + + - `:capacity' (the current capacity of the battery.) + - `:voltage' (the current voltage of the battery.) + - `:rate', (the current rate of charge or discharge.) + - `:state' (the current state of the battery.) + - `:design-capacity' (the design capacity of the battery.) + - `:design-voltage' (the design voltage of the battery.) + - `:last-full-charge' (the capacity at the last full charge of + the battery.) + +`:capacity' and `:design-capacity' are both represented in +terms of milliamp-hours." + (let ((state-regexp "State \\([[:digit:]]+\\), Current Rate \\([[:digit:]]+\\), \ +Capacity \\([[:digit:]]+\\), Voltage \\([[:digit:]]+\\)") + (pu-regexp "Power Unit \\([[:digit:]]\\)+, Design Capacity \\([[:digit:]]+\\), \ +Last Full Charge \\([[:digit:]]+\\)") + (design-regexp "Design Voltage \\([[:digit:]]+\\)") + power-unit last-full-charge state rate capacity + voltage design-capacity design-voltage) + (when (re-search-forward state-regexp) + (setq state (string-to-number (match-string 1))) + (setq rate (string-to-number (match-string 2))) + (setq capacity (string-to-number (match-string 3))) + (setq voltage (/ (string-to-number (match-string 4)) 1000.0))) + (when (re-search-forward pu-regexp) + (setq power-unit (string-to-number (match-string 1))) + (setq design-capacity (string-to-number (match-string 2))) + (setq last-full-charge (string-to-number (match-string 3)))) + (when (re-search-forward design-regexp) + (setq design-voltage (/ (string-to-number (match-string 1)) 1000.0))) + ;; Convert capacity fields to milliamp-hours if they're + ;; specified as miliwatt-hours. + (when (eq power-unit 0) + (setq capacity (/ capacity voltage)) + (setq design-capacity (/ design-capacity design-voltage)) + (setq last-full-charge (/ last-full-charge voltage))) + (list :capacity capacity :voltage voltage + :rate rate :state (cond + ((not (zerop (logand state 2))) 'charging) + ((not (zerop (logand state 1))) 'discharging) + ((not (zerop (logand state 4))) 'critical) + (t 'fully-charged)) + :design-capacity design-capacity + :design-voltage design-voltage + :last-full-charge last-full-charge))) + +(defun battery-haiku-acpi-battery () + "Get battery status from `/dev/power/acpi_battery'. +This function only works on Haiku systems with an ACPI battery. + +The following %-sequences are provided: +%c Current capacity (mAh) +%r Current rate of charge or discharge +%L AC line status (verbose) +%B Battery status (verbose) +%b Battery status: empty means high, `-' means low, + `!' means critical, and `+' means charging +%p Battery load percentage" + (with-temp-buffer + (dolist (file (battery--files "/dev/power/acpi_battery")) + (insert-file-contents (expand-file-name file "/dev/power/acpi_battery"))) + ;; I don't think Haiku actually supports multiple batteries yet, + ;; since the code in PowerStatus doesn't take care of that + ;; situation. + (let ((list (ignore-errors (battery--search-haiku-acpi-status)))) + (if list + (list (cons ?c (format "%.0f" (plist-get list :capacity))) + (cons ?r (format "%.0f" (plist-get list :rate))) + (cons ?B (symbol-name (plist-get list :state))) + (cons ?b (let ((state (plist-get list :state))) + (cond + ((eq state 'charging) "+") + ((and (eq state 'discharging) + (< (/ (plist-get list :capacity) + (plist-get list :last-full-charge)) + 0.15)) + "-") + ((eq state 'critical) "!") + (t "")))) + (cons ?L (if (not (eq (plist-get list :state) 'discharging)) + "on-line" "off-line")) + (cons ?p (format "%.0f" + (* 100 (/ (plist-get list :capacity) + (plist-get list :last-full-charge)))))) + '((?c . "N/A") + (?r . "N/A") + (?B . "N/A") + (?b . "N/A") + (?p . "N/A")))))) + + ;;; UPower interface. (defconst battery-upower-interface "org.freedesktop.UPower" diff --git a/lisp/bindings.el b/lisp/bindings.el index 56f742a2704..ed1325e326c 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 " " @@ -644,6 +654,18 @@ By default, this shows the information specified by `global-mode-string'.") (with-selected-window (posn-window (event-start event)) (previous-buffer))) +(defun mode-line-window-selected-p () + "Return non-nil if we're updating the mode line for the selected window. +This function is meant to be called in `:eval' mode line +constructs to allow altering the look of the mode line depending +on whether the mode line belongs to the currently selected window +or not." + (let ((window (selected-window))) + (or (eq window (old-selected-window)) + (and (minibuffer-window-active-p (minibuffer-window)) + (with-selected-window (minibuffer-window) + (eq window (minibuffer-selected-window))))))) + (defmacro bound-and-true-p (var) "Return the value of symbol VAR if it is bound, else nil. Note that if `lexical-binding' is in effect, this function isn't @@ -968,7 +990,7 @@ if `inhibit-field-text-motion' is non-nil." (define-key esc-map "\\" 'delete-horizontal-space) (define-key esc-map "m" 'back-to-indentation) (define-key ctl-x-map "\C-o" 'delete-blank-lines) -(define-key esc-map " " 'just-one-space) +(define-key esc-map " " 'cycle-spacing) (define-key esc-map "z" 'zap-to-char) (define-key esc-map "=" 'count-words-region) (define-key ctl-x-map "=" 'what-cursor-position) @@ -1105,6 +1127,7 @@ if `inhibit-field-text-motion' is non-nil." (define-key goto-map "p" 'previous-error) (define-key goto-map "\M-p" 'previous-error) (define-key goto-map "\t" 'move-to-column) +(define-key goto-map "i" 'imenu) (defvar search-map (make-sparse-keymap) "Keymap for search related commands.") @@ -1138,7 +1161,9 @@ if `inhibit-field-text-motion' is non-nil." ;(define-key global-map [delete] 'backward-delete-char) ;; natural bindings for terminal keycaps --- defined in X keysym order -(define-key global-map [Scroll_Lock] 'scroll-lock-mode) +(define-key global-map + (if (eq system-type 'windows-nt) [scroll] [Scroll_Lock]) + #'scroll-lock-mode) (define-key global-map [C-S-backspace] 'kill-whole-line) (define-key global-map [home] 'move-beginning-of-line) (define-key global-map [C-home] 'beginning-of-buffer) @@ -1251,6 +1276,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, @@ -1376,10 +1403,8 @@ if `inhibit-field-text-motion' is non-nil." (define-key esc-map [?\C-\ ] 'mark-sexp) (define-key esc-map "\C-d" 'down-list) (define-key esc-map "\C-k" 'kill-sexp) -;;; These are dangerous in various situations, -;;; so let's not encourage anyone to use them. -;;;(define-key global-map [C-M-delete] 'backward-kill-sexp) -;;;(define-key global-map [C-M-backspace] 'backward-kill-sexp) +(define-key global-map [C-M-delete] 'backward-kill-sexp) +(define-key global-map [C-M-backspace] 'backward-kill-sexp) (define-key esc-map [C-delete] 'backward-kill-sexp) (define-key esc-map [C-backspace] 'backward-kill-sexp) (define-key esc-map "\C-n" 'forward-list) diff --git a/lisp/bookmark.el b/lisp/bookmark.el index cc9956c80a9..849303fac7e 100644 --- a/lisp/bookmark.el +++ b/lisp/bookmark.el @@ -115,10 +115,18 @@ just use the value of `version-control'." (defcustom bookmark-sort-flag t - "Non-nil means that bookmarks will be displayed sorted by bookmark name. -Otherwise they will be displayed in LIFO order (that is, most -recently set ones come first, oldest ones come last)." - :type 'boolean) + "This controls the bookmark display sorting. +nil means they will be displayed in LIFO order (that is, most +recently created ones come first, oldest ones come last). + +`last-modified' means that bookmarks will be displayed sorted +from most recently set to least recently set. + +Other values means that bookmarks will be displayed sorted by +bookmark name." + :type '(choice (const :tag "By name" t) + (const :tag "By modified time" last-modified) + (const :tag "By creation time" nil))) (defcustom bookmark-menu-confirm-deletion nil @@ -214,31 +222,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) @@ -349,6 +354,17 @@ This point is in `bookmark-current-buffer'.") BOOKMARK-RECORD is, e.g., one element from `bookmark-alist'." (car bookmark-record)) +(defun bookmark-type-from-full-record (bookmark-record) + "Return then type of BOOKMARK-RECORD. +BOOKMARK-RECORD is, e.g., one element from `bookmark-alist'. It's +type is read from the symbol property named +`bookmark-handler-type' read on the record handler function." + (let ((handler (bookmark-get-handler bookmark-record))) + (when (autoloadp (symbol-function handler)) + (autoload-do-load (symbol-function handler))) + (if (symbolp handler) + (get handler 'bookmark-handler-type) + ""))) (defun bookmark-all-names () "Return a list of all current bookmark names." @@ -452,6 +468,10 @@ In other words, return all information but the name." "Return the handler function for BOOKMARK-NAME-OR-RECORD, or nil if none." (bookmark-prop-get bookmark-name-or-record 'handler)) +(defun bookmark-get-last-modified (bookmark-name-or-record) + "Return the last-modified for BOOKMARK-NAME-OR-RECORD, or nil if none." + (bookmark-prop-get bookmark-name-or-record 'last-modified)) + (defvar bookmark-history nil "The history list for bookmark functions.") @@ -489,6 +509,24 @@ See user option `bookmark-set-fringe'." (when (eq 'bookmark (overlay-get temp 'category)) (delete-overlay (setq found temp)))))))))) +(defun bookmark-maybe-sort-alist () + "Return `bookmark-alist' for display. +If `bookmark-sort-flag' is T, then return a sorted by name copy of the alist. +If `bookmark-sort-flag' is LAST-MODIFIED, then return a sorted by last modified +copy of the alist. Otherwise, just return `bookmark-alist', which by default +is ordered from most recently created to least recently created bookmark." + (let ((copy (copy-alist bookmark-alist))) + (cond ((eq bookmark-sort-flag t) + (sort copy (lambda (x y) (string-lessp (car x) (car y))))) + ((eq bookmark-sort-flag 'last-modified) + (sort copy (lambda (x y) + (let ((tx (bookmark-get-last-modified x)) + (ty (bookmark-get-last-modified y))) + (cond ((null tx) nil) + ((null ty) t) + (t (time-less-p ty tx))))))) + (t copy)))) + (defun bookmark-completing-read (prompt &optional default) "Prompting with PROMPT, read a bookmark name in completion. PROMPT will get a \": \" stuck on the end no matter what, so you @@ -498,16 +536,11 @@ If DEFAULT is nil then return empty string for empty input." (bookmark-maybe-load-default-file) ; paranoia (if (listp last-nonmenu-event) (bookmark-menu-popup-paned-menu t prompt - (if bookmark-sort-flag - (sort (bookmark-all-names) - 'string-lessp) - (bookmark-all-names))) + (mapcar 'bookmark-name-from-full-record + (bookmark-maybe-sort-alist))) (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)) @@ -518,8 +551,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)))) @@ -624,7 +658,8 @@ If POSN is non-nil, record POSN as the point instead of `(point)'." (point) (- (point) bookmark-search-size)) nil)))) - (position . ,(or posn (point))))) + (position . ,(or posn (point))) + (last-modified . ,(current-time)))) ;;; File format stuff @@ -818,11 +853,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. @@ -926,7 +959,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 @@ -997,12 +1030,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." @@ -1138,15 +1169,6 @@ it to the name of the bookmark currently being set, advancing (car bookmark-bookmarks-timestamp))))))) (bookmark-load (car bookmark-bookmarks-timestamp) t t)))) -(defun bookmark-maybe-sort-alist () - "Return `bookmark-alist' for display. -If `bookmark-sort-flag' is non-nil, then return a sorted copy of the alist. -Otherwise, just return `bookmark-alist', which by default is ordered -from most recently created to least recently created bookmark." - (if bookmark-sort-flag - (sort (copy-alist bookmark-alist) - (lambda (x y) (string-lessp (car x) (car y)))) - bookmark-alist)) (defvar bookmark-after-jump-hook nil @@ -1287,7 +1309,10 @@ then offer interactively to relocate BOOKMARK-NAME-OR-RECORD." (defun bookmark-default-handler (bmk-record) "Default handler to jump to a particular bookmark location. BMK-RECORD is a bookmark record, not a bookmark name (i.e., not a string). -Changes current buffer and point and returns nil, or signals a `file-error'." +Changes current buffer and point and returns nil, or signals a `file-error'. + +If BMK-RECORD has a property called `buffer', it should be a live +buffer object, and this buffer will be selected." (let ((file (bookmark-get-filename bmk-record)) (buf (bookmark-prop-get bmk-record 'buffer)) (forward-str (bookmark-get-front-context-string bmk-record)) @@ -1361,7 +1386,6 @@ minibuffer history list `bookmark-history'." (bookmark-get-filename bookmark-name-or-record) "-- Unknown location --")) - ;;;###autoload (defun bookmark-rename (old-name &optional new-name) "Change the name of OLD-NAME bookmark to NEW-NAME name. @@ -1707,44 +1731,43 @@ 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 + "S-SPC" #'previous-line + "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'." @@ -1802,6 +1825,7 @@ Don't affect the buffer ring order." (let (entries) (dolist (full-record (bookmark-maybe-sort-alist)) (let* ((name (bookmark-name-from-full-record full-record)) + (type (bookmark-type-from-full-record full-record)) (annotation (bookmark-get-annotation full-record)) (location (bookmark-location full-record))) (push (list @@ -1815,11 +1839,39 @@ Don't affect the buffer ring order." 'follow-link t 'help-echo "mouse-2: go to this bookmark in other window") name) + ,(or type "") ,@(if bookmark-bmenu-toggle-filenames (list location))]) entries))) - (tabulated-list-init-header) - (setq tabulated-list-entries entries)) + ;; The value of `bookmark-sort-flag' might have changed since the + ;; last time the buffer contents were generated, so re-check it. + (cond ((eq bookmark-sort-flag t) + (setq tabulated-list-sort-key '("Bookmark Name" . nil) + tabulated-list-entries entries)) + ((or (null bookmark-sort-flag) + (eq bookmark-sort-flag 'last-modified)) + (setq tabulated-list-sort-key nil) + ;; And since we're not sorting by bookmark name, show bookmarks + ;; according to order of creation, with the most recently + ;; created bookmarks at the top and the least recently created + ;; at the bottom. + ;; + ;; Note that clicking the column sort toggle for the bookmark + ;; name column will invoke the `tabulated-list-mode' sort, which + ;; uses `bookmark-bmenu--name-predicate' to sort lexically by + ;; bookmark name instead of by (reverse) creation order. + ;; Clicking the toggle again will reverse the lexical sort, but + ;; the sort will still be lexical not creation-order. However, + ;; if the user reverts the buffer, then the above check of + ;; `bookmark-sort-flag' will happen again and the buffer will + ;; go back to a creation-order sort. This is all expected + ;; behavior, as documented in `bookmark-bmenu-mode'. + (setq tabulated-list-entries (reverse entries)))) + ;; Generate the header only after `tabulated-list-sort-key' is + ;; settled, because if that's non-nil then the sort-direction + ;; indicator will be shown in the named column, but if it's + ;; nil then the indicator will not be shown. + (tabulated-list-init-header)) (tabulated-list-print t)) ;;;###autoload @@ -1863,6 +1915,18 @@ deletion, or > if it is flagged for displaying." Each line describes one of the bookmarks in Emacs. Letters do not insert themselves; instead, they are commands. Bookmark names preceded by a \"*\" have annotations. + +If `bookmark-sort-flag' is non-nil, then sort the list by +bookmark name (case-insensitively, in collation order); the +direction of that sort can be reversed by using the column sort +toggle for the bookmark name column. + +If `bookmark-sort-flag' is nil, then sort the list by bookmark +creation order, with most recently created bookmarks on top. +However, the column sort toggle will still activate (and +thereafter toggle the direction of) lexical sorting by bookmark name. +At any time you may use \\[revert-buffer] to go back to sorting by creation order. + \\<bookmark-bmenu-mode-map> \\[bookmark-bmenu-mark] -- mark bookmark to be displayed. \\[bookmark-bmenu-mark-all] -- mark all listed bookmarks to be displayed. @@ -1895,18 +1959,24 @@ Bookmark names preceded by a \"*\" have annotations. in another buffer. \\[bookmark-bmenu-show-all-annotations] -- show the annotations of all bookmarks in another buffer. \\[bookmark-bmenu-edit-annotation] -- edit the annotation for the current bookmark. -\\[bookmark-bmenu-search] -- incrementally search for bookmarks." +\\[bookmark-bmenu-search] -- incrementally search for bookmarks. +\\[revert-buffer] -- refresh the buffer, and thus refresh the sort order (useful + if `bookmark-sort-flag' is nil)." (setq truncate-lines t) (setq buffer-read-only t) ;; FIXME: The header could also display the current default bookmark file ;; according to `bookmark-bookmarks-timestamp'. (setq tabulated-list-format `[("" 1) ;; Space to add "*" for bookmark with annotation - ("Bookmark" ,bookmark-bmenu-file-column bookmark-bmenu--name-predicate) + ("Bookmark Name" + ,bookmark-bmenu-file-column bookmark-bmenu--name-predicate) + ("Type" 8 bookmark-bmenu--type-predicate) ,@(if bookmark-bmenu-toggle-filenames '(("File" 0 bookmark-bmenu--file-predicate)))]) (setq tabulated-list-padding bookmark-bmenu-marks-width) - (setq tabulated-list-sort-key '("Bookmark" . nil)) + (when (and bookmark-sort-flag + (not (eq bookmark-sort-flag 'last-modified))) + (setq tabulated-list-sort-key '("Bookmark Name" . nil))) (add-hook 'tabulated-list-revert-hook #'bookmark-bmenu--revert nil t)' (setq revert-buffer-function 'bookmark-bmenu--revert) (tabulated-list-init-header)) @@ -1915,13 +1985,19 @@ Bookmark names preceded by a \"*\" have annotations. (defun bookmark-bmenu--name-predicate (a b) "Predicate to sort \"*Bookmark List*\" buffer by the name column. This is used for `tabulated-list-format' in `bookmark-bmenu-mode'." - (string< (caar a) (caar b))) + (string-collate-lessp (caar a) (caar b) nil t)) +(defun bookmark-bmenu--type-predicate (a b) + "Predicate to sort \"*Bookmark List*\" buffer by the type column. +This is used for `tabulated-list-format' in `bookmark-bmenu-mode'." + (string-collate-lessp (elt (cadr a) 2) (elt (cadr b) 2) nil t)) (defun bookmark-bmenu--file-predicate (a b) "Predicate to sort \"*Bookmark List*\" buffer by the file column. This is used for `tabulated-list-format' in `bookmark-bmenu-mode'." - (string< (bookmark-location (car a)) (bookmark-location (car b)))) + (string-collate-lessp (bookmark-location (car a)) + (bookmark-location (car b)) + nil t)) (defun bookmark-bmenu-toggle-filenames (&optional show) @@ -2324,10 +2400,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/buff-menu.el b/lisp/buff-menu.el index 59040371c9f..179cc5484cd 100644 --- a/lisp/buff-menu.el +++ b/lisp/buff-menu.el @@ -116,43 +116,41 @@ as it is by default." This is set by the prefix argument to `buffer-menu' and related commands.") -(defvar Buffer-menu-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map tabulated-list-mode-map) - (define-key map "v" 'Buffer-menu-select) - (define-key map "2" 'Buffer-menu-2-window) - (define-key map "1" 'Buffer-menu-1-window) - (define-key map "f" 'Buffer-menu-this-window) - (define-key map "e" 'Buffer-menu-this-window) - (define-key map "\C-m" 'Buffer-menu-this-window) - (define-key map "o" 'Buffer-menu-other-window) - (define-key map "\C-o" 'Buffer-menu-switch-other-window) - (define-key map "s" 'Buffer-menu-save) - (define-key map "d" 'Buffer-menu-delete) - (define-key map "k" 'Buffer-menu-delete) - (define-key map "\C-k" 'Buffer-menu-delete) - (define-key map "\C-d" 'Buffer-menu-delete-backwards) - (define-key map "x" 'Buffer-menu-execute) - (define-key map " " 'next-line) - (define-key map "\177" 'Buffer-menu-backup-unmark) - (define-key map "~" 'Buffer-menu-not-modified) - (define-key map "u" 'Buffer-menu-unmark) - (define-key map "\M-\177" 'Buffer-menu-unmark-all-buffers) - (define-key map "U" 'Buffer-menu-unmark-all) - (define-key map "m" 'Buffer-menu-mark) - (define-key map "t" 'Buffer-menu-visit-tags-table) - (define-key map "%" 'Buffer-menu-toggle-read-only) - (define-key map "b" 'Buffer-menu-bury) - (define-key map "V" 'Buffer-menu-view) - (define-key map "T" 'Buffer-menu-toggle-files-only) - (define-key map (kbd "M-s a C-s") 'Buffer-menu-isearch-buffers) - (define-key map (kbd "M-s a M-C-s") 'Buffer-menu-isearch-buffers-regexp) - (define-key map (kbd "M-s a C-o") 'Buffer-menu-multi-occur) - - (define-key map [mouse-2] 'Buffer-menu-mouse-select) - (define-key map [follow-link] 'mouse-face) - map) - "Local keymap for `Buffer-menu-mode' buffers.") +(defvar-keymap Buffer-menu-mode-map + :doc "Local keymap for `Buffer-menu-mode' buffers." + :parent tabulated-list-mode-map + "v" #'Buffer-menu-select + "2" #'Buffer-menu-2-window + "1" #'Buffer-menu-1-window + "f" #'Buffer-menu-this-window + "e" #'Buffer-menu-this-window + "C-m" #'Buffer-menu-this-window + "o" #'Buffer-menu-other-window + "C-o" #'Buffer-menu-switch-other-window + "s" #'Buffer-menu-save + "d" #'Buffer-menu-delete + "k" #'Buffer-menu-delete + "C-k" #'Buffer-menu-delete + "C-d" #'Buffer-menu-delete-backwards + "x" #'Buffer-menu-execute + "SPC" #'next-line + "DEL" #'Buffer-menu-backup-unmark + "~" #'Buffer-menu-not-modified + "u" #'Buffer-menu-unmark + "M-DEL" #'Buffer-menu-unmark-all-buffers + "U" #'Buffer-menu-unmark-all + "m" #'Buffer-menu-mark + "t" #'Buffer-menu-visit-tags-table + "%" #'Buffer-menu-toggle-read-only + "b" #'Buffer-menu-bury + "V" #'Buffer-menu-view + "T" #'Buffer-menu-toggle-files-only + "M-s a C-s" #'Buffer-menu-isearch-buffers + "M-s a C-M-s" #'Buffer-menu-isearch-buffers-regexp + "M-s a C-o" #'Buffer-menu-multi-occur + + "<mouse-2>" #'Buffer-menu-mouse-select + "<follow-link>" 'mouse-face) (easy-menu-define Buffer-menu-mode-menu Buffer-menu-mode-map "Menu for `Buffer-menu-mode' buffers." @@ -529,13 +527,18 @@ If UNMARK is non-nil, unmark them." (multi-occur (Buffer-menu-marked-buffers) regexp nlines)) +(autoload 'etags-verify-tags-table "etags") (defun Buffer-menu-visit-tags-table () "Visit the tags table in the buffer on this line. See `visit-tags-table'." (interactive nil Buffer-menu-mode) - (let ((file (buffer-file-name (Buffer-menu-buffer t)))) - (if file - (visit-tags-table file) - (error "Specified buffer has no file")))) + (let* ((buf (Buffer-menu-buffer t)) + (file (buffer-file-name buf))) + (cond + ((not file) (error "Specified buffer has no file")) + ((and buf (with-current-buffer buf + (etags-verify-tags-table))) + (visit-tags-table file)) + (t (error "Specified buffer is not a tags-table"))))) (defun Buffer-menu-1-window () "Select this line's buffer, alone, in full frame." diff --git a/lisp/button.el b/lisp/button.el index 4e9448844cc..80b73033d68 100644 --- a/lisp/button.el +++ b/lisp/button.el @@ -55,29 +55,24 @@ "Default face used for buttons." :group 'basic-faces) -(defvar button-map - (let ((map (make-sparse-keymap))) - ;; The following definition needs to avoid using escape sequences that - ;; might get converted to ^M when building loaddefs.el - (define-key map [(control ?m)] 'push-button) - (define-key map [mouse-2] 'push-button) - (define-key map [follow-link] 'mouse-face) - ;; FIXME: You'd think that for keymaps coming from text-properties on the - ;; mode-line or header-line, the `mode-line' or `header-line' prefix - ;; shouldn't be necessary! - (define-key map [mode-line mouse-2] 'push-button) - (define-key map [header-line mouse-2] 'push-button) - map) - "Keymap used by buttons.") - -(defvar button-buffer-map - (let ((map (make-sparse-keymap))) - (define-key map [?\t] 'forward-button) - (define-key map "\e\t" 'backward-button) - (define-key map [backtab] 'backward-button) - map) - "Keymap useful for buffers containing buttons. -Mode-specific keymaps may want to use this as their parent keymap.") +(defvar-keymap button-buffer-map + :doc "Keymap useful for buffers containing buttons. +Mode-specific keymaps may want to use this as their parent keymap." + "TAB" #'forward-button + "ESC TAB" #'backward-button + "<backtab>" #'backward-button) + +(defvar-keymap button-map + :doc "Keymap used by buttons." + :parent button-buffer-map + "RET" #'push-button + "<mouse-2>" #'push-button + "<follow-link>" 'mouse-face + ;; FIXME: You'd think that for keymaps coming from text-properties on the + ;; mode-line or header-line, the `mode-line' or `header-line' prefix + ;; shouldn't be necessary! + "<mode-line> <mouse-2>" #'push-button + "<header-line> <mouse-2>" #'push-button) (define-minor-mode button-mode "A minor mode for navigating to buttons with the TAB key." @@ -130,6 +125,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 +599,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,19 +612,42 @@ 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." - (propertize string - 'face 'button - 'button t - 'follow-link t - 'category t - 'button-data data - 'keymap button-map - 'action callback)) +itself will be used instead as the function argument. + +If HELP-ECHO, use that as the `help-echo' property. + +Also see `buttonize-region'." + (apply #'propertize string + (button--properties callback data help-echo))) + +(defun button--properties (callback data help-echo) + (list 'face 'button + 'font-lock-face 'button + 'mouse-face 'highlight + 'help-echo help-echo + 'button t + 'follow-link t + 'category t + 'button-data data + 'keymap button-map + 'action callback)) + +(defun buttonize-region (start end callback &optional data help-echo) + "Make the region between START and END into a button. +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. + +If HELP-ECHO, use that as the `help-echo' property. + +Also see `buttonize'." + (add-text-properties start end (button--properties callback data help-echo))) (provide 'button) diff --git a/lisp/calc/calc-ext.el b/lisp/calc/calc-ext.el index 058d78e8476..7ee73d100a0 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 14890e14030..a95967bef4e 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 3355b63b6e1..a513a7de0c5 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 5fd07d57d81..40236e452cc 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 e944f812525..bd1635f2bf4 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 ff00a4a2a68..5690f101182 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 44b967c3859..dc2a086bbd7 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 c0dd77d9b2a..023dd40c155 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 d1565e74a04..c8405c7d1a0 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-yank.el b/lisp/calc/calc-yank.el index 8c6d3f51e5d..172ccf1adcd 100644 --- a/lisp/calc/calc-yank.el +++ b/lisp/calc/calc-yank.el @@ -47,6 +47,8 @@ (calc-check-stack num) (let ((stuff (calc-top-list n (- num n -1)))) (calc-cursor-stack-index num) + (unless calc-kill-line-numbering + (re-search-forward "\\=[0-9]+:\\s-+" (point-at-eol) t)) (let ((first (point))) (calc-cursor-stack-index (- num n)) (if (null nn) diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el index 171f7711324..b03dcfeb5b7 100644 --- a/lisp/calc/calc.el +++ b/lisp/calc/calc.el @@ -439,6 +439,14 @@ to be identified as that note." :version "24.1" :type 'string) +(defcustom calc-kill-line-numbering t + "If non-nil, calculator kills include any line numbering. + +This option does not affect calc kill and copy commands which +operate on the region, such as `calc-copy-region-as-kill'." + :version "29.1" + :type 'boolean) + (defvar math-format-date-cache) ; calc-forms.el (defface calc-nonselected-face @@ -494,7 +502,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)))) @@ -1375,7 +1383,7 @@ Notations: 3.14e6 3.14 * 10^6 LONG is a desired text for a wide window, SHORT is a desired abbreviated text, and width is the buffer width, which will be -some fraction of the 'parent' window width (At the time of +some fraction of the \"parent\" window width (At the time of writing, 2/3 for calc, 1/3 for trail). The optional FUDGE is a trial-and-error adjustment number for the edge-cases at the border of the two cases." @@ -1621,7 +1629,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 +3448,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 44c7fcecc8e..a80437d6ecf 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/appt.el b/lisp/calendar/appt.el index ebdafb438e3..a7d13cff9a1 100644 --- a/lisp/calendar/appt.el +++ b/lisp/calendar/appt.el @@ -510,9 +510,13 @@ The time should be in either 24 hour format or am/pm format. Optional argument WARNTIME is an integer (or string) giving the number of minutes before the appointment at which to start warning. The default is `appt-message-warning-time'." - (interactive "sTime (hh:mm[am/pm]): \nsMessage: \n\ -sMinutes before the appointment to start warning: ") - (unless (string-match appt-time-regexp time) + (interactive (list (let ((time (read-string "Time (hh:mm[am/pm]): "))) + (unless (string-match-p appt-time-regexp time) + (user-error "Unacceptable time-string")) + time) + (read-string "Message: ") + (read-string "Minutes before the appointment to start warning: "))) + (unless (string-match-p appt-time-regexp time) (user-error "Unacceptable time-string")) (and (stringp warntime) (setq warntime (unless (string-equal warntime "") diff --git a/lisp/calendar/cal-hebrew.el b/lisp/calendar/cal-hebrew.el index 61ce029e077..1c08de53fbd 100644 --- a/lisp/calendar/cal-hebrew.el +++ b/lisp/calendar/cal-hebrew.el @@ -798,6 +798,10 @@ In this case, the following civil date corresponds to the Hebrew birthday." (diary-ordinal-suffix age) (if (= b-date d) "" " (evening)"))))) +(defvar diary-hebrew-omer-sefirot + ["Hesed" "Gevurah" "Tiferet" "Netzach" "Hod" "Yesod" "Malchut"] + "The order of Sefirot for counting the Omer. +See https://opensiddur.org/prayers/solilunar/solar-cycles/sefirat-haomer/the-order-of-counting-the-omer-in-the-spring/") ;;;###diary-autoload (defun diary-hebrew-omer (&optional mark) "Omer count diary entry. @@ -813,7 +817,7 @@ use when highlighting the day in the calendar." (day (% omer 7))) (if (and (> omer 0) (< omer 50)) (cons mark - (format "Day %d%s of the omer (until sunset)" + (format "Day %d%s of the omer (until sunset) %s she'be'%s" omer (if (zerop week) "" @@ -823,7 +827,10 @@ use when highlighting the day in the calendar." (if (zerop day) "" (format " and %d day%s" - day (if (= day 1) "" "s")))))))))) + day (if (= day 1) "" "s"))))) + (aref diary-hebrew-omer-sefirot (% (+ 6 day) 7)) + (aref diary-hebrew-omer-sefirot + (+ (if (zerop day) -1 0) week))))))) (autoload 'diary-make-date "diary-lib") diff --git a/lisp/calendar/calendar.el b/lisp/calendar/calendar.el index 48d308afade..9a77ae72d02 100644 --- a/lisp/calendar/calendar.el +++ b/lisp/calendar/calendar.el @@ -1066,7 +1066,7 @@ calendar." ;; fixme should have a :set that changes calendar-standard-time-zone-name etc. (defcustom calendar-time-zone-style 'symbolic "Your preferred style for time zones. -If 'numeric, use numeric time zones like \"+0100\". +If `numeric', use numeric time zones like \"+0100\". Otherwise, use symbolic time zones like \"CET\"." :type '(choice (const numeric) (other symbolic)) :version "28.1" @@ -1861,7 +1861,9 @@ concatenated and the result truncated." buffs)) (defun calendar-exit (&optional kill) - "Get out of the calendar window and hide it and related buffers." + "Get out of the calendar window and hide it and related buffers. +If KILL (interactively, the prefix), kill the buffers instead of +hiding them." (interactive "P") (let ((diary-buffer (get-file-buffer diary-file)) (calendar-buffers (calendar-buffer-list))) @@ -1880,7 +1882,12 @@ concatenated and the result truncated." (iconify-frame (window-frame w))) (quit-window kill w)))) (dolist (b calendar-buffers) - (quit-windows-on b kill)))))) + (quit-windows-on b kill))) + ;; Finally, kill non-displayed buffers (if requested). + (when kill + (dolist (b calendar-buffers) + (when (buffer-live-p b) + (kill-buffer b))))))) (defun calendar-current-date (&optional offset) "Return the current date in a list (month day year). diff --git a/lisp/calendar/diary-lib.el b/lisp/calendar/diary-lib.el index 45df0c6259c..48dbf33adff 100644 --- a/lisp/calendar/diary-lib.el +++ b/lisp/calendar/diary-lib.el @@ -1,7 +1,6 @@ ;;; diary-lib.el --- diary functions -*- lexical-binding:t -*- -;; Copyright (C) 1989-1990, 1992-1995, 2001-2022 Free Software -;; Foundation, Inc. +;; Copyright (C) 1989-2022 Free Software Foundation, Inc. ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> ;; Maintainer: emacs-devel@gnu.org @@ -2246,12 +2245,10 @@ Prefix argument ARG makes the entry nonmarking." ;; Return value suitable for `write-contents-functions'. nil) -(defvar diary-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\C-c\C-s" 'diary-show-all-entries) - (define-key map "\C-c\C-q" 'quit-window) - map) - "Keymap for `diary-mode'.") +(defvar-keymap diary-mode-map + :doc "Keymap for `diary-mode'." + "C-c C-s" #'diary-show-all-entries + "C-c C-q" #'quit-window) (defun diary-font-lock-sexps (limit) "Recognize sexp diary entry up to LIMIT for font-locking." diff --git a/lisp/calendar/holidays.el b/lisp/calendar/holidays.el index 2afa667a56c..5aa0d26d192 100644 --- a/lisp/calendar/holidays.el +++ b/lisp/calendar/holidays.el @@ -30,7 +30,7 @@ ;;; Code: (require 'calendar) -(load "hol-loaddefs" nil t) +(load "holiday-loaddefs" nil t) (defgroup holidays nil "Holidays support in calendar." @@ -400,6 +400,36 @@ This function is suitable for execution in an init file." (displayed-year (calendar-extract-year date))) (calendar-list-holidays)))) +(defun holiday-available-holiday-lists () + "Return a list of all holiday lists. +This is used by `list-holidays', and you can customize the return +value by using `add-function'." + (delq + nil + (list + (cons "All" calendar-holidays) + (cons "Equinoxes/Solstices" + (list (list 'solar-equinoxes-solstices))) + (if holiday-general-holidays + (cons "General" holiday-general-holidays)) + (if holiday-local-holidays + (cons "Local" holiday-local-holidays)) + (if holiday-other-holidays + (cons "Other" holiday-other-holidays)) + (if holiday-christian-holidays + (cons "Christian" holiday-christian-holidays)) + (if holiday-hebrew-holidays + (cons "Hebrew" holiday-hebrew-holidays)) + (if holiday-islamic-holidays + (cons "Islamic" holiday-islamic-holidays)) + (if holiday-bahai-holidays + (cons "Bahá’í" holiday-bahai-holidays)) + (if holiday-oriental-holidays + (cons "Oriental" holiday-oriental-holidays)) + (if holiday-solar-holidays + (cons "Solar" holiday-solar-holidays)) + (cons "Ask" nil)))) + ;; rms: "Emacs commands to display a list of something generally start ;; with `list-'. Please make `list-holidays' the principal name." ;;;###autoload @@ -421,7 +451,12 @@ documentation of `calendar-holidays' for a list of the variables that control the choices, as well as a description of the format of a holiday list. -The optional LABEL is used to label the buffer created." +The optional LABEL is used to label the buffer created. + +The list of holiday lists is computed by the +`holiday-available-holiday-lists' and you can alter the results +by redefining that function, or use `add-function' to add +values." (interactive (let* ((start-year (calendar-read-sexp "Starting year of holidays (>0)" @@ -433,30 +468,7 @@ The optional LABEL is used to label the buffer created." start-year start-year)) (completion-ignore-case t) - (lists - (list - (cons "All" calendar-holidays) - (cons "Equinoxes/Solstices" - (list (list 'solar-equinoxes-solstices))) - (if holiday-general-holidays - (cons "General" holiday-general-holidays)) - (if holiday-local-holidays - (cons "Local" holiday-local-holidays)) - (if holiday-other-holidays - (cons "Other" holiday-other-holidays)) - (if holiday-christian-holidays - (cons "Christian" holiday-christian-holidays)) - (if holiday-hebrew-holidays - (cons "Hebrew" holiday-hebrew-holidays)) - (if holiday-islamic-holidays - (cons "Islamic" holiday-islamic-holidays)) - (if holiday-bahai-holidays - (cons "Bahá’í" holiday-bahai-holidays)) - (if holiday-oriental-holidays - (cons "Oriental" holiday-oriental-holidays)) - (if holiday-solar-holidays - (cons "Solar" holiday-solar-holidays)) - (cons "Ask" nil))) + (lists (holiday-available-holiday-lists)) (choice (capitalize (completing-read "List (TAB for choices): " lists nil t))) (which (if (string-equal choice "Ask") diff --git a/lisp/calendar/icalendar.el b/lisp/calendar/icalendar.el index 439fb6dd29a..1a5a071e202 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) + (pcase (aref isodatetimestring 15) + (?Z + (setq source-zone t)) + ((or ?- ?+) + (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/iso8601.el b/lisp/calendar/iso8601.el index e31120f52ff..6827a957a6f 100644 --- a/lisp/calendar/iso8601.el +++ b/lisp/calendar/iso8601.el @@ -114,6 +114,11 @@ iso8601--duration-week-match iso8601--duration-combined-match))) +;; "Z" dnd "z" are standard time; nil and [-+][0-9][0-9]... are local time +;; with unknown DST. +(defun iso8601--zone-dst (zone) + (if (= (length zone) 1) nil -1)) + (defun iso8601-parse (string &optional form) "Parse an ISO 8601 date/time string and return a `decode-time' structure. @@ -140,7 +145,7 @@ See `decode-time' for the meaning of FORM." (setf (decoded-time-zone date) ;; The time zone in decoded times are in seconds. (* (iso8601-parse-zone zone-string) 60)) - (setf (decoded-time-dst date) nil)) + (setf (decoded-time-dst date) (iso8601--zone-dst zone-string))) date))) (defun iso8601-parse-date (string) @@ -256,6 +261,7 @@ See `decode-time' for the meaning of FORM." (iso8601--decoded-time :hour hour :minute (or minute 0) :second (or second 0) + :dst (iso8601--zone-dst zone) :zone (and zone (* 60 (iso8601-parse-zone zone))))))))) @@ -364,7 +370,7 @@ Return the number of minutes." (cl-defun iso8601--decoded-time (&key second minute hour day month year - dst zone) + (dst -1) zone) (list (iso8601--value second) (iso8601--value minute) (iso8601--value hour) @@ -372,7 +378,7 @@ Return the number of minutes." (iso8601--value month) (iso8601--value year) nil - (if (or dst zone) dst -1) + dst zone)) (defun iso8601--encode-time (time) diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el index 83a57751474..40374c3bb4e 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) @@ -284,17 +287,23 @@ use. \"%,1s\" means \"use one decimal\". The \"%z\" specifier does not print anything. When it is used, specifiers must be given in order of decreasing size. To the left of \"%z\", nothing -is output until the first non-zero unit is encountered." +is output until the first non-zero unit is encountered. + +The \"%x\" specifier does not print anything. When it is used, +specifiers must be given in order of decreasing size. To the +right of \"%x\", trailing zero units are not output." (let ((start 0) (units '(("y" "year" 31536000) ("d" "day" 86400) ("h" "hour" 3600) ("m" "minute" 60) ("s" "second" 1) - ("z"))) + ("z") + ("x"))) (case-fold-search t) - spec match usedunits zeroflag larger prev name unit num zeropos - fraction) + spec match usedunits zeroflag larger prev name unit num + leading-zeropos trailing-zeropos fraction + chop-leading chop-trailing) (while (string-match "%\\.?[0-9]*\\(,[0-9]\\)?\\(.\\)" string start) (setq start (match-end 0) spec (match-string 2 string)) @@ -303,15 +312,16 @@ is output until the first non-zero unit is encountered." (error "Bad format specifier: `%s'" spec)) (if (assoc (downcase spec) usedunits) (error "Multiple instances of specifier: `%s'" spec)) - (if (string-equal (car match) "z") + (if (or (string-equal (car match) "z") + (string-equal (car match) "x")) (setq zeroflag t) (unless larger (setq unit (nth 2 match) larger (and prev (> unit prev)) prev unit))) (push match usedunits))) - (and zeroflag larger - (error "Units are not in decreasing order of size")) + (when (and zeroflag larger) + (error "Units are not in decreasing order of size")) (unless (numberp seconds) (setq seconds (float-time seconds))) (setq fraction (mod seconds 1) @@ -323,18 +333,28 @@ is output until the first non-zero unit is encountered." (when (string-match (format "%%\\(\\.?[0-9]+\\)?\\(,[0-9]+\\)?\\(%s\\)" spec) string) - (if (string-equal spec "z") ; must be last in units - (setq string - (replace-regexp-in-string - "%z" "" - (substring string (min (or zeropos (match-end 0)) - (match-beginning 0))))) + (cond + ((string-equal spec "z") + (setq chop-leading (and leading-zeropos + (min leading-zeropos (match-beginning 0))))) + ((string-equal spec "x") + (setq chop-trailing t)) + (t ;; Cf article-make-date-line in gnus-art. (setq num (floor seconds unit) seconds (- seconds (* num unit))) - ;; Start position of the first non-zero unit. - (or zeropos - (setq zeropos (unless (zerop num) (match-beginning 0)))) + (let ((is-zero (zerop (if (= unit 1) + (+ num fraction) + num)))) + ;; Start position of the first non-zero unit. + (when (and (not leading-zeropos) + (not is-zero)) + (setq leading-zeropos (match-beginning 0))) + (unless is-zero + (setq trailing-zeropos nil)) + (when (and (not trailing-zeropos) + is-zero) + (setq trailing-zeropos (match-beginning 0)))) (setq string (replace-match (format (if (match-string 2 string) @@ -357,7 +377,17 @@ is output until the first non-zero unit is encountered." (format " %s%s" name (if (= num 1) "" "s")))) t t string)))))) - (string-replace "%%" "%" string)) + (let ((pre string)) + (when (and chop-trailing trailing-zeropos) + (setq string (substring string 0 trailing-zeropos))) + (when chop-leading + (setq string (substring string chop-leading))) + ;; If we ended up removing everything, return the formatted + ;; string in full. + (when (equal string "") + (setq string pre))) + (setq string (replace-regexp-in-string "%[zx]" "" string))) + (string-trim (string-replace "%%" "%" string))) (defvar seconds-to-string (list (list 1 "ms" 0.001) @@ -406,7 +436,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 @@ -518,7 +552,7 @@ changes in daylight saving time are not taken into account." (cl-defun make-decoded-time (&key second minute hour day month year - dst zone) + (dst -1) zone) "Return a `decoded-time' structure with only the keywords given filled out." (list second minute hour day month year nil dst zone)) @@ -528,6 +562,9 @@ The default value is based on January 1st, 1970 at midnight. This year is used to guarantee portability; see Info node `(elisp) Time of Day'. +Optional argument DEFAULT-ZONE specifies what time zone to +default to when TIME's time zone is nil (meaning local time). + TIME is modified and returned." (unless (decoded-time-second time) (setf (decoded-time-second time) 0)) @@ -543,13 +580,11 @@ TIME is modified and returned." (unless (decoded-time-year time) (setf (decoded-time-year time) 1970)) - ;; When we don't have a time zone, default to DEFAULT-ZONE without - ;; DST if DEFAULT-ZONE if given, and to unknown DST otherwise. (unless (decoded-time-zone time) - (if default-zone - (progn (setf (decoded-time-zone time) default-zone) - (setf (decoded-time-dst time) nil)) - (setf (decoded-time-dst time) -1))) + (setf (decoded-time-zone time) default-zone)) + + ;; Do not set decoded-time-weekday or decoded-time-dst, + ;; as encode-time can infer them well enough when unknown. time) diff --git a/lisp/cedet/ede/files.el b/lisp/cedet/ede/files.el index 3b9002a6e31..b8acb192c17 100644 --- a/lisp/cedet/ede/files.el +++ b/lisp/cedet/ede/files.el @@ -257,7 +257,7 @@ If optional EXACT is non-nil, only return exact matches for DIR." (defun ede-flush-directory-hash () "Flush the project directory hash. Do this only when developing new projects that are incorrectly putting -'nomatch tokens into the hash." +`nomatch' tokens into the hash." (interactive) (setq ede-project-directory-hash (make-hash-table :test 'equal)) ;; Also slush the current project's locator hash. diff --git a/lisp/cedet/ede/proj-elisp.el b/lisp/cedet/ede/proj-elisp.el index 0c65af15c4a..7c56ca19936 100644 --- a/lisp/cedet/ede/proj-elisp.el +++ b/lisp/cedet/ede/proj-elisp.el @@ -319,8 +319,7 @@ Lays claim to all .elc files that match .el files in this target." ("require" . "$(foreach r,$(1),(require (quote $(r))))")) :commands '("$(EMACS) $(EMACSFLAGS) $(addprefix -L ,$(LOADPATH)) \ ---eval '(setq generated-autoload-file \"$(abspath $(LOADDEFS))\")' \ --f batch-update-autoloads $(abspath $(LOADDIRS))") +-f loaddefs-generate-batch $(abspath $(LOADDEFS)) $(abspath $(LOADDIRS))") :rules (list (ede-makefile-rule :target "clean-autoloads" :phony t :rules '("rm -f $(LOADDEFS)"))) :sourcetype '(ede-source-emacs) ) diff --git a/lisp/cedet/ede/project-am.el b/lisp/cedet/ede/project-am.el index 2803e1c3071..544e39b8729 100644 --- a/lisp/cedet/ede/project-am.el +++ b/lisp/cedet/ede/project-am.el @@ -191,8 +191,9 @@ other meta-variable based on this name.") "Encode one makefile.") ;;; Code: -(cl-defmethod project-add-file ((ot project-am-target)) +(cl-defmethod project-add-file ((ot project-am-target) &optional _file) "Add the current buffer into a project. +_FILE is ignored. OT is the object target. DIR is the directory to start in." (let* ((target (if ede-object (error "Already associated w/ a target") (let ((amf (project-am-load default-directory))) diff --git a/lisp/cedet/mode-local.el b/lisp/cedet/mode-local.el index f1fdcbca1ad..ce37a28c351 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 @@ -875,10 +877,9 @@ META-NAME is a cons (OVERLOADABLE-SYMBOL . MAJOR-MODE)." "Display mode local bindings active in BUFFER-OR-MODE. Optional argument INTERACTIVE-P is non-nil if the calling command was invoked interactively." - (when (fboundp 'help-setup-xref) - (help-setup-xref - (list 'mode-local-describe-bindings-1 buffer-or-mode) - interactive-p)) + (help-setup-xref + (list 'mode-local-describe-bindings-1 buffer-or-mode) + interactive-p) (with-output-to-temp-buffer (help-buffer) ; "*Help*" (with-current-buffer standard-output (mode-local-describe-bindings-2 buffer-or-mode)))) diff --git a/lisp/cedet/semantic.el b/lisp/cedet/semantic.el index dc6751db6cf..78002dd8abc 100644 --- a/lisp/cedet/semantic.el +++ b/lisp/cedet/semantic.el @@ -497,8 +497,8 @@ is requested." (defvar semantic-working-type 'percent "The type of working message to use when parsing. -'percent means we are doing a linear parse through the buffer. -'dynamic means we are reparsing specific tags.") +`percent' means we are doing a linear parse through the buffer. +`dynamic' means we are reparsing specific tags.") (defvar semantic-minimum-working-buffer-size (* 1024 5) "The minimum size of a buffer before working messages are displayed. diff --git a/lisp/cedet/semantic/bovine/c.el b/lisp/cedet/semantic/bovine/c.el index e099ef7902e..ee1cbcad4da 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/bovine/grammar.el b/lisp/cedet/semantic/bovine/grammar.el index d478b12f645..67366ad445e 100644 --- a/lisp/cedet/semantic/bovine/grammar.el +++ b/lisp/cedet/semantic/bovine/grammar.el @@ -260,7 +260,8 @@ QUOTEMODE is the mode in which quoted symbols are slurred." (insert ")\n"))) ) -(defun bovine-grammar-parsetable-builder () +(define-mode-local-override semantic-grammar-parsetable-builder + bovine-grammar-mode () "Return the parser table expression as a string value. The format of a bovine parser table is: @@ -409,7 +410,8 @@ The source directory is relative to some root in the load path." newdir)) (error (buffer-name)))) -(defun bovine-grammar-setupcode-builder () +(define-mode-local-override semantic-grammar-setupcode-builder + bovine-grammar-mode () "Return the text of the setup code." (format "(setq semantic--parse-table %s\n\ @@ -435,10 +437,7 @@ Menu items are appended to the common grammar menu.") ;;;###autoload (define-derived-mode bovine-grammar-mode semantic-grammar-mode "BY" "Major mode for editing Bovine grammars." - (semantic-grammar-setup-menu bovine-grammar-menu) - (semantic-install-function-overrides - '((semantic-grammar-parsetable-builder . bovine-grammar-parsetable-builder) - (semantic-grammar-setupcode-builder . bovine-grammar-setupcode-builder)))) + (semantic-grammar-setup-menu bovine-grammar-menu)) (add-to-list 'auto-mode-alist '("\\.by\\'" . bovine-grammar-mode)) @@ -461,7 +460,7 @@ Menu items are appended to the common grammar menu.") (defun bovine--make-parser-1 (infile &optional outdir) (if outdir (setq outdir (file-name-directory (expand-file-name outdir)))) ;; It would be nicer to use a temp-buffer rather than find-file-noselect. - ;; The only thing stopping us is bovine-grammar-setupcode-builder's + ;; The only thing stopping us is bovine's semantic-grammar-setupcode-builder's ;; use of (buffer-name). Perhaps that could be changed to ;; (file-name-nondirectory (buffer-file-name)) ? ;; (with-temp-buffer diff --git a/lisp/cedet/semantic/complete.el b/lisp/cedet/semantic/complete.el index 5969232a054..6a09adca32d 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 ;; @@ -1762,7 +1761,8 @@ Return a cons cell (X . Y)." (defvar tooltip-frame-parameters) -(declare-function tooltip-show "tooltip" (text &optional use-echo-area)) +(declare-function tooltip-show "tooltip" (text &optional use-echo-area + text-face default-face)) (defun semantic-displayer-tooltip-show (text) "Display a tooltip with TEXT near cursor." diff --git a/lisp/cedet/semantic/db-el.el b/lisp/cedet/semantic/db-el.el index 73ef37ea2aa..02ebde40785 100644 --- a/lisp/cedet/semantic/db-el.el +++ b/lisp/cedet/semantic/db-el.el @@ -213,9 +213,7 @@ TOKTYPE is a hint to the type of tag desired." (symbol-name sym) nil ;; return type (semantic-elisp-desymbolify arglist) - :user-visible-flag (condition-case nil - (interactive-form sym) - (error nil))))) + :user-visible-flag (commandp sym)))) ((and (eq toktype 'variable) (boundp sym)) (semantic-tag-new-variable (symbol-name sym) diff --git a/lisp/cedet/semantic/db.el b/lisp/cedet/semantic/db.el index 7f25a848918..82785ec6d2e 100644 --- a/lisp/cedet/semantic/db.el +++ b/lisp/cedet/semantic/db.el @@ -729,7 +729,7 @@ Exit the save between databases if there is user input." (defvar semanticdb-project-predicate-functions nil "List of predicates to try that indicate a directory belongs to a project. This list is used when `semanticdb-persistent-path' contains the value -'project. If the predicate list is nil, then presume all paths are valid. +`project'. If the predicate list is nil, then presume all paths are valid. Project Management software (such as EDE and JDE) should add their own predicates with `add-hook' to this variable, and semanticdb will save tag diff --git a/lisp/cedet/semantic/decorate/mode.el b/lisp/cedet/semantic/decorate/mode.el index 41b50797221..ad215db0f63 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 38eb732e465..eb922a12507 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/find.el b/lisp/cedet/semantic/find.el index e894022315f..92644ce0066 100644 --- a/lisp/cedet/semantic/find.el +++ b/lisp/cedet/semantic/find.el @@ -591,7 +591,7 @@ in the new list. If optional argument SEARCH-PARTS is non-nil, all sub-parts of tags are searched. The overloadable function `semantic-tag-components' is used for the searching child lists. If SEARCH-PARTS is the symbol -'positiononly, then only children that have positional information are +`positiononly', then only children that have positional information are searched. If SEARCH-INCLUDES has not been implemented. diff --git a/lisp/cedet/semantic/fw.el b/lisp/cedet/semantic/fw.el index 2ce6976d644..113323cb339 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 @@ -193,12 +191,20 @@ will throw a warning when it encounters this symbol." (not (string-match "cedet" (macroexp-file-name))) ) (make-obsolete-overload oldfnalias newfn when) - (byte-compile-warn - "%s: `%s' obsoletes overload `%s'" - (macroexp-file-name) - newfn - (with-suppressed-warnings ((obsolete semantic-overload-symbol-from-function)) - (semantic-overload-symbol-from-function oldfnalias))))) + (if (fboundp 'byte-compile-warn-x) + (byte-compile-warn-x + newfn + "%s: `%s' obsoletes overload `%s'" + (macroexp-file-name) + newfn + (with-suppressed-warnings ((obsolete semantic-overload-symbol-from-function)) + (semantic-overload-symbol-from-function oldfnalias))) + (byte-compile-warn + "%s: `%s' obsoletes overload `%s'" + (macroexp-file-name) + newfn + (with-suppressed-warnings ((obsolete semantic-overload-symbol-from-function)) + (semantic-overload-symbol-from-function oldfnalias)))))) (defun semantic-varalias-obsolete (oldvaralias newvar when) "Make OLDVARALIAS an alias for variable NEWVAR. @@ -211,10 +217,14 @@ will throw a warning when it encounters this symbol." (error ;; Only throw this warning when byte compiling things. (when (macroexp-compiling-p) - (byte-compile-warn - "variable `%s' obsoletes, but isn't alias of `%s'" - newvar oldvaralias) - )))) + (if (fboundp 'byte-compile-warn-x) + (byte-compile-warn-x + newvar + "variable `%s' obsoletes, but isn't alias of `%s'" + newvar oldvaralias) + (byte-compile-warn + "variable `%s' obsoletes, but isn't alias of `%s'" + newvar oldvaralias)))))) ;;; Help debugging ;; @@ -277,7 +287,8 @@ later installation should be done in MODE hook." (cons (intern (format "semantic-%s" name)) (cdr e))))) overrides) (list 'constant-flag (not transient) - 'override-flag t))) + 'override-flag t) + nil)) ;;; User Interrupt handling ;; diff --git a/lisp/cedet/semantic/grm-wy-boot.el b/lisp/cedet/semantic/grm-wy-boot.el index f61bcbdef9a..376fab89c23 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/html.el b/lisp/cedet/semantic/html.el index 718ce3c4c74..00e19dbc892 100644 --- a/lisp/cedet/semantic/html.el +++ b/lisp/cedet/semantic/html.el @@ -82,6 +82,11 @@ or tag :members (mapcar #'semantic-html-expand-tag chil))) (car (semantic--tag-expand tag)))) +(define-mode-local-override semantic-tag-components html-mode (tag) + "Return components belonging to TAG." + ;; Keep this η-regexp because `semantic-html-components' is called + ;; from elsewhere. + (semantic-html-components tag)) (defun semantic-html-components (tag) "Return components belonging to TAG." (semantic-tag-get-attribute tag :members)) @@ -245,12 +250,7 @@ tag with greater section value than LEVEL is found." senator-step-at-start-end-tag-classes '(section) senator-step-at-tag-classes '(section) semantic-stickyfunc-sticky-classes '(section) - ) - (semantic-install-function-overrides - '((semantic-tag-components . semantic-html-components) - ) - t) - ) + )) ;; `html-helper-mode' hasn't been updated since 2004, so it's not very ;; relevant nowadays. diff --git a/lisp/cedet/semantic/imenu.el b/lisp/cedet/semantic/imenu.el index 235965a9955..37dc9632729 100644 --- a/lisp/cedet/semantic/imenu.el +++ b/lisp/cedet/semantic/imenu.el @@ -39,7 +39,8 @@ (require 'semantic/sort) (require 'imenu) -(declare-function pulse-momentary-highlight-one-line "pulse" (o &optional face)) +(declare-function pulse-momentary-highlight-one-line "pulse" + (&optional point face)) (declare-function semanticdb-semantic-init-hook-fcn "db-mode") ;; Because semantic imenu tags will hose the current imenu handling diff --git a/lisp/cedet/semantic/java.el b/lisp/cedet/semantic/java.el index a7c02032e22..9b70afd0a33 100644 --- a/lisp/cedet/semantic/java.el +++ b/lisp/cedet/semantic/java.el @@ -391,7 +391,7 @@ That is TAG `symbol-name' without the leading `@'." Return the list of FUN results. If optional PROPERTY is non-nil only call FUN for javadoc keywords which have a value for PROPERTY. FUN receives two arguments: the javadoc keyword and its associated -'javadoc property list. It can return any value. All nil values are +`javadoc' property list. It can return any value. All nil values are removed from the result list." (delq nil (mapcar diff --git a/lisp/cedet/semantic/lex-spp.el b/lisp/cedet/semantic/lex-spp.el index 5912a887848..57e59f4e9fe 100644 --- a/lisp/cedet/semantic/lex-spp.el +++ b/lisp/cedet/semantic/lex-spp.el @@ -726,7 +726,7 @@ Returns position with the end of that macro." (point)))))) (defun semantic-lex-spp-get-overlay (&optional point) - "Return first overlay which has a 'semantic-spp property." + "Return first overlay which has a `semantic-spp' property." (let ((overlays (overlays-at (or point (point))))) (while (and overlays (null (overlay-get (car overlays) 'semantic-spp))) @@ -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 72864a8da52..885ffbf5a73 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/senator.el b/lisp/cedet/semantic/senator.el index ebc4159a4c5..1d16b024a5e 100644 --- a/lisp/cedet/semantic/senator.el +++ b/lisp/cedet/semantic/senator.el @@ -735,12 +735,9 @@ yanked to." Optional argument KILL-FLAG will delete the text of the tag to the kill ring. -Interactively, reads the register using `register-read-with-preview', -if available." - (interactive (list (if (fboundp 'register-read-with-preview) - (register-read-with-preview "Tag to register: ") - (read-char "Tag to register: ")) - current-prefix-arg)) +Interactively, reads the register using `register-read-with-preview'." + (interactive (list (register-read-with-preview "Tag to register: ") + current-prefix-arg)) (semantic-fetch-tags) (let ((ft (semantic-obtain-foreign-tag))) (when ft diff --git a/lisp/cedet/semantic/sort.el b/lisp/cedet/semantic/sort.el index 1503a766dc8..756b949c0d1 100644 --- a/lisp/cedet/semantic/sort.el +++ b/lisp/cedet/semantic/sort.el @@ -310,7 +310,7 @@ may re-organize the list with side-effects." ;; class tag. ;; (defvar-local semantic-orphaned-member-metaparent-type "class" - "In `semantic-adopt-external-members', the type of 'type for metaparents. + "In `semantic-adopt-external-members', the type of `type' for metaparents. A metaparent is a made-up type semantic token used to hold the child list of orphaned members of a named type.") diff --git a/lisp/cedet/semantic/symref.el b/lisp/cedet/semantic/symref.el index ba236059f66..e48cefa4ca6 100644 --- a/lisp/cedet/semantic/symref.el +++ b/lisp/cedet/semantic/symref.el @@ -101,7 +101,7 @@ Where PREDICATE is a function that takes a directory name for the root of a project, and returns non-nil if the tool represented by KEY is supported. -If no tools are supported, then 'grep is assumed.") +If no tools are supported, then `grep' is assumed.") (defun semantic-symref-calculate-rootdir () "Calculate the root directory for a symref search. @@ -475,7 +475,7 @@ already." Return the Semantic tag associated with HIT. SEARCHTXT is the text that is being searched for. Used to narrow the in-buffer search. -SEARCHTYPE is the type of search (such as 'symbol or 'tagname). +SEARCHTYPE is the type of search (such as `symbol' or `tagname'). If there is no database, or if the searchtype is wrong, return nil." ;; Allowed search types for this mechanism: ;; tagname, tagregexp, tagcompletions @@ -506,7 +506,7 @@ If there is no database, or if the searchtype is wrong, return nil." Return the Semantic tag associated with HIT. SEARCHTXT is the text that is being searched for. Used to narrow the in-buffer search. -SEARCHTYPE is the type of search (such as 'symbol or 'tagname). +SEARCHTYPE is the type of search (such as `symbol' or `tagname'). Optional OPEN-BUFFERS, when nil will use a faster version of `find-file' when a file needs to be opened. If non-nil, then normal buffer initialization will be used. diff --git a/lisp/cedet/semantic/texi.el b/lisp/cedet/semantic/texi.el index 1917bcb40a6..d005b7a854c 100644 --- a/lisp/cedet/semantic/texi.el +++ b/lisp/cedet/semantic/texi.el @@ -55,20 +55,17 @@ The field position is the field number (based at 1) where the name of this section is.") ;;; Code: -(defun semantic-texi-parse-region (&rest _ignore) +(define-mode-local-override semantic-parse-region texinfo-mode (&rest _ignore) "Parse the current texinfo buffer for semantic tags. IGNORE any arguments, always parse the whole buffer. Each tag returned is of the form: (\"NAME\" section (:members CHILDREN)) or - (\"NAME\" def) - -It is an override of `semantic-parse-region' and must be installed by the -function `semantic-install-function-overrides'." + (\"NAME\" def)" (mapcar #'semantic-texi-expand-tag (semantic-texi-parse-headings))) -(defun semantic-texi-parse-changes () +(define-mode-local-override semantic-parse-changes texinfo-mode () "Parse changes in the current texinfo buffer." ;; NOTE: For now, just schedule a full reparse. ;; To be implemented later. @@ -445,9 +442,6 @@ that start with that symbol." (defun semantic-default-texi-setup () "Set up a buffer for parsing of Texinfo files." ;; This will use our parser. - (semantic-install-function-overrides - '((semantic-parse-region . semantic-texi-parse-region) - (semantic-parse-changes . semantic-texi-parse-changes))) (setq semantic-parser-name "TEXI" ;; Setup a dummy parser table to enable parsing! semantic--parse-table t diff --git a/lisp/cedet/semantic/wisent.el b/lisp/cedet/semantic/wisent.el index 454ddde219b..55eeef453ea 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/cedet/semantic/wisent/comp.el b/lisp/cedet/semantic/wisent/comp.el index f842b3c364b..ba67d250604 100644 --- a/lisp/cedet/semantic/wisent/comp.el +++ b/lisp/cedet/semantic/wisent/comp.el @@ -65,6 +65,7 @@ (defmacro wisent-defcontext (name &rest vars) "Define a context NAME that will bind variables VARS." (declare (indent 1)) + (declare-function wisent-context-name nil (name)) (let* ((context (wisent-context-name name)) (declarations (mapcar (lambda (v) (list 'defvar v)) vars))) `(progn @@ -75,6 +76,7 @@ (defmacro wisent-with-context (name &rest body) "Bind variables in context NAME then eval BODY." (declare (indent 1)) + (declare-function wisent-context-bindings nil (name)) `(dlet ,(wisent-context-bindings name) ,@body)) diff --git a/lisp/cedet/semantic/wisent/grammar.el b/lisp/cedet/semantic/wisent/grammar.el index 5ca22bac86c..a4104e333d3 100644 --- a/lisp/cedet/semantic/wisent/grammar.el +++ b/lisp/cedet/semantic/wisent/grammar.el @@ -284,13 +284,15 @@ Return the expanded expression." (assocs (wisent-grammar-assocs))) (cons terminals (cons assocs nonterminals)))) -(defun wisent-grammar-parsetable-builder () +(define-mode-local-override semantic-grammar-parsetable-builder + wisent-grammar-mode () "Return the value of the parser table." `(wisent-compiled-grammar ,(wisent-grammar-grammar) ,(semantic-grammar-start))) -(defun wisent-grammar-setupcode-builder () +(define-mode-local-override semantic-grammar-setupcode-builder + wisent-grammar-mode () "Return the parser setup code." (format "(semantic-install-function-overrides\n\ @@ -322,10 +324,7 @@ Menu items are appended to the common grammar menu.") (define-derived-mode wisent-grammar-mode semantic-grammar-mode "WY" "Major mode for editing Wisent grammars." (semantic-grammar-setup-menu wisent-grammar-menu) - (setq-local semantic-grammar-require-form '(require 'semantic/wisent)) - (semantic-install-function-overrides - '((semantic-grammar-parsetable-builder . wisent-grammar-parsetable-builder) - (semantic-grammar-setupcode-builder . wisent-grammar-setupcode-builder)))) + (setq-local semantic-grammar-require-form '(require 'semantic/wisent))) (defvar-mode-local wisent-grammar-mode semantic-grammar-macros '( diff --git a/lisp/cedet/srecode/texi.el b/lisp/cedet/srecode/texi.el index 50b0e150ff3..c297429e408 100644 --- a/lisp/cedet/srecode/texi.el +++ b/lisp/cedet/srecode/texi.el @@ -246,7 +246,7 @@ that class. class => @code{class} @xref{class} unknown => @code{unknown} \"text\" => \\=`\\=`text\\='\\=' - 'quoteme => @code{quoteme} + \\='quoteme => @code{quoteme} non-nil => non-@code{nil} t => @code{t} :tag => @code{:tag} diff --git a/lisp/char-fold.el b/lisp/char-fold.el index 3eea630aa71..05ae52cae0d 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 ae4354fbbcf..22a465f5b61 100644 --- a/lisp/cmuscheme.el +++ b/lisp/cmuscheme.el @@ -195,6 +195,7 @@ to continue it." (scheme-mode-variables) (setq mode-line-process '(":%s")) (setq comint-input-filter (function scheme-input-filter)) + (setq-local comint-prompt-read-only t) (setq comint-get-old-input (function scheme-get-old-input))) (defcustom inferior-scheme-filter-regexp "\\`\\s *\\S ?\\S ?\\s *\\'" @@ -237,7 +238,7 @@ is run). (inferior-scheme-mode))) (setq scheme-program-name cmd) (setq scheme-buffer "*scheme*") - (pop-to-buffer-same-window "*scheme*")) + (pop-to-buffer "*scheme*" display-comint-buffer-action)) (defun scheme-start-file (prog) "Return the name of the start file corresponding to PROG. @@ -245,7 +246,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)))) @@ -356,7 +358,7 @@ With argument, position cursor at end of buffer." (interactive "P") (if (or (and scheme-buffer (get-buffer scheme-buffer)) (scheme-interactively-start-process)) - (pop-to-buffer-same-window scheme-buffer) + (pop-to-buffer scheme-buffer display-comint-buffer-action) (error "No current process buffer. See variable `scheme-buffer'")) (when eob-p (push-mark) diff --git a/lisp/color.el b/lisp/color.el index ef3a2f58362..410659869ae 100644 --- a/lisp/color.el +++ b/lisp/color.el @@ -407,7 +407,7 @@ See `color-desaturate-hsl'." Given a color defined in terms of hue, saturation, and luminance \(arguments H, S, and L), return a color that is PERCENT lighter. Returns a list (HUE SATURATION LUMINANCE)." - (list H S (color-clamp (+ L (/ percent 100.0))))) + (list H S (color-clamp (+ L (* L (/ percent 100.0)))))) (defun color-lighten-name (name percent) "Make a color with a specified NAME lighter by PERCENT. diff --git a/lisp/comint.el b/lisp/comint.el index 782833cc8fd..3da61fb992f 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." @@ -1105,7 +1110,8 @@ See also `comint-read-input-ring'." (use-local-map keymap)) (forward-line 3) (while (search-backward "completion" nil 'move) - (replace-match "history reference"))) + (replace-match (apply #'propertize "history reference" + (text-properties-at (point)))))) (sit-for 0) (message "Hit space to flush") (setq comint-dynamic-list-input-ring-window-conf conf) @@ -1510,6 +1516,7 @@ Intended to be added to `isearch-mode-hook' in `comint-mode'." #'comint-history-isearch-wrap) (setq-local isearch-push-state-function #'comint-history-isearch-push-state) + (setq-local isearch-lazy-count nil) (add-hook 'isearch-mode-end-hook 'comint-history-isearch-end nil t))) (defun comint-history-isearch-end () @@ -1521,6 +1528,7 @@ Intended to be added to `isearch-mode-hook' in `comint-mode'." (setq isearch-message-function nil) (setq isearch-wrap-function nil) (setq isearch-push-state-function nil) + (kill-local-variable 'isearch-lazy-count) (remove-hook 'isearch-mode-end-hook 'comint-history-isearch-end t) (unless isearch-suspended (custom-reevaluate-setting 'comint-history-isearch))) @@ -1812,7 +1820,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 +1913,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 +1964,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)) @@ -2022,7 +2039,7 @@ the start, the cdr to the end of the last prompt recognized.") Freezes the `font-lock-face' text property in place." (when comint-last-prompt (with-silent-modifications - (font-lock-prepend-text-property + (font-lock-append-text-property (car comint-last-prompt) (cdr comint-last-prompt) 'font-lock-face 'comint-highlight-prompt)) @@ -2141,14 +2158,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 +2190,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 +2505,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 @@ -3136,8 +3194,8 @@ inside of a \"[...]\" (see `skip-chars-forward'), plus all non-ASCII characters. (while (not giveup) (let ((startpoint (point))) (skip-chars-backward (concat "\\\\" word-chars)) - (if (and comint-file-name-quote-list - (eq (char-before (1- (point))) ?\\)) + (if (and (eq (char-before (1- (point))) ?\\) + (memq (char-before) comint-file-name-quote-list)) (forward-char -2)) ;; FIXME: This isn't consistent with Bash, at least -- not ;; all non-ASCII chars should be word constituents. @@ -3509,6 +3567,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 @@ -3906,10 +3978,12 @@ REGEXP-GROUP is the regular expression group in REGEXP to use." ;;; OSC escape sequences (Operating System Commands) ;;============================================================================ -;; Adding `comint-osc-process-output' to `comint-output-filter-functions' -;; enables the interpretation of OSC escape sequences. By default, only -;; OSC 8, for hyperlinks, is acted upon. Adding more entries to -;; `comint-osc-handlers' allows a customized treatment of further sequences. +;; Adding `comint-osc-process-output' to +;; `comint-output-filter-functions' enables the interpretation of OSC +;; escape sequences. By default, OSC 7 and 8 (for current directory +;; and hyperlinks respectively) are acted upon. Adding more entries +;; to `comint-osc-handlers' allows a customized treatment of further +;; sequences. (defvar-local comint-osc-handlers '(("7" . comint-osc-directory-tracker) ("8" . comint-osc-hyperlink-handler)) @@ -3954,9 +4028,9 @@ arguments, with point where the escape sequence was located." ;; Current directory tracking (OSC 7) -(declare-function url-host "url-parse.el") -(declare-function url-type "url-parse.el") -(declare-function url-filename "url-parse.el") +(declare-function url-host "url/url-parse.el") +(declare-function url-type "url/url-parse.el") +(declare-function url-filename "url/url-parse.el") (defun comint-osc-directory-tracker (_ text) "Update `default-directory' from OSC 7 escape sequences. diff --git a/lisp/completion.el b/lisp/completion.el index 6040ff4d334..fb700954b0e 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 fc931474606..d7ac75708c9 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 fd42c542b46..6dff9ec97a2 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -441,6 +441,7 @@ Use group `text' for this instead. This group is deprecated." (define-key map "u" 'Custom-goto-parent) (define-key map "n" 'widget-forward) (define-key map "p" 'widget-backward) + (define-key map "H" 'custom-toggle-hide-all-widgets) map) "Keymap for `Custom-mode'.") @@ -745,6 +746,9 @@ groups after non-groups, if nil do not order groups at all." (or custom-file user-init-file) "Un-customize settings in this and future sessions." "delete" "Uncustomize" (modified set changed rogue saved)) + (" Toggle hiding all values " custom-toggle-hide-all-widgets + t "Toggle hiding all values." + "hide" "Hide" t) (" Help for Customize " Custom-help t "Get help for using Customize." "help" "Help" t) (" Exit " Custom-buffer-done t "Exit Customize." "exit" "Exit" t)) @@ -1045,6 +1049,35 @@ If given a prefix (or a COMMENT argument), also prompt for a comment." value) ;;;###autoload +(defmacro setopt (&rest pairs) + "Set VARIABLE/VALUE pairs, and return the final VALUE. +This is like `setq', but is meant for user options instead of +plain variables. This means that `setopt' will execute any +`custom-set' form associated with VARIABLE. + +\(fn [VARIABLE VALUE]...)" + (declare (debug setq)) + (unless (zerop (mod (length pairs) 2)) + (error "PAIRS must have an even number of variable/value members")) + (let ((expr nil)) + (while pairs + (unless (symbolp (car pairs)) + (error "Attempting to set a non-symbol: %s" (car pairs))) + (push `(setopt--set ',(car pairs) ,(cadr pairs)) + expr) + (setq pairs (cddr pairs))) + (macroexp-progn (nreverse expr)))) + +;;;###autoload +(defun setopt--set (variable value) + (custom-load-symbol variable) + ;; Check that the type is correct. + (when-let ((type (get variable 'custom-type))) + (unless (widget-apply (widget-convert type) :match value) + (user-error "Value `%S' does not match type %s" value type))) + (funcall (or (get variable 'custom-set) #'set-default) variable value)) + +;;;###autoload (defun customize-save-variable (variable value &optional comment) "Set the default for VARIABLE to VALUE, and save it for future sessions. Return VALUE. @@ -1133,7 +1166,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 +1238,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. @@ -1465,7 +1498,7 @@ symbols `custom-face' or `custom-variable'." (custom-buffer-create (custom-sort-items found t nil) "*Customize Saved*")))) -(declare-function apropos-parse-pattern "apropos" (pattern)) +(declare-function apropos-parse-pattern "apropos" (pattern &optional di-all)) (defvar apropos-regexp) ;;;###autoload @@ -2176,7 +2209,7 @@ and `face'." ;;; The `custom' Widget. (defface custom-button - '((((type x w32 ns) (class color)) ; Like default mode line + '((((type x w32 ns haiku pgtk) (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 +2217,7 @@ and `face'." :group 'custom-faces) (defface custom-button-mouse - '((((type x w32 ns) (class color)) + '((((type x w32 ns haiku pgtk) (class color)) :box (:line-width 2 :style released-button) :background "grey90" :foreground "black") (t @@ -2209,7 +2242,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 pgtk) (class color)) :box (:line-width 2 :style pressed-button) :background "lightgrey" :foreground "black") (t :inverse-video t)) @@ -2805,6 +2838,39 @@ try matching its doc string against `custom-guess-doc-alist'." (custom-add-parent-links widget)) (custom-add-see-also widget))))) +(defvar custom--hidden-state) + +(defun custom-toggle-hide-all-widgets () + "Hide or show details of all customizable settings in a Custom buffer. +This command is for use in a Custom buffer that shows many +customizable settings, like \"*Customize Group*\" or \"*Customize Faces*\". +It toggles the display of each of the customizable settings in the buffer +between the expanded view, where the values of the settings and the value +menus to change them are visible; and the concise view, where only the +minimal details are shown, usually the name, the doc string and little +else." + (interactive) + (save-excursion + (goto-char (point-min)) + ;; Surely there's a better way to find all the "top level" widgets + ;; in a buffer, but I couldn't find it. + (while (not (eobp)) + (when-let* ((widget (widget-at (point))) + (parent (widget-get widget :parent)) + (state (widget-get parent :custom-state))) + (when (eq state 'changed) + (setq state 'standard)) + (when (and (eq (widget-type widget) 'custom-visibility) + (eq state custom--hidden-state)) + (custom-toggle-parent widget))) + (forward-line 1))) + (setq custom--hidden-state (if (eq custom--hidden-state 'hidden) + 'standard + 'hidden)) + (if (eq custom--hidden-state 'hidden) + (message "All variables hidden") + (message "All variables shown"))) + (defun custom-toggle-hide-variable (visibility-widget &rest _ignore) "Toggle the visibility of a `custom-variable' parent widget. By default, this signals an error if the parent has unsaved @@ -3458,6 +3524,10 @@ MS Windows.") :sibling-args (:help-echo "\ GNUstep or Macintosh OS Cocoa interface.") ns) + (const :format "PGTK " + :sibling-args (:help-echo "\ +Pure-GTK interface.") + ns) (const :format "DOS " :sibling-args (:help-echo "\ Plain MS-DOS.") @@ -3972,6 +4042,18 @@ Optional EVENT is the location for the menu." (setq comment nil) ;; Make the comment invisible by hand if it's empty (custom-comment-hide comment-widget)) + ;; When modifying the default face, we need to save the standard or themed + ;; attrs, in case the user asks to revert to them in the future. + ;; In GUIs, when resetting the attributes of the default face, the frame + ;; parameters associated with this face won't change, unless explicitly + ;; passed a value. Storing this known attrs allows us to tell faces.el to + ;; set those attributes to specified values, making the relevant frame + ;; parameters stay in sync with the default face. + (when (and (eq symbol 'default) + (not (get symbol 'custom-face-default-attrs)) + (memq (custom-face-state symbol) '(standard themed))) + (put symbol 'custom-face-default-attrs + (custom-face-get-current-spec symbol))) (custom-push-theme 'theme-face symbol 'user 'set value) (face-spec-set symbol value 'customized-face) (put symbol 'face-comment comment) @@ -3990,6 +4072,12 @@ Optional EVENT is the location for the menu." (setq comment nil) ;; Make the comment invisible by hand if it's empty (custom-comment-hide comment-widget)) + ;; See the comments in `custom-face-set'. + (when (and (eq symbol 'default) + (not (get symbol 'custom-face-default-attrs)) + (memq (custom-face-state symbol) '(standard themed))) + (put symbol 'custom-face-default-attrs + (custom-face-get-current-spec symbol))) (custom-push-theme 'theme-face symbol 'user 'set value) (face-spec-set symbol value (if standard 'reset 'saved-face)) (put symbol 'face-comment comment) @@ -4003,7 +4091,14 @@ Optional EVENT is the location for the menu." (defun custom-face-save (widget) "Save the face edited by WIDGET." - (let ((form (widget-get widget :custom-form))) + (let ((form (widget-get widget :custom-form)) + (symbol (widget-value widget))) + ;; See the comments in `custom-face-set'. + (when (and (eq symbol 'default) + (not (get symbol 'custom-face-default-attrs)) + (memq (custom-face-state symbol) '(standard themed))) + (put symbol 'custom-face-default-attrs + (custom-face-get-current-spec symbol))) (if (memq form '(all lisp)) (custom-face-mark-to-save widget) ;; The user is working on only a selected terminal type; @@ -4031,10 +4126,20 @@ uncustomized (themed or standard) face." (saved-face (get face 'saved-face)) (comment (get face 'saved-face-comment)) (comment-widget (widget-get widget :comment-widget))) + ;; If resetting the default face and there isn't a saved value, + ;; push a fake user setting, so that reverting to the default + ;; attributes works. (custom-push-theme 'theme-face face 'user - (if saved-face 'set 'reset) - saved-face) + (if (or saved-face (eq face 'default)) 'set 'reset) + (or saved-face + ;; If this is t, then MODE is 'reset, + ;; and `custom-push-theme' ignores this argument. + (not (eq face 'default)) + (get face 'custom-face-default-attrs))) (face-spec-set face saved-face 'saved-face) + (when (and (not saved-face) (eq face 'default)) + ;; Remove the fake user setting. + (custom-push-theme 'theme-face face 'user 'reset)) (put face 'face-comment comment) (put face 'customized-face-comment nil) (widget-value-set child saved-face) @@ -4056,8 +4161,15 @@ redraw the widget immediately." (comment-widget (widget-get widget :comment-widget))) (unless value (user-error "No standard setting for this face")) - (custom-push-theme 'theme-face symbol 'user 'reset) + ;; If erasing customizations for the default face, push a fake user setting, + ;; so that reverting to the default attributes works. + (custom-push-theme 'theme-face symbol 'user + (if (eq symbol 'default) 'set 'reset) + (or (not (eq symbol 'default)) + (get symbol 'custom-face-default-attrs))) (face-spec-set symbol value 'reset) + ;; Remove the fake user setting. + (custom-push-theme 'theme-face symbol 'user 'reset) (put symbol 'face-comment nil) (put symbol 'customized-face-comment nil) (if (and custom-reset-standard-faces-list @@ -4723,7 +4835,11 @@ if only the first line of the docstring is shown.")) (delay-mode-hooks (emacs-lisp-mode))) (let ((inhibit-read-only t) (print-length nil) - (print-level nil)) + (print-level nil) + ;; We might be saving byte-code with embedded NULs, which + ;; can cause problems when read back, so print them + ;; readably. (Bug#52554) + (print-escape-control-characters t)) (atomic-change-group (custom-save-variables) (custom-save-faces))) @@ -5151,7 +5267,8 @@ if that value is non-nil." :label (nth 5 arg))) custom-commands) (setq custom-tool-bar-map map)))) - (setq-local custom--invocation-options nil) + (setq-local custom--invocation-options nil + custom--hidden-state 'hidden) (setq-local revert-buffer-function #'custom--revert-buffer) (make-local-variable 'custom-options) (make-local-variable 'custom-local-buffer) diff --git a/lisp/cus-face.el b/lisp/cus-face.el index 8e629e26d0b..80d0aaa0d51 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) @@ -43,7 +46,7 @@ ;;; Face attributes. (defconst custom-face-attributes - '((:family + `((:family (string :tag "Font Family" :help-echo "Font family or fontset alias name.")) @@ -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" @@ -113,7 +133,7 @@ :help-echo "Control text underlining." (const :tag "Off" nil) (list :tag "On" - :value (:color foreground-color :style line) + :value (:color foreground-color :style line :position nil) (const :format "" :value :color) (choice :tag "Color" (const :tag "Foreground Color" foreground-color) @@ -121,28 +141,36 @@ (const :format "" :value :style) (choice :tag "Style" (const :tag "Line" line) - (const :tag "Wave" wave)))) + (const :tag "Wave" wave)) + (const :format "" :value :position) + (choice :tag "Position" + (const :tag "At Default Position" nil) + (const :tag "At Bottom Of Text" t) + (integer :tag "Pixels Above Bottom Of Text")))) ;; filter to make value suitable for customize - (lambda (real-value) - (and real-value - (let ((color - (or (and (consp real-value) (plist-get real-value :color)) - (and (stringp real-value) real-value) - 'foreground-color)) - (style - (or (and (consp real-value) (plist-get real-value :style)) - 'line))) - (list :color color :style style)))) + ,(lambda (real-value) + (and real-value + (let ((color + (or (and (consp real-value) (plist-get real-value :color)) + (and (stringp real-value) real-value) + 'foreground-color)) + (style + (or (and (consp real-value) (plist-get real-value :style)) + 'line)) + (position (and (consp real-value) + (plist-get real-value :style)))) + (list :color color :style style :position position)))) ;; filter to make customized-value suitable for storing - (lambda (cus-value) - (and cus-value - (let ((color (plist-get cus-value :color)) - (style (plist-get cus-value :style))) - (cond ((eq style 'line) - ;; Use simple value for default style - (if (eq color 'foreground-color) t color)) - (t - `(:color ,color :style ,style))))))) + ,(lambda (cus-value) + (and cus-value + (let ((color (plist-get cus-value :color)) + (style (plist-get cus-value :style)) + (position (plist-get cus-value :position))) + (cond ((and (eq style 'line) (not position)) + ;; Use simple value for default style + (if (eq color 'foreground-color) t color)) + (t + `(:color ,color :style ,style :position ,position))))))) (:overline (choice :tag "Overline" @@ -178,40 +206,40 @@ (const :tag "Flat" flat-button) (const :tag "None" nil)))) ;; filter to make value suitable for customize - (lambda (real-value) - (and real-value - (let ((lwidth - (or (and (consp real-value) - (if (listp (cdr real-value)) - (plist-get real-value :line-width) - real-value)) - (and (integerp real-value) real-value) - '(1 . 1))) - (color - (or (and (consp real-value) (plist-get real-value :color)) - (and (stringp real-value) real-value) - nil)) - (style - (and (consp real-value) (plist-get real-value :style)))) - (if (integerp lwidth) - (setq lwidth (cons (abs lwidth) lwidth))) - (list :line-width lwidth :color color :style style)))) + ,(lambda (real-value) + (and real-value + (let ((lwidth + (or (and (consp real-value) + (if (listp (cdr real-value)) + (plist-get real-value :line-width) + real-value)) + (and (integerp real-value) real-value) + '(1 . 1))) + (color + (or (and (consp real-value) (plist-get real-value :color)) + (and (stringp real-value) real-value) + nil)) + (style + (and (consp real-value) (plist-get real-value :style)))) + (if (integerp lwidth) + (setq lwidth (cons (abs lwidth) lwidth))) + (list :line-width lwidth :color color :style style)))) ;; filter to make customized-value suitable for storing - (lambda (cus-value) - (and cus-value - (let ((lwidth (plist-get cus-value :line-width)) - (color (plist-get cus-value :color)) - (style (plist-get cus-value :style))) - (cond ((and (null color) (null style)) - lwidth) - ((and (null lwidth) (null style)) - ;; actually can't happen, because LWIDTH is always an int - color) - (t - ;; Keep as a plist, but remove null entries - (nconc (and lwidth `(:line-width ,lwidth)) - (and color `(:color ,color)) - (and style `(:style ,style))))))))) + ,(lambda (cus-value) + (and cus-value + (let ((lwidth (plist-get cus-value :line-width)) + (color (plist-get cus-value :color)) + (style (plist-get cus-value :style))) + (cond ((and (null color) (null style)) + lwidth) + ((and (null lwidth) (null style)) + ;; actually can't happen, because LWIDTH is always an int + color) + (t + ;; Keep as a plist, but remove null entries + (nconc (and lwidth `(:line-width ,lwidth)) + (and color `(:color ,color)) + (and style `(:style ,style))))))))) (:inverse-video (choice :tag "Inverse-video" @@ -248,18 +276,18 @@ :help-echo "List of faces to inherit attributes from." (face :Tag "Face" default)) ;; filter to make value suitable for customize - (lambda (real-value) - (cond ((or (null real-value) (eq real-value 'unspecified)) - nil) - ((symbolp real-value) - (list real-value)) - (t - real-value))) + ,(lambda (real-value) + (cond ((or (null real-value) (eq real-value 'unspecified)) + nil) + ((symbolp real-value) + (list real-value)) + (t + real-value))) ;; filter to make customized-value suitable for storing - (lambda (cus-value) - (if (and (consp cus-value) (null (cdr cus-value))) - (car cus-value) - cus-value)))) + ,(lambda (cus-value) + (if (and (consp cus-value) (null (cdr cus-value))) + (car cus-value) + cus-value)))) "Alist of face attributes. @@ -301,12 +329,12 @@ If FRAME is nil, use the global defaults for FACE." "Apply a list of face specs for user customizations. This works by calling `custom-theme-set-faces' for the `user' theme, a special theme referring to settings made via Customize. -The arguments should be a list where each entry has the form: +The arguments ARGS should be a list where each entry has the form: (FACE SPEC [NOW [COMMENT]]) See the documentation of `custom-theme-set-faces' for details." - (apply 'custom-theme-set-faces 'user args)) + (apply #'custom-theme-set-faces 'user args)) (defun custom-theme-set-faces (theme &rest args) "Apply a list of face specs associated with theme THEME. @@ -391,7 +419,7 @@ Each of the arguments ARGS has this form: (FACE FROM-THEME) This means reset FACE to its value in FROM-THEME." - (apply 'custom-theme-reset-faces 'user args)) + (apply #'custom-theme-reset-faces 'user args)) (define-obsolete-function-alias 'custom-facep #'facep "28.1") diff --git a/lisp/cus-start.el b/lisp/cus-start.el index 38e328a7c64..d8c4b480359 100644 --- a/lisp/cus-start.el +++ b/lisp/cus-start.el @@ -356,6 +356,7 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of (const :tag "Iconify" t)) "26.1") (tooltip-reuse-hidden-frame tooltip boolean "26.1") + (use-system-tooltips tooltip boolean "29.1") ;; fringe.c (overflow-newline-into-fringe fringe boolean) ;; image.c @@ -369,7 +370,7 @@ Leaving \"Default\" unchecked is equivalent with specifying a default of (auto-save-timeout auto-save (choice (const :tag "off" nil) (integer :format "%v"))) (echo-keystrokes minibuffer number) - (polling-period keyboard integer) + (polling-period keyboard float) (double-click-time mouse (restricted-sexp :match-alternatives (integerp 'nil 't))) (double-click-fuzz mouse integer "22.1") @@ -386,7 +387,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 +573,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) @@ -808,6 +811,7 @@ since it could result in memory overflow and make Emacs crash." character) "27.1" :safe (lambda (value) (or (characterp value) (null value)))) + (composition-break-at-point display boolean "29.1") ;; xfaces.c (scalable-fonts-allowed display (choice (const :tag "Don't allow scalable fonts" nil) @@ -826,10 +830,17 @@ 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") + (x-gtk-use-native-input keyboard boolean "29.1") + (x-dnd-disable-motif-drag dnd boolean "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 +857,24 @@ 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)) + ((eq symbol 'process-error-pause-time) + (not (eq system-type 'ms-dos))) + ((eq symbol 'x-gtk-use-native-input) + (and (featurep 'x) + (featurep 'gtk))) ((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)) + (equal "x-dnd-disable-motif-drag" + (symbol-name symbol))) + (featurep 'x)) ((string-match "\\`x-" (symbol-name symbol)) (fboundp 'x-create-frame)) ((string-match "selection" (symbol-name symbol)) @@ -870,9 +895,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 8aab636f853..69ec837db88 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 968b28f7a89..a084304ff80 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. @@ -1419,6 +1422,22 @@ are not directories are omitted from the expansion." ;;; Enabling and disabling loaded themes. +(defcustom enable-theme-functions nil + "Abnormal hook that is run after a theme has been enabled. +The functions in the hook are called with one parameter -- the + name of the theme that's been enabled (as a symbol)." + :type 'hook + :group 'customize + :version "29.1") + +(defcustom disable-theme-functions nil + "Abnormal hook that is run after a theme has been disabled. +The functions in the hook are called with one parameter -- the + name of the theme that's been disabled (as a symbol)." + :type 'hook + :group 'customize + :version "29.1") + (defun enable-theme (theme) "Reenable all variable and face settings defined by THEME. THEME should be either `user', or a theme loaded via `load-theme'. @@ -1427,7 +1446,9 @@ After this function completes, THEME will have the highest precedence (after `user') among enabled themes. Note that any already-enabled themes remain enabled after this -function runs. To disable other themes, use `disable-theme'." +function runs. To disable other themes, use `disable-theme'. + +After THEME has been enabled, runs `enable-theme-functions'." (interactive (list (intern (completing-read "Enable custom theme: " @@ -1475,7 +1496,9 @@ function runs. To disable other themes, use `disable-theme'." (setq custom-enabled-themes (cons theme (remq theme custom-enabled-themes))) ;; Give the `user' theme the highest priority. - (enable-theme 'user))) + (enable-theme 'user)) + ;; Allow callers to react to the enabling. + (run-hook-with-args 'enable-theme-functions theme)) (defcustom custom-enabled-themes nil "List of enabled Custom Themes, highest precedence first. @@ -1520,7 +1543,9 @@ Setting this variable through Customize calls `enable-theme' or (defun disable-theme (theme) "Disable all variable and face settings defined by THEME. -See `custom-enabled-themes' for a list of enabled themes." +See `custom-enabled-themes' for a list of enabled themes. + +After THEME has been disabled, runs `disable-theme-functions'." (interactive (list (intern (completing-read "Disable custom theme: " @@ -1564,7 +1589,9 @@ See `custom-enabled-themes' for a list of enabled themes." "unspecified-fg" "black")) (face-set-after-frame-default frame)) (setq custom-enabled-themes - (delq theme custom-enabled-themes)))) + (delq theme custom-enabled-themes)) + ;; Allow callers to react to the disabling. + (run-hook-with-args 'disable-theme-functions theme))) ;; Only used if window-system not null. (declare-function x-get-resource "frame.c" diff --git a/lisp/dabbrev.el b/lisp/dabbrev.el index 220a2f52e92..215425f1367 100644 --- a/lisp/dabbrev.el +++ b/lisp/dabbrev.el @@ -225,18 +225,27 @@ or matched by `dabbrev-ignored-buffer-regexps'." (defcustom dabbrev-ignored-buffer-names '("*Messages*" "*Buffer List*") "List of buffer names that dabbrev should not check. -See also `dabbrev-ignored-buffer-regexps'." +See also `dabbrev-ignored-buffer-regexps' and +`dabbrev-ignored-buffer-modes'." :type '(repeat (string :tag "Buffer name")) :group 'dabbrev :version "20.3") (defcustom dabbrev-ignored-buffer-regexps nil "List of regexps matching names of buffers that dabbrev should not check. -See also `dabbrev-ignored-buffer-names'." +See also `dabbrev-ignored-buffer-names' and +`dabbrev-ignored-buffer-modes'." :type '(repeat regexp) :group 'dabbrev :version "21.1") +(defcustom dabbrev-ignored-buffer-modes '(archive-mode image-mode) + "Inhibit looking for abbreviations in buffers derived from these modes. +See also `dabbrev-ignored-buffer-names' and +`dabbrev-ignored-buffer-regexps'." + :type '(repeat symbol) + :version "29.1") + (defcustom dabbrev-check-other-buffers t "Should \\[dabbrev-expand] look in other buffers? nil: Don't look in other buffers. @@ -383,6 +392,14 @@ If the prefix argument is 16 (which comes from \\[universal-argument] \\[univers then it searches *all* buffers." (interactive "*P") (dabbrev--reset-global-variables) + (setq dabbrev--check-other-buffers (and arg t)) + (setq dabbrev--check-all-buffers + (and arg (= (prefix-numeric-value arg) 16))) + (let ((completion-at-point-functions '(dabbrev-capf))) + (completion-at-point))) + +(defun dabbrev-capf () + "Dabbrev completion function for `completion-at-point-functions'." (let* ((abbrev (dabbrev--abbrev-at-point)) (beg (progn (search-backward abbrev) (point))) (end (progn (search-forward abbrev) (point))) @@ -420,10 +437,7 @@ then it searches *all* buffers." (t (mapcar #'downcase completion-list))))))) (complete-with-action a list s p))))) - (setq dabbrev--check-other-buffers (and arg t)) - (setq dabbrev--check-all-buffers - (and arg (= (prefix-numeric-value arg) 16))) - (completion-in-region beg end table))) + (list beg end table))) ;;;###autoload (defun dabbrev-expand (arg) @@ -537,8 +551,9 @@ See also `dabbrev-abbrev-char-regexp' and \\[dabbrev-completion]." (if (not (or (eq dabbrev--last-buffer dabbrev--last-buffer-found) (minibuffer-window-active-p (selected-window)))) (progn - (message "Expansion found in `%s'" - (buffer-name dabbrev--last-buffer)) + (when (buffer-name dabbrev--last-buffer) + (message "Expansion found in `%s'" + (buffer-name dabbrev--last-buffer))) (setq dabbrev--last-buffer-found dabbrev--last-buffer)) (message nil)) (if (and (or (eq (current-buffer) dabbrev--last-buffer) @@ -632,19 +647,29 @@ See also `dabbrev-abbrev-char-regexp' and \\[dabbrev-completion]." "Return a list of other buffers to search for a possible abbrev. The current buffer is not included in the list. -This function makes a list of all the buffers returned by `buffer-list', -then discards buffers whose names match `dabbrev-ignored-buffer-names' -or `dabbrev-ignored-buffer-regexps'. It also discards buffers for which -`dabbrev-friend-buffer-function', if it is bound, returns nil when called -with the buffer as argument. -It returns the list of the buffers that are not discarded." +This function makes a list of all the buffers returned by +`buffer-list', then discards buffers whose names match +`dabbrev-ignored-buffer-names' or +`dabbrev-ignored-buffer-regexps', and major modes that match +`dabbrev-ignored-buffer-modes'. It also discards buffers for +which `dabbrev-friend-buffer-function', if it is bound, returns +nil when called with the buffer as argument. It returns the list +of the buffers that are not discarded." (dabbrev-filter-elements - buffer (buffer-list) + buffer (dabbrev--filter-buffer-modes) (and (not (eq (current-buffer) buffer)) (not (dabbrev--ignore-buffer-p buffer)) (boundp 'dabbrev-friend-buffer-function) (funcall dabbrev-friend-buffer-function buffer)))) +(defun dabbrev--filter-buffer-modes () + (seq-filter (lambda (buffer) + (not (apply + #'provided-mode-derived-p + (buffer-local-value 'major-mode buffer) + dabbrev-ignored-buffer-modes))) + (buffer-list))) + (defun dabbrev--try-find (abbrev reverse n ignore-case) "Search for ABBREV, backwards if REVERSE, N times. If IGNORE-CASE is non-nil, ignore case while searching. @@ -746,17 +771,41 @@ of the start of the occurrence." (make-progress-reporter "Scanning for dabbrevs..." (- (length dabbrev--friend-buffer-list)) 0 0 1 1.5)))) - ;; Walk through the buffers till we find a match. - (let (expansion) - (while (and (not expansion) dabbrev--friend-buffer-list) - (setq dabbrev--last-buffer (pop dabbrev--friend-buffer-list)) - (set-buffer dabbrev--last-buffer) - (progress-reporter-update dabbrev--progress-reporter - (- (length dabbrev--friend-buffer-list))) - (setq dabbrev--last-expansion-location (point-min)) - (setq expansion (dabbrev--try-find abbrev nil 1 ignore-case))) - (progress-reporter-done dabbrev--progress-reporter) - expansion))))) + (let ((file-name (buffer-file-name)) + file-name-buffer) + (unwind-protect + (progn + ;; Include the file name components into the abbrev + ;; list (because if you have a file name "foobar", it's + ;; somewhat likely that you'll be talking about foobar + ;; stuff in the file itself). + (when file-name + (setq file-name-buffer (generate-new-buffer " *abbrev-file*")) + (with-current-buffer file-name-buffer + (dolist (part (file-name-split file-name)) + (insert part "\n"))) + (setq dabbrev--friend-buffer-list + (append dabbrev--friend-buffer-list + (list file-name-buffer)))) + ;; Walk through the buffers till we find a match. + (let (expansion) + (while (and (not expansion) dabbrev--friend-buffer-list) + (setq dabbrev--last-buffer + (pop dabbrev--friend-buffer-list)) + (set-buffer dabbrev--last-buffer) + (progress-reporter-update + dabbrev--progress-reporter + (- (length dabbrev--friend-buffer-list))) + (setq dabbrev--last-expansion-location (point-min)) + (setq expansion (dabbrev--try-find + abbrev nil 1 ignore-case))) + (progress-reporter-done dabbrev--progress-reporter) + expansion)) + (when (buffer-live-p file-name-buffer) + (kill-buffer file-name-buffer)) + (setq dabbrev--friend-buffer-list + (seq-filter #'buffer-live-p + dabbrev--friend-buffer-list)))))))) ;; Compute the list of buffers to scan. ;; If dabbrev-search-these-buffers-only, then the current buffer @@ -779,7 +828,7 @@ of the start of the occurrence." (setq list (append list (dabbrev-filter-elements - buffer (buffer-list) + buffer (dabbrev--filter-buffer-modes) (and (not (memq buffer list)) (not (dabbrev--ignore-buffer-p buffer))))))) ;; Remove the current buffer. diff --git a/lisp/delsel.el b/lisp/delsel.el index 554b1e7249a..5310328e5fd 100644 --- a/lisp/delsel.el +++ b/lisp/delsel.el @@ -64,6 +64,19 @@ "If non-nil, deleted region text is stored in this register. Value must be the register (key) to use.") +(defcustom delete-selection-temporary-region nil + "Whether to delete only temporary regions. +When non-nil, typed text replaces only the regions set by +mouse-dragging, shift-selection, and \"\\[universal-argument] \\[exchange-point-and-mark]\" when +`transient-mark-mode' is turned off. If the value is the symbol +`selection', then replace only the regions set by mouse-dragging +and shift-selection." + :version "29.1" + :group 'editing-basics + :type '(choice (const :tag "Replace all regions" nil) + (const :tag "Replace region from mouse, shift-selection, and \"C-u C-x C-x\"" t) + (const :tag "Replace region from mouse and shift-selection" selection))) + ;;;###autoload (defalias 'pending-delete-mode 'delete-selection-mode) @@ -252,7 +265,13 @@ property on their symbol; commands which insert text but don't have this property won't delete the selection. See `delete-selection-helper'." (when (and delete-selection-mode (use-region-p) - (not buffer-read-only)) + (not buffer-read-only) + (or (null delete-selection-temporary-region) + (and delete-selection-temporary-region + (consp transient-mark-mode) + (eq (car transient-mark-mode) 'only)) + (and (not (eq delete-selection-temporary-region 'selection)) + (eq transient-mark-mode 'lambda)))) (delete-selection-helper (and (symbolp this-command) (get this-command 'delete-selection))))) diff --git a/lisp/descr-text.el b/lisp/descr-text.el index 4234deb73af..0f01ad676ae 100644 --- a/lisp/descr-text.el +++ b/lisp/descr-text.el @@ -176,6 +176,10 @@ otherwise." (insert "\n")) ;; Text properties (when properties + (when (plist-get properties 'invisible) + (insert "\nNote that character has an invisibility property,\n" + " so the character displayed at point in the buffer may\n" + " differ from the character described here.\n")) (newline) (insert "There are text properties here:\n") (describe-property-list properties))))) @@ -417,6 +421,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 +543,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 +688,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/desktop.el b/lisp/desktop.el index 041dbcf7c11..947f7cff5cb 100644 --- a/lisp/desktop.el +++ b/lisp/desktop.el @@ -231,16 +231,26 @@ Zero or nil means disable auto-saving due to idleness." (defcustom desktop-load-locked-desktop 'ask "Specifies whether the desktop should be loaded if locked. Possible values are: - t -- load anyway. - nil -- don't load. - ask -- ask the user. -If the value is nil, or `ask' and the user chooses not to load the desktop, -the normal hook `desktop-not-loaded-hook' is run." + t -- load anyway. + nil -- don't load. + ask -- ask the user. + check-pid -- load if locking Emacs process is missing locally. + +If the value is nil, or `ask' and the user chooses not to load +the desktop, the normal hook `desktop-not-loaded-hook' is run. + +If the value is `check-pid', load the desktop if the Emacs +process that has locked it is not running on the local machine. +This should not be used in circumstances where the locking Emacs +might still be running on another machine. That could be the +case if you have remotely mounted (NFS) paths in +`desktop-dirname'." :type '(choice (const :tag "Load anyway" t) (const :tag "Don't load" nil) - (const :tag "Ask the user" ask)) + (const :tag "Ask the user" ask) + (const :tag "Load if no local process" check-pid)) :group 'desktop :version "22.2") @@ -425,7 +435,9 @@ If `all', also restores frames that are partially offscreen onscreen. Note that checking of frame boundaries is only approximate. It can fail to reliably detect frames whose onscreen/offscreen state depends on a few pixels, especially near the right / bottom borders -of the screen." +of the screen. +Text-mode frames are always considered onscreen, so this option has +no effect on restoring frames in a non-GUI session." :type '(choice (const :tag "Only fully offscreen frames" t) (const :tag "Also partially offscreen frames" all) (const :tag "Do not force frames onscreen" nil)) @@ -636,6 +648,14 @@ Only valid during frame saving & restoring; intended for internal use.") "When the desktop file was last modified to the knowledge of this Emacs. Used to detect desktop file conflicts.") +(defun desktop--get-file-modtime () + "Get desktop file modtime, in list form for desktop format version 208." + (setq desktop-file-modtime + (time-convert (file-attribute-modification-time + (file-attributes + (desktop-full-file-name))) + 'list))) + (defvar desktop-var-serdes-funs (list (list 'mark-ring @@ -663,6 +683,44 @@ DIRNAME omitted or nil means use `desktop-dirname'." (integerp owner))) owner))) +(defun desktop--emacs-pid-running-p (pid) + "Return non-nil if an Emacs process whose ID is PID might still be running." + (when-let ((attr (process-attributes pid))) + (let ((proc-cmd (alist-get 'comm attr)) + (my-cmd (file-name-nondirectory (car command-line-args))) + (case-fold-search t)) + (or (equal proc-cmd my-cmd) + (and (eq system-type 'windows-nt) + (eq t (compare-strings proc-cmd + nil + (if (string-suffix-p ".exe" proc-cmd t) + -4) + my-cmd + nil + (if (string-suffix-p ".exe" my-cmd t) + -4)))) + ;; We should err on the safe side here: if any of the + ;; executables is something like "emacs-nox" or "emacs-42.1" + ;; or "gemacs" or "xemacs", let's recognize them as well. + (and (string-match-p "emacs" proc-cmd) + (string-match-p "emacs" my-cmd)))))) + +(defun desktop--load-locked-desktop-p (owner) + "Return t if a locked desktop should be loaded. +OWNER is the pid in the lock file. +The return value of this function depends on the value of +`desktop-load-locked-desktop'." + (pcase desktop-load-locked-desktop + ('ask + (unless (daemonp) + (y-or-n-p (format "Warning: desktop file appears to be in use by PID %s.\n\ +Using it may cause conflicts. Use it anyway? " owner)))) + ('check-pid + (or (eq (emacs-pid) owner) + (not (desktop--emacs-pid-running-p owner)))) + ('nil nil) + (_ t))) + (defun desktop-claim-lock (&optional dirname) "Record this Emacs process as the owner of the desktop file in DIRNAME. DIRNAME omitted or nil means use `desktop-dirname'." @@ -800,15 +858,16 @@ buffer, which is (in order): ,(buffer-name) ,major-mode ;; minor modes - ,(let (ret) - (dolist (minor-mode (mapcar #'car minor-mode-alist) ret) - (and (boundp minor-mode) - (symbol-value minor-mode) - (let* ((special (assq minor-mode desktop-minor-mode-table)) - (value (cond (special (cadr special)) - ((get minor-mode :minor-mode-function)) - ((functionp minor-mode) minor-mode)))) - (when value (cl-pushnew value ret)))))) + ,(seq-filter + (lambda (minor-mode) + ;; Just two sanity checks. + (and (boundp minor-mode) + (symbol-value minor-mode) + (let ((special + (assq minor-mode desktop-minor-mode-table))) + (or (not special) + (cadr special))))) + local-minor-modes) ;; point and mark, and read-only status ,(point) ,(list (mark t) mark-active) @@ -1073,7 +1132,7 @@ no questions asked." (file-attributes (desktop-full-file-name))))) (when (or (not new-modtime) ; nothing to overwrite - (equal desktop-file-modtime new-modtime) + (time-equal-p desktop-file-modtime new-modtime) (yes-or-no-p (if desktop-file-modtime (if (time-less-p desktop-file-modtime new-modtime) @@ -1173,9 +1232,7 @@ no questions asked." (write-region (point-min) (point-max) (desktop-full-file-name) nil 'nomessage)) (setq desktop-file-checksum checksum) ;; We remember when it was modified (which is presumably just now). - (setq desktop-file-modtime (file-attribute-modification-time - (file-attributes - (desktop-full-file-name))))))))))) + (desktop--get-file-modtime)))))))) ;; ---------------------------------------------------------------------------- ;;;###autoload @@ -1197,7 +1254,11 @@ This function also sets `desktop-dirname' to nil." ;; ---------------------------------------------------------------------------- (defun desktop-restoring-frameset-p () "True if calling `desktop-restore-frameset' will actually restore it." - (and desktop-restore-frames desktop-saved-frameset (display-graphic-p) t)) + (and desktop-restore-frames desktop-saved-frameset + ;; Don't restore frames when the selected frame is the daemon's + ;; initial frame. + (not (and (daemonp) (not (frame-parameter nil 'client)))) + t)) (defun desktop-restore-frameset () "Restore the state of a set of frames. @@ -1208,7 +1269,17 @@ being set (usually, by reading it from the desktop)." :reuse-frames (eq desktop-restore-reuses-frames t) :cleanup-frames (not (eq desktop-restore-reuses-frames 'keep)) :force-display desktop-restore-in-current-display - :force-onscreen desktop-restore-forces-onscreen))) + :force-onscreen (and desktop-restore-forces-onscreen + (display-graphic-p))) + ;; When at least one restored frame contains a tab bar, + ;; enable `tab-bar-mode' that takes care about recalculating + ;; the correct values of the frame parameter `tab-bar-lines' + ;; (that depends on `tab-bar-show'), and also loads graphical buttons. + (when (seq-some + (lambda (frame) + (menu-bar-positive-p (frame-parameter frame 'tab-bar-lines))) + (frame-list)) + (tab-bar-mode 1)))) ;; Just to silence the byte compiler. ;; Dynamically bound in `desktop-read'. @@ -1264,13 +1335,7 @@ It returns t if a desktop file was loaded, nil otherwise. (desktop-save nil) (desktop-autosave-was-enabled)) (if (and owner - (memq desktop-load-locked-desktop '(nil ask)) - (or (null desktop-load-locked-desktop) - (daemonp) - (not (y-or-n-p (format " -Warning: desktop file appears to be in use by process with PID %s.\n\ -Using it may cause conflicts if that process still runs.\n\ -Use desktop file anyway? " owner))))) + (not (desktop--load-locked-desktop-p owner))) (let ((default-directory desktop-dirname)) (setq desktop-dirname nil) (run-hooks 'desktop-not-loaded-hook) @@ -1290,9 +1355,7 @@ Use desktop file anyway? " owner))))) 'window-configuration-change-hook))) (desktop-auto-save-disable) ;; Evaluate desktop buffer and remember when it was modified. - (setq desktop-file-modtime (file-attribute-modification-time - (file-attributes - (desktop-full-file-name)))) + (desktop--get-file-modtime) (load (desktop-full-file-name) t t t) ;; If it wasn't already, mark it as in-use, to bother other ;; desktop instances. diff --git a/lisp/dframe.el b/lisp/dframe.el index 6593708a13c..9580a3187fd 100644 --- a/lisp/dframe.el +++ b/lisp/dframe.el @@ -120,9 +120,7 @@ :prefix "dframe-" :group 'dframe) -(defvar dframe-have-timer-flag (if (fboundp 'display-graphic-p) - (display-graphic-p) - window-system) +(defvar dframe-have-timer-flag (display-graphic-p) "Non-nil means that timers are available for this Emacs. This is nil for terminals, since updating a frame in a terminal is not useful to the user.") diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index d47bcf04279..4faf9431aa3 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) @@ -796,6 +796,15 @@ offer a smarter default choice of shell command." 'read-shell-command prompt nil nil)))) ;;;###autoload +(defcustom dired-confirm-shell-command t + "Whether to prompt for confirmation for `dired-do-shell-command'. +If non-nil, prompt for confirmation if the command contains potentially +dangerous characters. If nil, never prompt for confirmation." + :type 'boolean + :group 'dired + :version "29.1") + +;;;###autoload (defun dired-do-async-shell-command (command &optional arg file-list) "Run a shell command COMMAND on the marked files asynchronously. @@ -810,7 +819,9 @@ are executed in the background on each file sequentially waiting for each command to terminate before running the next command. In shell syntax this means separating the individual commands with `;'. -The output appears in the buffer named by `shell-command-buffer-name-async'." +The output appears in the buffer named by `shell-command-buffer-name-async'. + +Commands that are run asynchronously do not accept user input." (interactive (let ((files (dired-get-marked-files t current-prefix-arg nil nil t))) (list @@ -873,7 +884,9 @@ can be produced by `dired-get-marked-files', for example. `dired-guess-shell-alist-default' and `dired-guess-shell-alist-user' are consulted when the user is -prompted for the shell command to use interactively." +prompted for the shell command to use interactively. + +Also see the `dired-confirm-shell-command' variable." ;; Functions dired-run-shell-command and dired-shell-stuff-it do the ;; actual work and can be redefined for customization. (interactive @@ -891,6 +904,8 @@ prompted for the shell command to use interactively." (ok (cond ((not (or on-each no-subst)) (error "You can not combine `*' and `?' substitution marks")) + ((not dired-confirm-shell-command) + t) ((setq confirmations (dired--need-confirm-positions command "*")) (dired--no-subst-confirm confirmations command)) ((setq confirmations (dired--need-confirm-positions command "?")) @@ -954,6 +969,13 @@ prompted for the shell command to use interactively." (setq retval (replace-match x t t retval 2))) retval)) (lambda (x) (concat cmd-prefix command dired-mark-separator x))))) + ;; If a file name starts with "-", add a "./" to avoid the command + ;; interpreting it as a command line switch. + (setq file-list (mapcar (lambda (file) + (if (string-match "\\`-" file) + (concat "./" file) + file)) + file-list)) (concat (cond (on-each @@ -976,8 +998,15 @@ prompted for the shell command to use interactively." file-list dired-mark-separator))) (when (cdr file-list) (setq files (concat dired-mark-prefix files dired-mark-postfix))) - (funcall stuff-it files)))) - (or (and in-background "&") "")))) + (concat + (funcall stuff-it files) + ;; Be consistent in how we treat inputs to commands -- do + ;; the same here as in the `on-each' case. + (if (and in-background (not w32-shell)) + "&wait" + ""))))) + (or (and in-background "&") + "")))) ;; This is an extra function so that it can be redefined by ange-ftp. ;;;###autoload @@ -1009,6 +1038,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 +1064,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)))) @@ -1283,9 +1314,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))) @@ -1296,10 +1327,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. @@ -1317,7 +1348,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)) @@ -1347,9 +1379,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)) @@ -1364,7 +1397,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")))))))) @@ -1785,13 +1819,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))) @@ -1988,11 +2055,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 @@ -2108,18 +2176,23 @@ Prompt user for a target directory in which to create the new one file is marked. The initial suggestion for target is the Dired buffer's current directory (or, if `dired-dwim-target' is non-nil, the current directory of a neighboring Dired window). + OP-SYMBOL is the symbol for the operation. Function `dired-mark-pop-up' will determine whether pop-ups are appropriate for this OP-SYMBOL. + FILE-CREATOR and OPERATION as in `dired-create-files'. + ARG as in `dired-get-marked-files'. + Optional arg MARKER-CHAR as in `dired-create-files'. + Optional arg OP1 is an alternate form for OPERATION if there is only one file. + Optional arg HOW-TO determines how to treat the target. If HOW-TO is nil, use `file-directory-p' to determine if the target is a directory. If so, the marked file(s) are created - inside that directory. Otherwise, the target is a plain file; - an error is raised unless there is exactly one marked file. + inside that directory. If HOW-TO is t, target is always treated as a plain file. Otherwise, HOW-TO should be a function of one argument, TARGET. If its return value is nil, TARGET is regarded as a plain file. @@ -2132,6 +2205,11 @@ Optional arg HOW-TO determines how to treat the target. target - the name of the target itself. The rest of elements of the list returned by HOW-TO are optional arguments for the function that is the first element of the list. + + This can be useful because by default, copying a single file + would replace the tar file. But this could be overridden to + add or replace entries in the tar file. + For any other return value, TARGET is treated as a directory." (or op1 (setq op1 operation)) (let* ((fn-list (dired-get-marked-files nil arg nil nil t)) @@ -2161,7 +2239,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 @@ -2375,7 +2458,7 @@ If FILE already exists, signal an error." (defvar dired-copy-how-to-fn nil "Either nil or a function used by `dired-do-copy' to determine target. -See HOW-TO argument for `dired-do-create-files'.") +See HOW-TO argument for `dired-do-create-files' for an explanation.") ;;;###autoload (defun dired-do-copy (&optional arg) @@ -2396,6 +2479,10 @@ If `dired-copy-preserve-time' is non-nil, this command preserves the modification time of each old file in the copy, similar to the \"-p\" option for the \"cp\" shell command. +The `dired-keep-marker-copy' user option controls how this +command handles file marking. The default is to mark all new +copies of files with a \"C\" mark. + This command copies symbolic links by creating new ones, similar to the \"-d\" option for the \"cp\" shell command. But if `dired-copy-dereference' is non-nil, the symbolic @@ -2485,11 +2572,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 @@ -2610,11 +2698,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) @@ -2864,8 +2953,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))) @@ -2884,7 +2973,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 @@ -2894,6 +2982,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) @@ -3081,16 +3170,16 @@ a file name. Otherwise, it searches the whole buffer without restrictions." (define-minor-mode dired-isearch-filenames-mode "Toggle file names searching on or off. -When on, Isearch skips matches outside file names using the predicate -`dired-isearch-filter-filenames' that matches only at file names. -When off, it uses the original predicate." +When on, Isearch skips matches outside file names using the search function +`dired-isearch-search-filenames' that matches only at file names. +When off, it uses the default search function." :lighter nil (if dired-isearch-filenames-mode - (add-function :before-while (local 'isearch-filter-predicate) - #'dired-isearch-filter-filenames + (add-function :around (local 'isearch-search-fun-function) + #'dired-isearch-search-filenames '((isearch-message-prefix . "filename "))) - (remove-function (local 'isearch-filter-predicate) - #'dired-isearch-filter-filenames)) + (remove-function (local 'isearch-search-fun-function) + #'dired-isearch-search-filenames)) (when isearch-mode (setq isearch-success t isearch-adjusted t) (isearch-update))) @@ -3114,12 +3203,46 @@ Intended to be added to `isearch-mode-hook'." (unless isearch-suspended (kill-local-variable 'dired-isearch-filenames))) -(defun dired-isearch-filter-filenames (beg end) - "Test whether some part of the current search match is inside a file name. -This function returns non-nil if some part of the text between BEG and END -is part of a file name (i.e., has the text property `dired-filename')." - (text-property-not-all (min beg end) (max beg end) - 'dired-filename nil)) +(defun dired-isearch-search-filenames (orig-fun) + "Return the function that searches inside file names. +The returned function narrows the search to match the search string +only as part of a file name enclosed by the text property `dired-filename'. +It's intended to override the default search function." + (let ((search-fun (funcall orig-fun)) + (property 'dired-filename)) + (lambda (string &optional bound noerror count) + (let* ((old (point)) + ;; Check if point is already on the property. + (beg (when (get-text-property + (if isearch-forward old (max (1- old) (point-min))) + property) + old)) + end found) + ;; Otherwise, try to search for the next property. + (unless beg + (setq beg (if isearch-forward + (next-single-property-change old property) + (previous-single-property-change old property))) + (when beg (goto-char beg))) + ;; Non-nil `beg' means there are more properties. + (while (and beg (not found)) + ;; Search for the end of the current property. + (setq end (if isearch-forward + (next-single-property-change beg property) + (previous-single-property-change beg property))) + (setq found (funcall + search-fun string (if bound (if isearch-forward + (min bound end) + (max bound end)) + end) + noerror count)) + (unless found + (setq beg (if isearch-forward + (next-single-property-change end property) + (previous-single-property-change end property))) + (when beg (goto-char beg)))) + (unless found (goto-char old)) + found)))) ;;;###autoload (defun dired-isearch-filenames () @@ -3196,7 +3319,6 @@ resume the query replace with the command \\[fileloop-continue]." delimited) (fileloop-continue)) -(declare-function xref--show-xrefs "xref") (declare-function xref-query-replace-in-results "xref") (declare-function project--files-in-directory "project") @@ -3232,7 +3354,7 @@ REGEXP should use constructs supported by your local `grep' command." (project--files-in-directory mark ignores "*") files)) (push mark files))) - (nreverse marks)) + (reverse marks)) (message "Searching...") (setq xrefs (xref-matches-in-files regexp files)) @@ -3240,7 +3362,7 @@ REGEXP should use constructs supported by your local `grep' command." (user-error "No matches for: %s" regexp)) (message "Searching...done") xrefs)))) - (xref--show-xrefs fetcher nil))) + (xref-show-xrefs fetcher nil))) ;;;###autoload (defun dired-do-find-regexp-and-replace (from to) @@ -3258,7 +3380,10 @@ recursively. However, files matching `grep-find-ignored-files' and subdirectories matching `grep-find-ignored-directories' are skipped in the marked directories. -REGEXP should use constructs supported by your local `grep' command." +REGEXP should use constructs supported by your local `grep' command. + +Also see `query-replace' for user options that affect how this +function works." (interactive (let ((common (query-replace-read-args diff --git a/lisp/dired-x.el b/lisp/dired-x.el index 998cd46c7d6..56036b6c166 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]." @@ -638,8 +639,8 @@ you can relist single subdirs using \\[dired-do-redisplay]." ":\n")) (dired-mode dirname (or switches dired-listing-switches)) (setq mode-name "Virtual Dired" - revert-buffer-function 'dired-virtual-revert) - (setq-local dired-subdir-alist nil) + revert-buffer-function 'dired-virtual-revert + dired-subdir-alist nil) (dired-build-subdir-alist) (goto-char (point-min)) (dired-initial-position dirname)) @@ -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 f5ddd7aa39f..7df50a7b2ae 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -35,8 +35,10 @@ ;;; 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) +(require 'dnd) (declare-function dired-buffer-more-recently-used-p "dired-x" (buffer1 buffer2)) @@ -208,6 +210,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, @@ -235,6 +249,44 @@ The target is used in the prompt for file copy, rename etc." (other :tag "Try to guess" t)) :group 'dired) + +(defcustom dired-mouse-drag-files nil + "If non-nil, allow the mouse to drag files from inside a Dired buffer. +Dragging the mouse and then releasing it over the window of +another program will result in that program opening or creating a +copy of the file underneath the mouse pointer (or all marked +files if it was marked). This feature is supported only on X +Windows, Haiku, and Nextstep (macOS or GNUstep). + +If the value is `link', then a symbolic link will be created to +the file instead by the other program (usually a file manager). + +If the value is `move', then the default action will be for the +other program to move the file to a different location. For this +to work optimally, `auto-revert-mode' should be enabled in the +Dired buffer. + +If the Meta key is held down when the mouse button is pressed, +then this will always be equivalent to `link'. + +If the Control key is held down when the mouse button is pressed, +then dragging the file will always copy it to the new location. + +If the Shift key is held down when the mouse button is pressed, +then this will always be equivalent to `move'." + :set (lambda (option value) + (set-default option value) + (dolist (buffer (buffer-list)) + (with-current-buffer buffer + (when (derived-mode-p 'dired-mode) + (revert-buffer nil t))))) + :type '(choice (const :tag "Don't allow dragging" nil) + (const :tag "Copy file to new location" t) + (const :tag "Move file to new location" t) + (const :tag "Create symbolic link to file" link)) + :group 'dired + :version "29.1") + (defcustom dired-copy-preserve-time t "If non-nil, Dired preserves the last-modified time in a file copy. \(This works on only some systems.)" @@ -281,6 +333,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 +396,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 @@ -390,7 +447,7 @@ action argument symbol is `window-height' and its value is nil." "24.3") (defvar dired-file-version-alist) ;;;###autoload -(defvar dired-directory nil +(defvar-local dired-directory nil "The directory name or wildcard spec that this Dired directory lists. Local to each Dired buffer. May be a list, in which case the car is the directory name and the cdr is the list of files to mention. @@ -437,7 +494,7 @@ The directory name must be absolute, but need not be fully expanded.") (defvar dired-re-dot "^.* \\.\\.?/?$") ;; The subdirectory names in the next two lists are expanded. -(defvar dired-subdir-alist nil +(defvar-local dired-subdir-alist nil "Alist of listed directories and their buffer positions. Alist elements have the form (DIRNAME . STARTMARKER), where DIRNAME is the absolute name of the directory and STARTMARKER is @@ -768,6 +825,9 @@ that commands on the next ARG (instead of the marked) files can be chained easily. For any other non-nil value of ARG, use the current file. +If ARG is `marked', don't return the current file if nothing else +is marked. + If optional third arg SHOW-PROGRESS evaluates to non-nil, redisplay the dired buffer after each file is processed. @@ -789,7 +849,7 @@ marked file, return (t FILENAME) instead of (FILENAME)." ;;This warning should not apply any longer, sk 2-Sep-1991 14:10. `(prog1 (let ((inhibit-read-only t) case-fold-search found results) - (if ,arg + (if (and ,arg (not (eq ,arg 'marked))) (if (integerp ,arg) (progn ;; no save-excursion, want to move point. (dired-repeat-over-lines @@ -800,8 +860,8 @@ marked file, return (t FILENAME) instead of (FILENAME)." (if (< ,arg 0) (nreverse results) results)) - ;; non-nil, non-integer ARG means use current file: - (list ,body)) + ;; non-nil, non-integer, non-marked ARG means use current file: + (list ,body)) (let ((regexp (dired-marker-regexp)) next-position) (save-excursion (goto-char (point-min)) @@ -826,7 +886,8 @@ marked file, return (t FILENAME) instead of (FILENAME)." (setq results (cons t results))) (if found results - (list ,body))))) + (unless (eq ,arg 'marked) + (list ,body)))))) ;; save-excursion loses, again (dired-move-to-filename))) @@ -1245,40 +1306,42 @@ The return value is the target column for the file names." ;; This differs from dired-buffers-for-dir in that it does not consider ;; subdirs of default-directory and searches for the first match only. ;; Also, the major mode must be MODE. - (if (and (featurep 'dired-x) - dired-find-subdir - ;; 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)))) - (cur-buf-matches (and (memq cur-buf buffers) - ;; Wildcards must match, too: - (equal dired-directory dirname)))) - ;; We don't want to switch to the same buffer--- - (setq buffers (delq cur-buf buffers)) - (or (car (sort buffers #'dired-buffer-more-recently-used-p)) - ;; ---unless it's the only possibility: - (and cur-buf-matches cur-buf))) - ;; No dired-x, or dired-find-subdir nil. - (setq dirname (expand-file-name dirname)) - (let (found (blist dired-buffers)) ; was (buffer-list) - (or mode (setq mode 'dired-mode)) - (while blist - (if (null (buffer-name (cdr (car blist)))) - (setq blist (cdr blist)) - (with-current-buffer (cdr (car blist)) - (if (and (eq major-mode mode) - dired-directory ;; nil during find-alternate-file - (equal dirname - (expand-file-name - (if (consp dired-directory) - (car dired-directory) - dired-directory)))) - (setq found (cdr (car blist)) - blist nil) - (setq blist (cdr blist)))))) - found))) + ;; We bind `non-essential' in order to avoid hangs in remote buffers + ;; with a blocked connection. (Bug#54542) + (let ((non-essential t)) + (if (and (featurep 'dired-x) + dired-find-subdir + ;; 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 dirname))) + (cur-buf-matches (and (memq cur-buf buffers) + ;; Wildcards must match, too: + (equal dired-directory dirname)))) + ;; We don't want to switch to the same buffer--- + (setq buffers (delq cur-buf buffers)) + (or (car (sort buffers #'dired-buffer-more-recently-used-p)) + ;; ---unless it's the only possibility: + (and cur-buf-matches cur-buf))) + ;; No dired-x, or dired-find-subdir nil. + (setq dirname (expand-file-name dirname)) + (let (found (blist dired-buffers)) ; was (buffer-list) + (or mode (setq mode 'dired-mode)) + (while blist + (if (null (buffer-name (cdr (car blist)))) + (setq blist (cdr blist)) + (with-current-buffer (cdr (car blist)) + (if (and (eq major-mode mode) + dired-directory ;; nil during find-alternate-file + (equal dirname + (expand-file-name + (if (consp dired-directory) + (car dired-directory) + dired-directory)))) + (setq found (cdr (car blist)) + blist nil) + (setq blist (cdr blist)))))) + found)))) ;;; Read in a new dired buffer @@ -1322,13 +1385,15 @@ wildcards, erases the buffer, and builds the subdir-alist anew (goto-char (point-min)) ;; Must first make alist buffer local and set it to nil because ;; dired-build-subdir-alist will call dired-clear-alist first - (setq-local dired-subdir-alist nil) + (setq dired-subdir-alist nil) (dired-build-subdir-alist)) (let ((attributes (file-attributes dirname))) (if (eq (car attributes) t) (set-visited-file-modtime (file-attribute-modification-time 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) @@ -1609,15 +1674,134 @@ 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)))) + +(declare-function x-begin-drag "xfns.c") + +(defun dired-mouse-drag (event) + "Begin a drag-and-drop operation for the file at EVENT. +If there are marked files and that file is marked, drag every +other marked file as well. Otherwise, unmark all files." + (interactive "e") + (when mark-active + (deactivate-mark)) + (let* ((modifiers (event-modifiers event)) + (action (cond ((memq 'control modifiers) 'copy) + ((memq 'shift modifiers) 'move) + ((memq 'meta modifiers) 'link) + (t (if (memq dired-mouse-drag-files + '(copy move link)) + dired-mouse-drag-files + 'copy))))) + (save-excursion + (with-selected-window (posn-window (event-end event)) + (goto-char (posn-point (event-end event)))) + (track-mouse + (let ((beginning-position (mouse-pixel-position)) + new-event) + (catch 'track-again + (setq new-event (read-event)) + (if (not (eq (event-basic-type new-event) 'mouse-movement)) + (when (eq (event-basic-type new-event) 'mouse-1) + (push new-event unread-command-events)) + (let ((current-position (mouse-pixel-position))) + ;; If the mouse didn't move far enough, don't + ;; inadvertently trigger a drag. + (when (and (eq (car current-position) (car beginning-position)) + (ignore-errors + (and (> 3 (abs (- (cadr beginning-position) + (cadr current-position)))) + (> 3 (abs (- (caddr beginning-position) + (caddr current-position))))))) + (throw 'track-again nil))) + ;; We can get an error if there's by some chance no file + ;; name at point. + (condition-case error + (let ((filename (with-selected-window (posn-window + (event-end event)) + (let ((marked-files (dired-map-over-marks (dired-get-filename + nil 'no-error-if-not-filep) + 'marked)) + (file-name (dired-get-filename nil 'no-error-if-not-filep))) + (if (and marked-files + (member file-name marked-files)) + marked-files + (when marked-files + (dired-map-over-marks (dired-unmark nil) + 'marked)) + file-name))))) + (when filename + (if (and (consp filename) + (cdr filename)) + (dnd-begin-drag-files filename nil action t) + (dnd-begin-file-drag (if (stringp filename) + filename + (car filename)) + nil action t)))) + (error (when (eq (event-basic-type new-event) 'mouse-1) + (push new-event unread-command-events)) + ;; Errors from `dnd-begin-drag-file' should be + ;; treated as user errors, since they should + ;; only occur when the user performs an invalid + ;; action, such as trying to create a link to + ;; an invalid file. + (user-error error)))))))))) + +(defvar dired-mouse-drag-files-map (let ((keymap (make-sparse-keymap))) + (define-key keymap [down-mouse-1] #'dired-mouse-drag) + (define-key keymap [C-down-mouse-1] #'dired-mouse-drag) + (define-key keymap [S-down-mouse-1] #'dired-mouse-drag) + (define-key keymap [M-down-mouse-1] #'dired-mouse-drag) + keymap) + "Keymap applied to file names when `dired-mouse-drag-files' is enabled.") + (defun dired-insert-set-properties (beg end) "Add various text properties to the lines in the region, from BEG to END." (save-excursion @@ -1632,20 +1816,58 @@ see `dired-use-ls-dired' for more details.") 'invisible 'dired-hide-details-information)) (put-text-property (+ (line-beginning-position) 1) (1- (point)) 'invisible 'dired-hide-details-detail) + (when (and dired-mouse-drag-files (fboundp 'x-begin-drag)) + (put-text-property (point) + (save-excursion + (dired-move-to-end-of-filename) + (backward-char) + (point)) + 'keymap + dired-mouse-drag-files-map)) (add-text-properties (point) (progn (dired-move-to-end-of-filename) (point)) - '(mouse-face + `(mouse-face highlight dired-filename t - help-echo "mouse-2: visit this file in other window")) + help-echo ,(if (and dired-mouse-drag-files + (fboundp 'x-begin-drag)) + "down-mouse-1: drag this file to another program +mouse-2: visit this file in other window" + "mouse-2: visit this file in other window"))) (when (< (+ (point) 4) (line-end-position)) (put-text-property (+ (point) 4) (line-end-position) '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 @@ -1838,160 +2060,152 @@ Do so according to the former subdir alist OLD-SUBDIR-ALIST." ;;; Dired mode key bindings and menus -(defvar dired-mode-map +(defvar-keymap dired-mode-map + :doc "Local keymap for Dired mode buffers." + :full t + :parent special-mode-map ;; This looks ugly when substitute-command-keys uses C-d instead d: - ;; (define-key dired-mode-map "\C-d" 'dired-flag-file-deletion) - (let ((map (make-keymap))) - (set-keymap-parent map special-mode-map) - (define-key map [mouse-2] 'dired-mouse-find-file-other-window) - (define-key map [follow-link] 'mouse-face) - ;; Commands to mark or flag certain categories of files - (define-key map "#" 'dired-flag-auto-save-files) - (define-key map "." 'dired-clean-directory) - (define-key map "~" 'dired-flag-backup-files) - ;; Upper case keys (except !) for operating on the marked files - (define-key map "A" 'dired-do-find-regexp) - (define-key map "C" 'dired-do-copy) - (define-key map "B" 'dired-do-byte-compile) - (define-key map "D" 'dired-do-delete) - (define-key map "G" 'dired-do-chgrp) - (define-key map "H" 'dired-do-hardlink) - (define-key map "L" 'dired-do-load) - (define-key map "M" 'dired-do-chmod) - (define-key map "O" 'dired-do-chown) - (define-key map "P" 'dired-do-print) - (define-key map "Q" 'dired-do-find-regexp-and-replace) - (define-key map "R" 'dired-do-rename) - (define-key map "S" 'dired-do-symlink) - (define-key map "T" 'dired-do-touch) - (define-key map "X" 'dired-do-shell-command) - (define-key map "Z" 'dired-do-compress) - (define-key map "c" 'dired-do-compress-to) - (define-key map "!" 'dired-do-shell-command) - (define-key map "&" 'dired-do-async-shell-command) - ;; Comparison commands - (define-key map "=" 'dired-diff) - ;; Tree Dired commands - (define-key map "\M-\C-?" 'dired-unmark-all-files) - (define-key map "\M-\C-d" 'dired-tree-down) - (define-key map "\M-\C-u" 'dired-tree-up) - (define-key map "\M-\C-n" 'dired-next-subdir) - (define-key map "\M-\C-p" 'dired-prev-subdir) - ;; move to marked files - (define-key map "\M-{" 'dired-prev-marked-file) - (define-key map "\M-}" 'dired-next-marked-file) - ;; Make all regexp commands share a `%' prefix: - ;; We used to get to the submap via a symbol dired-regexp-prefix, - ;; but that seems to serve little purpose, and copy-keymap - ;; does a better job without it. - (define-key map "%" nil) - (define-key map "%u" 'dired-upcase) - (define-key map "%l" 'dired-downcase) - (define-key map "%d" 'dired-flag-files-regexp) - (define-key map "%g" 'dired-mark-files-containing-regexp) - (define-key map "%m" 'dired-mark-files-regexp) - (define-key map "%r" 'dired-do-rename-regexp) - (define-key map "%C" 'dired-do-copy-regexp) - (define-key map "%H" 'dired-do-hardlink-regexp) - (define-key map "%R" 'dired-do-rename-regexp) - (define-key map "%S" 'dired-do-symlink-regexp) - (define-key map "%&" 'dired-flag-garbage-files) - ;; Commands for marking and unmarking. - (define-key map "*" nil) - (define-key map "**" 'dired-mark-executables) - (define-key map "*/" 'dired-mark-directories) - (define-key map "*@" 'dired-mark-symlinks) - (define-key map "*%" 'dired-mark-files-regexp) - (define-key map "*N" 'dired-number-of-marked-files) - (define-key map "*c" 'dired-change-marks) - (define-key map "*s" 'dired-mark-subdir-files) - (define-key map "*m" 'dired-mark) - (define-key map "*u" 'dired-unmark) - (define-key map "*?" 'dired-unmark-all-files) - (define-key map "*!" 'dired-unmark-all-marks) - (define-key map "U" 'dired-unmark-all-marks) - (define-key map "*\177" 'dired-unmark-backward) - (define-key map "*\C-n" 'dired-next-marked-file) - (define-key map "*\C-p" 'dired-prev-marked-file) - (define-key map "*t" 'dired-toggle-marks) - ;; Lower keys for commands not operating on all the marked files - (define-key map "a" 'dired-find-alternate-file) - (define-key map "d" 'dired-flag-file-deletion) - (define-key map "e" 'dired-find-file) - (define-key map "f" 'dired-find-file) - (define-key map "\C-m" 'dired-find-file) - (put 'dired-find-file :advertised-binding "\C-m") - (define-key map "g" 'revert-buffer) - (define-key map "i" 'dired-maybe-insert-subdir) - (define-key map "j" 'dired-goto-file) - (define-key map "k" 'dired-do-kill-lines) - (define-key map "l" 'dired-do-redisplay) - (define-key map "m" 'dired-mark) - (define-key map "n" 'dired-next-line) - (define-key map "o" 'dired-find-file-other-window) - (define-key map "\C-o" 'dired-display-file) - (define-key map "p" 'dired-previous-line) - (define-key map "s" 'dired-sort-toggle-or-edit) - (define-key map "t" 'dired-toggle-marks) - (define-key map "u" 'dired-unmark) - (define-key map "v" 'dired-view-file) - (define-key map "w" 'dired-copy-filename-as-kill) - (define-key map "W" 'browse-url-of-dired-file) - (define-key map "x" 'dired-do-flagged-delete) - (define-key map "y" 'dired-show-file-type) - (define-key map "+" 'dired-create-directory) - ;; moving - (define-key map "<" 'dired-prev-dirline) - (define-key map ">" 'dired-next-dirline) - (define-key map "^" 'dired-up-directory) - (define-key map " " 'dired-next-line) - (define-key map [?\S-\ ] 'dired-previous-line) - (define-key map [remap next-line] 'dired-next-line) - (define-key map [remap previous-line] 'dired-previous-line) - ;; hiding - (define-key map "$" 'dired-hide-subdir) - (define-key map "\M-$" 'dired-hide-all) - (define-key map "(" 'dired-hide-details-mode) - ;; isearch - (define-key map (kbd "M-s a C-s") 'dired-do-isearch) - (define-key map (kbd "M-s a M-C-s") 'dired-do-isearch-regexp) - (define-key map (kbd "M-s f C-s") 'dired-isearch-filenames) - (define-key map (kbd "M-s f M-C-s") 'dired-isearch-filenames-regexp) - ;; misc - (define-key map [remap read-only-mode] 'dired-toggle-read-only) - ;; `toggle-read-only' is an obsolete alias for `read-only-mode' - (define-key map [remap toggle-read-only] 'dired-toggle-read-only) - (define-key map "?" 'dired-summary) - (define-key map "\177" 'dired-unmark-backward) - (define-key map [remap undo] 'dired-undo) - (define-key map [remap advertised-undo] 'dired-undo) - (define-key map [remap vc-next-action] 'dired-vc-next-action) - ;; thumbnail manipulation (image-dired) - (define-key map "\C-td" 'image-dired-display-thumbs) - (define-key map "\C-tt" 'image-dired-tag-files) - (define-key map "\C-tr" 'image-dired-delete-tag) - (define-key map "\C-tj" '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) - (define-key map "\C-t\C-t" 'image-dired-dired-toggle-marked-thumbs) - (define-key map "\C-te" 'image-dired-dired-edit-comment-and-tags) - ;; encryption and decryption (epa-dired) - (define-key map ":d" 'epa-dired-do-decrypt) - (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.") + ;; "C-d" #'dired-flag-file-deletion + "<mouse-2>" #'dired-mouse-find-file-other-window + "<follow-link>" 'mouse-face + ;; Commands to mark or flag certain categories of files + "#" #'dired-flag-auto-save-files + "." #'dired-clean-directory + "~" #'dired-flag-backup-files + ;; Upper case keys (except !) for operating on the marked files + "A" #'dired-do-find-regexp + "C" #'dired-do-copy + "B" #'dired-do-byte-compile + "D" #'dired-do-delete + "G" #'dired-do-chgrp + "H" #'dired-do-hardlink + "L" #'dired-do-load + "M" #'dired-do-chmod + "O" #'dired-do-chown + "P" #'dired-do-print + "Q" #'dired-do-find-regexp-and-replace + "R" #'dired-do-rename + "S" #'dired-do-symlink + "T" #'dired-do-touch + "X" #'dired-do-shell-command + "Z" #'dired-do-compress + "c" #'dired-do-compress-to + "!" #'dired-do-shell-command + "&" #'dired-do-async-shell-command + ;; Comparison commands + "=" #'dired-diff + ;; Tree Dired commands + "M-DEL" #'dired-unmark-all-files + "C-M-d" #'dired-tree-down + "C-M-u" #'dired-tree-up + "C-M-n" #'dired-next-subdir + "C-M-p" #'dired-prev-subdir + ;; move to marked files + "M-{" #'dired-prev-marked-file + "M-}" #'dired-next-marked-file + ;; Make all regexp commands share a `%' prefix: + ;; We used to get to the submap via a symbol dired-regexp-prefix, + ;; but that seems to serve little purpose, and copy-keymap + ;; does a better job without it. + "% u" #'dired-upcase + "% l" #'dired-downcase + "% d" #'dired-flag-files-regexp + "% g" #'dired-mark-files-containing-regexp + "% m" #'dired-mark-files-regexp + "% r" #'dired-do-rename-regexp + "% C" #'dired-do-copy-regexp + "% H" #'dired-do-hardlink-regexp + "% R" #'dired-do-rename-regexp + "% S" #'dired-do-symlink-regexp + "% &" #'dired-flag-garbage-files + ;; Commands for marking and unmarking. + "* *" #'dired-mark-executables + "* /" #'dired-mark-directories + "* @" #'dired-mark-symlinks + "* %" #'dired-mark-files-regexp + "* N" #'dired-number-of-marked-files + "* c" #'dired-change-marks + "* s" #'dired-mark-subdir-files + "* m" #'dired-mark + "* u" #'dired-unmark + "* ?" #'dired-unmark-all-files + "* !" #'dired-unmark-all-marks + "U" #'dired-unmark-all-marks + "* DEL" #'dired-unmark-backward + "* C-n" #'dired-next-marked-file + "* C-p" #'dired-prev-marked-file + "* t" #'dired-toggle-marks + ;; Lower keys for commands not operating on all the marked files + "a" #'dired-find-alternate-file + "d" #'dired-flag-file-deletion + "e" #'dired-find-file + "f" #'dired-find-file + "C-m" #'dired-find-file + "g" #'revert-buffer + "i" #'dired-maybe-insert-subdir + "j" #'dired-goto-file + "k" #'dired-do-kill-lines + "l" #'dired-do-redisplay + "m" #'dired-mark + "n" #'dired-next-line + "o" #'dired-find-file-other-window + "C-o" #'dired-display-file + "p" #'dired-previous-line + "s" #'dired-sort-toggle-or-edit + "t" #'dired-toggle-marks + "u" #'dired-unmark + "v" #'dired-view-file + "w" #'dired-copy-filename-as-kill + "W" #'browse-url-of-dired-file + "x" #'dired-do-flagged-delete + "y" #'dired-show-file-type + "+" #'dired-create-directory + ;; moving + "<" #'dired-prev-dirline + ">" #'dired-next-dirline + "^" #'dired-up-directory + "SPC" #'dired-next-line + "S-SPC" #'dired-previous-line + "<remap> <next-line>" #'dired-next-line + "<remap> <previous-line>" #'dired-previous-line + ;; hiding + "$" #'dired-hide-subdir + "M-$" #'dired-hide-all + "(" #'dired-hide-details-mode + ;; isearch + "M-s a C-s" #'dired-do-isearch + "M-s a C-M-s" #'dired-do-isearch-regexp + "M-s f C-s" #'dired-isearch-filenames + "M-s f C-M-s" #'dired-isearch-filenames-regexp + ;; misc + "<remap> <read-only-mode>" #'dired-toggle-read-only + ;; `toggle-read-only' is an obsolete alias for `read-only-mode' + "<remap> <toggle-read-only>" #'dired-toggle-read-only + "?" #'dired-summary + "DEL" #'dired-unmark-backward + "<remap> <undo>" #'dired-undo + "<remap> <advertised-undo>" #'dired-undo + "<remap> <vc-next-action>" #'dired-vc-next-action + ;; thumbnail manipulation (image-dired) + "C-t d" #'image-dired-display-thumbs + "C-t t" #'image-dired-tag-files + "C-t r" #'image-dired-delete-tag + "C-t j" #'image-dired-jump-thumbnail-buffer + "C-t i" #'image-dired-dired-display-image + "C-t x" #'image-dired-dired-display-external + "C-t a" #'image-dired-display-thumbs-append + "C-t ." #'image-dired-display-thumb + "C-t c" #'image-dired-dired-comment-files + "C-t f" #'image-dired-mark-tagged-files + "C-t C-t" #'image-dired-dired-toggle-marked-thumbs + "C-t e" #'image-dired-dired-edit-comment-and-tags + ;; encryption and decryption (epa-dired) + ": d" #'epa-dired-do-decrypt + ": v" #'epa-dired-do-verify + ": s" #'epa-dired-do-sign + ": e" #'epa-dired-do-encrypt) + +(put 'dired-find-file :advertised-binding (kbd "RET")) (easy-menu-define dired-mode-subdir-menu dired-mode-map "Subdir menu for Dired mode." @@ -2291,7 +2505,7 @@ Keybindings: (setq-local buffer-stale-function #'dired-buffer-stale-p) (setq-local buffer-auto-revert-by-notification t) (setq-local page-delimiter "\n\n") - (setq-local dired-directory (or dirname default-directory)) + (setq dired-directory (or dirname default-directory)) ;; list-buffers uses this to display the dir being edited in this buffer. (setq list-buffers-directory (expand-file-name (if (listp dired-directory) @@ -2342,6 +2556,8 @@ If the current buffer can be edited with Wdired, (i.e. the major mode is `dired-mode'), call `wdired-change-to-wdired-mode'. Otherwise, toggle `read-only-mode'." (interactive) + (unless (file-exists-p default-directory) + (user-error "The current directory no longer exists")) (when (and (not (file-writable-p default-directory)) (not (y-or-n-p "Directory isn't writable; edit anyway? "))) @@ -2418,7 +2634,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 @@ -2680,7 +2898,7 @@ permissions are hidden from view. See options: `dired-hide-details-hide-symlink-targets' and `dired-hide-details-hide-information-lines'." :group 'dired - (unless (derived-mode-p 'dired-mode) + (unless (derived-mode-p 'dired-mode 'wdired-mode) (error "Not a Dired buffer")) (dired-hide-details-update-invisibility-spec) (if dired-hide-details-mode @@ -2880,7 +3098,7 @@ matches FILE. 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)) @@ -3446,7 +3664,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)))) @@ -3762,7 +3980,11 @@ this subdir." (let ((inhibit-read-only t)) (dired-repeat-over-lines (prefix-numeric-value arg) - (lambda () (delete-char 1) (insert dired-marker-char))))))) + (lambda () + (when (or (not (looking-at-p dired-re-dot)) + (not (equal dired-marker-char dired-del-marker))) + (delete-char 1) + (insert dired-marker-char)))))))) (defun dired-unmark (arg &optional interactive) "Unmark the file at point in the Dired buffer. @@ -4083,9 +4305,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/display-line-numbers.el b/lisp/display-line-numbers.el index 860aa758bce..897a88398fd 100644 --- a/lisp/display-line-numbers.el +++ b/lisp/display-line-numbers.el @@ -108,6 +108,84 @@ the mode is on, set `display-line-numbers' directly." (define-globalized-minor-mode global-display-line-numbers-mode display-line-numbers-mode display-line-numbers--turn-on) + + +;;;###autoload +(defvar header-line-indent "" + "String to indent at the start if the header line. +This is used in `header-line-indent-mode', and buffers that have +this switched on should have a `header-line-format' that look like: + + (\"\" header-line-indent THE-REST...) + +Also see `header-line-indent-width'.") + +;;;###autoload +(defvar header-line-indent-width 0 + "The width of the current line numbers displayed. +This is updated when `header-line-indent-mode' is switched on. + +Also see `header-line-indent'.") + +(defun header-line-indent--line-number-width () + "Return the width taken by `display-line-numbers' in the current buffer." + ;; line-number-display-width returns the value for the selected + ;; window, which might not be the window in which the current buffer + ;; is displayed. + (if (not display-line-numbers) + 0 + (let ((cbuf-window (get-buffer-window (current-buffer) t))) + (if (window-live-p cbuf-window) + (with-selected-window cbuf-window + (truncate (line-number-display-width 'columns))) + 4)))) + +(defun header-line-indent--watch-line-number-width (_window) + (let ((width (header-line-indent--line-number-width))) + (setq header-line-indent-width width) + (unless (= (length header-line-indent) width) + (setq header-line-indent (make-string width ?\s))))) + +(defun header-line-indent--window-scroll-function (window _start) + (let ((width (with-selected-window window + (truncate (line-number-display-width 'columns))))) + (setq header-line-indent-width width) + (unless (= (length header-line-indent) width) + (setq header-line-indent (make-string width ?\s))))) + +;;;###autoload +(define-minor-mode header-line-indent-mode + "Mode to indent the header line in `display-line-numbers-mode' buffers. +This means that the header line will be kept indented so that it +has blank space that's as wide as the displayed line numbers in +the buffer. + +Buffers that have this switched on should have a +`header-line-format' that look like: + + (\"\" header-line-indent THE-REST...) + +The `header-line-indent-width' variable is also kept updated, and +has the width of `header-line-format'. This can be used, for +instance, in `:align-to' specs, like: + + (space :align-to (+ header-line-indent-width 10))" + :lighter nil + (if header-line-indent-mode + (progn + (setq-local header-line-indent "" + header-line-indent-width 0) + (add-hook 'pre-redisplay-functions + #'header-line-indent--watch-line-number-width nil t) + (add-hook 'window-scroll-functions + #'header-line-indent--window-scroll-function nil t)) + (setq-local header-line-indent "" + header-line-indent-width 0) + (remove-hook 'pre-redisplay-functions + #'header-line-indent--watch-line-number-width t) + (remove-hook 'window-scroll-functions + #'header-line-indent--window-scroll-function t))) + (provide 'display-line-numbers) ;;; display-line-numbers.el ends here diff --git a/lisp/dnd.el b/lisp/dnd.el index 97e81e9bf11..14d80ac6c57 100644 --- a/lisp/dnd.el +++ b/lisp/dnd.el @@ -33,6 +33,9 @@ ;;; Customizable variables +(eval-when-compile + (require 'cl-lib)) + (defgroup dnd nil "Handling data from drag and drop." :group 'environment) @@ -42,8 +45,7 @@ `((,(purecopy "^file:///") . dnd-open-local-file) ; XDND format. (,(purecopy "^file://") . dnd-open-file) ; URL with host (,(purecopy "^file:") . dnd-open-local-file) ; Old KDE, Motif, Sun - (,(purecopy "^\\(https?\\|ftp\\|file\\|nfs\\)://") . dnd-open-file) - ) + (,(purecopy "^\\(https?\\|ftp\\|file\\|nfs\\)://") . dnd-open-file)) "The functions to call for different protocols when a drop is made. This variable is used by `dnd-handle-one-url' and `dnd-handle-file-name'. @@ -57,7 +59,8 @@ If no match is found, the URL is inserted as text by calling `dnd-insert-text'. The function shall return the action done (move, copy, link or private) if some action was made, or nil if the URL is ignored." :version "22.1" - :type '(repeat (cons (regexp) (function)))) + :type '(repeat (cons (regexp) (function))) + :group 'dnd) (defcustom dnd-open-remote-file-function @@ -73,17 +76,68 @@ Predefined functions are `dnd-open-local-file' and `dnd-open-remote-url'. is the default on MS-Windows. `dnd-open-remote-url' uses `url-handler-mode' and is the default except for MS-Windows." :version "22.1" - :type 'function) + :type 'function + :group 'dnd) (defcustom dnd-open-file-other-window nil "If non-nil, always use `find-file-other-window' to open dropped files." :version "22.1" - :type 'boolean) - + :type 'boolean + :group 'dnd) + +(defcustom dnd-scroll-margin nil + "The scroll margin inside a window underneath the cursor during drag-and-drop. +If the mouse moves this many lines close to the top or bottom of +a window while dragging text, then that window will be scrolled +down and up respectively." + :type '(choice (const :tag "Don't scroll during mouse movement") + (integer :tag "This many lines from window top or bottom")) + :version "29.1" + :group 'dnd) + +(defcustom dnd-indicate-insertion-point nil + "Whether or not point should follow the position of the mouse. +If non-nil, the point of the window underneath the mouse will be +adjusted to reflect where any text will be inserted upon drop +when the mouse moves while receiving a drop from another +program." + :type 'boolean + :version "29.1" + :group 'dnd) ;; Functions +(defun dnd-handle-movement (posn) + "Handle mouse movement to POSN when receiving a drop from another program." + (when (windowp (posn-window posn)) + (with-selected-window (posn-window posn) + (when dnd-scroll-margin + (ignore-errors + (let* ((row (cdr (posn-col-row posn))) + (window (when (windowp (posn-window posn)) + (posn-window posn))) + (text-height (window-text-height window)) + ;; Make sure it's possible to scroll both up + ;; and down if the margin is too large for the + ;; window. + (margin (min (/ text-height 3) dnd-scroll-margin))) + ;; At 2 lines, the window becomes too small for any + ;; meaningful scrolling. + (unless (<= text-height 2) + (cond + ;; Inside the bottom scroll margin, scroll up. + ((> row (- text-height margin)) + (with-selected-window window + (scroll-up 1))) + ;; Inside the top scroll margin, scroll down. + ((< row margin) + (with-selected-window window + (scroll-down 1)))))))) + (when dnd-indicate-insertion-point + (ignore-errors + (goto-char (posn-point posn))))))) + (defun dnd-handle-one-url (window action url) "Handle one dropped url by calling the appropriate handler. The handler is first located by looking at `dnd-protocol-alist'. @@ -227,6 +281,235 @@ TEXT is the text as a string, WINDOW is the window where the drop happened." (insert text)) action) + +;;; Functions for dragging stuff to other programs. These build upon +;;; the lower-level `x-begin-drag' interface, but take care of data +;;; types and abstracting around the different return values. + +(defvar dnd-last-dragged-remote-file nil + "If non-nil, the name of a local copy of the last remote file that was dragged. +This may also be a list of files, if multiple files were dragged. +It can't be removed immediately after the drag-and-drop operation +completes, since there is no way to determine when the drop +target has finished opening it. So instead, this file is removed +when Emacs exits or the user drags another file.") + +(defun dnd-remove-last-dragged-remote-file () + "Remove the local copy of the last remote file to be dragged. +If `dnd-last-dragged-remote-file' is a list, remove all the files +in that list instead." + (when dnd-last-dragged-remote-file + (unwind-protect + (if (consp dnd-last-dragged-remote-file) + (mapc #'delete-file dnd-last-dragged-remote-file) + (delete-file dnd-last-dragged-remote-file)) + (setq dnd-last-dragged-remote-file nil))) + (remove-hook 'kill-emacs-hook + #'dnd-remove-last-dragged-remote-file)) + +(declare-function x-begin-drag "xfns.c") + +(defun dnd-begin-text-drag (text &optional frame action allow-same-frame) + "Begin dragging TEXT from FRAME. +Initate a drag-and-drop operation allowing the user to drag text +from Emacs to another program (the drop target), then block until +the drop is completed or is cancelled. + +If the drop completed, return the action that the drop target +actually performed, which can be one of the following symbols: + + - `copy', which means TEXT was inserted by the drop target. + + - `move', which means TEXT was inserted, and the caller should + additionally delete TEXT from its source (such as the buffer + where it originated). + + - `private', which means the drop target chose to perform an + unspecified action. + +Return nil if the drop was cancelled. + +TEXT is a string containing text that will be inserted by the +program where the drop happened. FRAME is the frame where the +mouse is currently held down, or nil, which stands for the +current frame. ACTION is one of the symbols `copy' or `move', +where `copy' means that the text should be inserted by the drop +target, and `move' means the the same as `copy', but in addition +the caller might have to delete TEXT from its source after this +function returns. If ALLOW-SAME-FRAME is nil, ignore any drops +on FRAME itself. + +This function might return immediately if no mouse buttons are +currently being held down. It should only be called upon a +`down-mouse-1' (or similar) event." + (unless (fboundp 'x-begin-drag) + (error "Dragging text from Emacs is not supported by this window system")) + (gui-set-selection 'XdndSelection text) + (unless action + (setq action 'copy)) + (let ((return-value + (x-begin-drag '(;; Traditional X selection targets used by GTK, the + ;; Motif drag-and-drop protocols, and programs like + ;; Xterm. `STRING' is also used on NS and Haiku. + "STRING" "TEXT" "COMPOUND_TEXT" "UTF8_STRING" + ;; Used by Xdnd clients that strictly comply with + ;; the standard (i.e. Qt programs). + "text/plain" "text/plain;charset=utf-8") + (cl-ecase action + ('copy 'XdndActionCopy) + ('move 'XdndActionMove)) + frame nil allow-same-frame))) + (cond + ((eq return-value 'XdndActionCopy) 'copy) + ((eq return-value 'XdndActionMove) 'move) + ((not return-value) nil) + (t 'private)))) + +(defun dnd-begin-file-drag (file &optional frame action allow-same-frame) + "Begin dragging FILE from FRAME. +Initate a drag-and-drop operation allowing the user to drag a file +from Emacs to another program (the drop target), then block until +the drop happens or is cancelled. + +Return the action that the drop target actually performed, which +can be one of the following symbols: + + - `copy', which means FILE was opened by the drop target. + + - `move', which means FILE was moved to another location by the + drop target. + + - `link', which means a symbolic link was created to FILE by + the drop target, usually a file manager. + + - `private', which means the drop target chose to perform an + unspecified action. + +Return nil if the drop was cancelled. + +FILE is the file name that will be sent to the program where the +drop happened. If it is a remote file, Emacs will make a +temporary copy and pass that. FRAME is the frame where the mouse +is currently held down, or nil (which means to use the current +frame). ACTION is one of the symbols `copy', `move' or `link', +where `copy' means that the file should be opened or copied by +the drop target, `move' means the drop target should move the +file to another location, and `link' means the drop target should +create a symbolic link to FILE. It is an error to specify `link' +as the action if FILE is a remote file. If ALLOW-SAME-FRAME is +nil, any drops on FRAME itself will be ignored. + +This function might return immediately if no mouse buttons are +currently being held down. It should only be called upon a +`down-mouse-1' (or similar) event." + (unless (fboundp 'x-begin-drag) + (error "Dragging files from Emacs is not supported by this window system")) + (dnd-remove-last-dragged-remote-file) + (unless action + (setq action 'copy)) + (let ((original-file file)) + (when (file-remote-p file) + (if (eq action 'link) + (error "Cannot create symbolic link to remote file") + (setq file (file-local-copy file)) + (setq dnd-last-dragged-remote-file file) + (add-hook 'kill-emacs-hook + #'dnd-remove-last-dragged-remote-file))) + (gui-set-selection 'XdndSelection + (propertize (expand-file-name file) 'text/uri-list + (concat "file://" + (expand-file-name file)))) + (let ((return-value + (x-begin-drag '(;; Xdnd types used by GTK, Qt, and most other + ;; modern programs that expect filenames to + ;; be supplied as URIs. + "text/uri-list" "text/x-dnd-username" + ;; Traditional X selection targets used by + ;; programs supporting the Motif + ;; drag-and-drop protocols. Also used by NS + ;; and Haiku. + "FILE_NAME" "FILE" "HOST_NAME" + ;; ToolTalk filename. Mostly used by CDE + ;; programs. + "_DT_NETFILE") + (cl-ecase action + ('copy 'XdndActionCopy) + ('move 'XdndActionMove) + ('link 'XdndActionLink)) + frame nil allow-same-frame))) + (cond + ((eq return-value 'XdndActionCopy) 'copy) + ((eq return-value 'XdndActionMove) + (prog1 'move + ;; If original-file is a remote file, delete it from the + ;; remote as well. + (when (file-remote-p original-file) + (ignore-errors + (delete-file original-file))))) + ((eq return-value 'XdndActionLink) 'link) + ((not return-value) nil) + (t 'private))))) + +(defun dnd-begin-drag-files (files &optional frame action allow-same-frame) + "Begin dragging FILES from FRAME. +This is like `dnd-begin-file-drag', except with multiple files. +FRAME, ACTION and ALLOW-SAME-FRAME mean the same as in +`dnd-begin-file-drag'. + +FILES is a list of files that will be dragged. If the drop +target doesn't support dropping multiple files, the first file in +FILES will be dragged." + (unless (fboundp 'x-begin-drag) + (error "Dragging files from Emacs is not supported by this window system")) + (dnd-remove-last-dragged-remote-file) + (let* ((new-files (copy-sequence files)) + (tem new-files)) + (while tem + (setcar tem (expand-file-name (car tem))) + (when (file-remote-p (car tem)) + (when (eq action 'link) + (error "Cannot create symbolic link to remote file")) + (setcar tem (file-local-copy (car tem))) + (push (car tem) dnd-last-dragged-remote-file)) + (setq tem (cdr tem))) + (unless action + (setq action 'copy)) + (gui-set-selection 'XdndSelection + (propertize (car new-files) + 'text/uri-list + (cl-loop for file in new-files + collect (concat "file://" file) + into targets finally return + (apply #'vector targets)) + 'FILE_NAME (apply #'vector new-files))) + (let ((return-value + (x-begin-drag '(;; Xdnd types used by GTK, Qt, and most other + ;; modern programs that expect filenames to + ;; be supplied as URIs. + "text/uri-list" "text/x-dnd-username" + ;; Traditional X selection targets used by + ;; programs supporting the Motif + ;; drag-and-drop protocols. Also used by NS + ;; and Haiku. + "FILE_NAME" "HOST_NAME") + (cl-ecase action + ('copy 'XdndActionCopy) + ('move 'XdndActionMove) + ('link 'XdndActionLink)) + frame nil allow-same-frame))) + (cond + ((eq return-value 'XdndActionCopy) 'copy) + ((eq return-value 'XdndActionMove) + (prog1 'move + ;; If original-file is a remote file, delete it from the + ;; remote as well. + (dolist (original-file files) + (when (file-remote-p original-file) + (ignore-errors + (delete-file original-file)))))) + ((eq return-value 'XdndActionLink) 'link) + ((not return-value) nil) + (t 'private))))) (provide 'dnd) diff --git a/lisp/doc-view.el b/lisp/doc-view.el index 836bfaf910f..9d27347360b 100644 --- a/lisp/doc-view.el +++ b/lisp/doc-view.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2007-2022 Free Software Foundation, Inc. ;; ;; Author: Tassilo Horn <tsdh@gnu.org> -;; Keywords: files, pdf, ps, dvi +;; Keywords: files, pdf, ps, dvi, djvu, epub, cbz, fb2, xps, openxps ;; This file is part of GNU Emacs. @@ -25,17 +25,19 @@ ;; Viewing PS/PDF/DVI files requires Ghostscript, `dvipdf' (comes with ;; Ghostscript) or `dvipdfm' (comes with teTeX or TeXLive) and ;; `pdftotext', which comes with xpdf (https://www.foolabs.com/xpdf/) -;; or poppler (https://poppler.freedesktop.org/). -;; Djvu documents require `ddjvu' (from DjVuLibre). -;; ODF files require `soffice' (from LibreOffice). +;; or poppler (https://poppler.freedesktop.org/). EPUB, CBZ, FB2, XPS +;; and OXPS documents require `mutool' which comes with mupdf +;; (https://mupdf.com/index.html). Djvu documents require `ddjvu' +;; (from DjVuLibre). ODF files require `soffice' (from LibreOffice). ;;; Commentary: ;; DocView is a document viewer for Emacs. It converts a number of -;; document formats (including PDF, PS, DVI, Djvu and ODF files) to a -;; set of PNG files, one PNG for each page, and displays the PNG -;; images inside an Emacs buffer. This buffer uses `doc-view-mode' -;; which provides convenient key bindings for browsing the document. +;; document formats (including PDF, PS, DVI, Djvu, ODF, EPUB, CBZ, +;; FB2, XPS and OXPS files) to a set of PNG (or TIFF for djvu) files, +;; one image for each page, and displays the images inside an Emacs +;; buffer. This buffer uses `doc-view-mode' which provides convenient +;; key bindings for browsing the document. ;; ;; To use it simply open a document file with ;; @@ -147,7 +149,10 @@ ;;;; Customization Options (defgroup doc-view nil - "In-buffer viewer for PDF, PostScript, DVI, and DJVU files." + "In-buffer document viewer. +The viewer handles PDF, PostScript, DVI, DJVU, ODF, EPUB, CBZ, +FB2, XPS and OXPS files, if the appropriate converter programs +are available (see Info node `(emacs)Document View')" :link '(function-link doc-view) :version "22.2" :group 'applications @@ -221,6 +226,44 @@ Higher values result in larger images." :type 'number) +(defcustom doc-view-mutool-user-stylesheet nil + "User stylesheet to use when converting EPUB documents to PDF." + :type '(choice (const nil) + (file :must-match t)) + :version "29.1") + +(defvar doc-view-doc-type nil + "The type of document in the current buffer. +Can be `dvi', `pdf', `ps', `djvu', `odf', `epub', `cbz', `fb2', +`xps' or `oxps'.") + +;; FIXME: The doc-view-current-* definitions below are macros because they +;; map to accessors which we want to use via `setf' as well! +(defmacro doc-view-current-page (&optional win) + `(image-mode-window-get 'page ,win)) +(defmacro doc-view-current-info () '(image-mode-window-get 'info)) +(defmacro doc-view-current-overlay () '(image-mode-window-get 'overlay)) +(defmacro doc-view-current-image () '(image-mode-window-get 'image)) +(defmacro doc-view-current-slice () '(image-mode-window-get 'slice)) + +(defvar-local doc-view--current-cache-dir nil + "Only used internally.") + +(defun doc-view-custom-set-epub-font-size (option-name new-value) + (set-default option-name new-value) + (dolist (x (buffer-list)) + (with-current-buffer x + (when (eq doc-view-doc-type 'epub) + (delete-directory doc-view--current-cache-dir t) + (doc-view-initiate-display) + (doc-view-goto-page (doc-view-current-page)))))) + +(defcustom doc-view-epub-font-size nil + "Font size in points for EPUB layout." + :type '(choice (const nil) integer) + :set #'doc-view-custom-set-epub-font-size + :version "29.1") + (defcustom doc-view-scale-internally t "Whether we should try to rescale images ourselves. If nil, the document is re-rendered every time the scaling factor is modified. @@ -256,9 +299,7 @@ If this and `doc-view-dvipdfm-program' are set, `doc-view-dvipdf-program' will be preferred." :type 'file) -(define-obsolete-variable-alias 'doc-view-unoconv-program - 'doc-view-odf->pdf-converter-program - "24.4") +(define-obsolete-variable-alias 'doc-view-unoconv-program 'doc-view-odf->pdf-converter-program "24.4") (defcustom doc-view-odf->pdf-converter-program (cond @@ -363,9 +404,6 @@ of the page moves to the previous page." (defvar-local doc-view--current-timer nil "Only used internally.") -(defvar-local doc-view--current-cache-dir nil - "Only used internally.") - (defvar-local doc-view--current-search-matches nil "Only used internally.") @@ -380,10 +418,6 @@ files inside an archive it is a temporary copy of the (uncompressed, extracted) file residing in `doc-view-cache-directory'.") -(defvar doc-view-doc-type nil - "The type of document in the current buffer. -Can be `dvi', `pdf', `ps', `djvu' or `odf'.") - (defvar doc-view-single-page-converter-function nil "Function to call to convert a single page of the document to a bitmap file. May operate on the source document or on some intermediate (typically PDF) @@ -464,17 +498,17 @@ Typically \"page-%s.png\".") ;; It's normal for this operation to result in a very large undo entry. (setq-local undo-outer-limit (* 2 (buffer-size)))) (cl-labels ((revert () - (let ((revert-buffer-preserve-modes t)) - (apply orig-fun args) - ;; Update the cached version of the pdf file, - ;; too. This is the one that's used when - ;; rendering (bug#26996). - (unless (equal buffer-file-name - doc-view--buffer-file-name) - ;; FIXME: Lars says he needed to recreate - ;; the dir, we should figure out why. - (doc-view-make-safe-dir doc-view-cache-directory) - (write-region nil nil doc-view--buffer-file-name))))) + (let ((revert-buffer-preserve-modes t)) + (apply orig-fun args) + ;; Update the cached version of the pdf file, + ;; too. This is the one that's used when + ;; rendering (bug#26996). + (unless (equal buffer-file-name + doc-view--buffer-file-name) + ;; FIXME: Lars says he needed to recreate + ;; the dir, we should figure out why. + (doc-view-make-safe-dir doc-view-cache-directory) + (write-region nil nil doc-view--buffer-file-name))))) (if (and (eq 'pdf doc-view-doc-type) (executable-find "pdfinfo")) ;; We don't want to revert if the PDF file is corrupted which @@ -493,24 +527,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,16 +599,17 @@ Typically \"page-%s.png\".") map) "Keymap used by `doc-view-minor-mode'.") -;;;; Navigation Commands +(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])) -;; FIXME: The doc-view-current-* definitions below are macros because they -;; map to accessors which we want to use via `setf' as well! -(defmacro doc-view-current-page (&optional win) - `(image-mode-window-get 'page ,win)) -(defmacro doc-view-current-info () '(image-mode-window-get 'info)) -(defmacro doc-view-current-overlay () '(image-mode-window-get 'overlay)) -(defmacro doc-view-current-image () '(image-mode-window-get 'image)) -(defmacro doc-view-current-slice () '(image-mode-window-get 'slice)) +;;;; Navigation Commands (defun doc-view-last-page-number () (length doc-view--current-files)) @@ -552,17 +632,16 @@ Typically \"page-%s.png\".") (propertize (format "Page %d of %d." page len) 'face 'bold) ;; Tell user if converting isn't finished yet - (if doc-view--current-converter-processes - " (still converting...)\n" - "\n") - ;; Display context infos if this page matches the last search - (when (and doc-view--current-search-matches - (assq page doc-view--current-search-matches)) - (concat (propertize "Search matches:\n" 'face 'bold) + (and doc-view--current-converter-processes + " (still converting...)") + ;; Display context infos if this page matches the last search + (when (and doc-view--current-search-matches + (assq page doc-view--current-search-matches)) + (concat "\n" (propertize "Search matches:" 'face 'bold) (let ((contexts "")) (dolist (m (cdr (assq page doc-view--current-search-matches))) - (setq contexts (concat contexts " - \"" m "\"\n"))) + (setq contexts (concat contexts "\n - \"" m "\""))) contexts))))) ;; Update the buffer ;; We used to find the file name from doc-view--current-files but @@ -683,7 +762,7 @@ at the top edge of the page moves to the previous page." (interactive) (while (consp doc-view--current-converter-processes) (ignore-errors ;; Some entries might not be processes, and maybe - ;; some are dead already? + ; some are dead already? (kill-process (pop doc-view--current-converter-processes)))) (when doc-view--current-timer (cancel-timer doc-view--current-timer) @@ -744,8 +823,8 @@ It's a subdirectory of `doc-view-cache-directory'." ;;;###autoload (defun doc-view-mode-p (type) "Return non-nil if document type TYPE is available for `doc-view'. -Document types are symbols like `dvi', `ps', `pdf', or `odf' (any -OpenDocument format)." +Document types are symbols like `dvi', `ps', `pdf', `epub', +`cbz', `fb2', `xps', `oxps', or`odf' (any OpenDocument format)." (and (display-graphic-p) (image-type-available-p 'png) (cond @@ -756,15 +835,22 @@ 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)) + ;; for pdf also check for `doc-view-pdfdraw-program' + (when (eq type 'pdf) + (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) (doc-view-mode-p 'pdf))) ((eq type 'djvu) (executable-find "ddjvu")) + ((memq type '(epub cbz fb2 xps oxps)) + ;; first check if `doc-view-pdfdraw-program' is set to mutool + (and (string= doc-view-pdfdraw-program "mutool") + (executable-find "mutool"))) (t ;; unknown image type nil)))) @@ -997,7 +1083,7 @@ Should be invoked when the cached images aren't up-to-date." ;; some file-name-handler-managed dir, for example). (let* ((default-directory (or (unhandled-file-name-directory default-directory) - (expand-file-name "~/"))) + (expand-file-name "~/"))) (proc (apply #'start-process name doc-view-conversion-buffer program args))) (push proc doc-view--current-converter-processes) @@ -1083,14 +1169,25 @@ The test is performed using `doc-view-pdfdraw-program'." (search-forward "error: cannot authenticate password" nil t))) (defun doc-view-pdf->png-converter-mupdf (pdf png page callback) - (let ((pdf-passwd (if (doc-view-pdf-password-protected-pdfdraw-p pdf) - (read-passwd "Enter password for PDF file: ")))) + (let* ((pdf-passwd (if (doc-view-pdf-password-protected-pdfdraw-p pdf) + (read-passwd "Enter password for PDF file: "))) + (options `(,(concat "-o" png) + ,(format "-r%d" (round doc-view-resolution)) + ,@(if pdf-passwd `("-p" ,pdf-passwd))))) + (when (eq doc-view-doc-type 'epub) + (when doc-view-epub-font-size + (setq options (append options + (list (format "-S%s" doc-view-epub-font-size))))) + (when doc-view-mutool-user-stylesheet + (setq options + (append options + (list (format "-U%s" + (expand-file-name + doc-view-mutool-user-stylesheet))))))) (doc-view-start-process "pdf->png" doc-view-pdfdraw-program `(,@(doc-view-pdfdraw-program-subcommand) - ,(concat "-o" png) - ,(format "-r%d" (round doc-view-resolution)) - ,@(if pdf-passwd `("-p" ,pdf-passwd)) + ,@options ,pdf ,@(if page `(,(format "%d" page)))) callback))) @@ -1133,7 +1230,8 @@ is named like ODF with the extension turned to pdf." "Convert PDF-PS to PNG asynchronously." (funcall (pcase doc-view-doc-type - ('pdf doc-view-pdf->png-converter-function) + ((or 'pdf 'odf 'epub 'cbz 'fb2 'xps 'oxps) + doc-view-pdf->png-converter-function) ('djvu #'doc-view-djvu->tiff-converter-ddjvu) (_ #'doc-view-ps->png-converter-ghostscript)) pdf-ps png nil @@ -1171,20 +1269,20 @@ Start by converting PAGES, and then the rest." (let ((rest (cdr pages))) (funcall doc-view-single-page-converter-function pdf (format png (car pages)) (car pages) - (lambda () - (if rest - (doc-view-document->bitmap pdf png rest) - ;; Yippie, the important pages are done, update the display. - (clear-image-cache) - ;; For the windows that have a message (like "Welcome to - ;; DocView") display property, clearing the image cache is - ;; not sufficient. - (dolist (win (get-buffer-window-list (current-buffer) nil 'visible)) - (with-selected-window win - (when (stringp (overlay-get (doc-view-current-overlay) 'display)) - (doc-view-goto-page (doc-view-current-page))))) - ;; Convert the rest of the pages. - (doc-view-pdf/ps->png pdf png))))))) + (lambda () + (if rest + (doc-view-document->bitmap pdf png rest) + ;; Yippie, the important pages are done, update the display. + (clear-image-cache) + ;; For the windows that have a message (like "Welcome to + ;; DocView") display property, clearing the image cache is + ;; not sufficient. + (dolist (win (get-buffer-window-list (current-buffer) nil 'visible)) + (with-selected-window win + (when (stringp (overlay-get (doc-view-current-overlay) 'display)) + (doc-view-goto-page (doc-view-current-page))))) + ;; Convert the rest of the pages. + (doc-view-pdf/ps->png pdf png))))))) (defun doc-view-pdf->txt (pdf txt callback) "Convert PDF to TXT asynchronously and call CALLBACK when finished." @@ -1281,7 +1379,9 @@ Those files are saved in the directory given by the function ;; Rename to doc.pdf (rename-file opdf pdf) (doc-view-pdf/ps->png pdf png-file))))) - ((or 'pdf 'djvu) + ;; The doc-view-mode-p check ensures that epub, cbz, fb2 and + ;; (o)xps are handled with mutool + ((or 'pdf 'djvu 'epub 'cbz 'fb2 'xps 'oxps) (let ((pages (doc-view-active-pages))) ;; Convert doc to bitmap images starting with the active pages. (doc-view-document->bitmap doc-view--buffer-file-name png-file pages))) @@ -1376,7 +1476,7 @@ dragging it to its bottom-right corner. See also (defun doc-view-guess-paper-size (iw ih) "Guess the paper size according to the aspect ratio." (cl-labels ((div (x y) - (round (/ (* 100.0 x) y)))) + (round (/ (* 100.0 x) y)))) (let ((ar (div iw ih)) (al (mapcar (lambda (l) (list (div (nth 1 l) (nth 2 l)) (car l))) @@ -1530,18 +1630,19 @@ 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: +\\<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"))))) -`q' : Bury this buffer. Conversion will go on in background. -`k' : Kill the conversion process and this buffer. -`K' : Kill the conversion process.\n")))) - -(declare-function tooltip-show "tooltip" (text &optional use-echo-area)) +(declare-function tooltip-show "tooltip" (text &optional use-echo-area + text-face default-face)) (defun doc-view-show-tooltip () (interactive) @@ -1813,6 +1914,8 @@ If BACKWARD is non-nil, jump to the previous match." ("dvi" dvi) ;; PDF ("pdf" pdf) ("epdf" pdf) + ;; EPUB + ("epub" epub) ;; PostScript ("ps" ps) ("eps" ps) ;; DjVu @@ -1824,7 +1927,13 @@ If BACKWARD is non-nil, jump to the previous match." ;; Microsoft Office formats (also handled by the odf ;; conversion chain). ("doc" odf) ("docx" odf) ("xls" odf) ("xlsx" odf) - ("ppt" odf) ("pps" odf) ("pptx" odf) ("rtf" odf)) + ("ppt" odf) ("pps" odf) ("pptx" odf) ("rtf" odf) + ;; CBZ + ("cbz" cbz) + ;; FB2 + ("fb2" fb2) + ;; (Open)XPS + ("xps" xps) ("oxps" oxps)) t)))) (content-types (save-excursion @@ -1833,7 +1942,12 @@ If BACKWARD is non-nil, jump to the previous match." ((looking-at "%!") '(ps)) ((looking-at "%PDF") '(pdf)) ((looking-at "\367\002") '(dvi)) - ((looking-at "AT&TFORM") '(djvu)))))) + ((looking-at "AT&TFORM") '(djvu)) + ;; The following pattern actually is for recognizing + ;; zip-archives, so that this same association is used for + ;; cbz files. This is fine, as cbz files should be handled + ;; like epub anyway. + ((looking-at "PK") '(epub odf)))))) (setq-local doc-view-doc-type (car (or (nreverse (seq-intersection name-types content-types #'eq)) @@ -2146,6 +2260,8 @@ See the command `doc-view-mode' for more information on this mode." (add-hook 'bookmark-after-jump-hook show-fn-sym) (bookmark-default-handler bmk))) +(put 'doc-view-bookmark-jump 'bookmark-handler-type "Docview") + ;; Obsolete. (defun doc-view-intersection (l1 l2) diff --git a/lisp/ebuff-menu.el b/lisp/ebuff-menu.el index 0c3d4af569d..2b1fc916d9f 100644 --- a/lisp/ebuff-menu.el +++ b/lisp/ebuff-menu.el @@ -48,6 +48,7 @@ (define-key map "\C-m" #'Electric-buffer-menu-select) (define-key map "\C-l" #'recenter) (define-key map "s" #'Buffer-menu-save) + (define-key map "S" #'tabulated-list-sort) (define-key map "d" #'Buffer-menu-delete) (define-key map "k" #'Buffer-menu-delete) (define-key map "\C-d" #'Buffer-menu-delete-backwards) diff --git a/lisp/ecomplete.el b/lisp/ecomplete.el index 260657e0f7a..d5f3fc77560 100644 --- a/lisp/ecomplete.el +++ b/lisp/ecomplete.el @@ -65,10 +65,11 @@ :type 'file) (defcustom ecomplete-database-file-coding-system 'iso-2022-7bit + ;; FIXME: We should transition to `utf-8-emacs-unix' somehow! "Coding system used for writing the ecomplete database file." :type '(symbol :tag "Coding system")) -(defcustom ecomplete-sort-predicate 'ecomplete-decay +(defcustom ecomplete-sort-predicate #'ecomplete-decay "Predicate to use when sorting matched. The predicate is called with two parameters that represent the completion. Each parameter is a list where the first element is @@ -95,13 +96,18 @@ string that was matched." (defun ecomplete-add-item (type key text) "Add item TEXT of TYPE to the database, using KEY as the identifier." + (unless ecomplete-database (ecomplete-setup)) (let ((elems (assq type ecomplete-database)) (now (time-convert nil 'integer)) entry) (unless elems (push (setq elems (list type)) ecomplete-database)) (if (setq entry (assoc key (cdr elems))) - (setcdr entry (list (1+ (cadr entry)) now text)) + (pcase-let ((`(,_key ,count ,_time ,oldtext) entry)) + (setcdr entry (list (1+ count) now + ;; Preserve the "more complete" text. + (if (>= (length text) (length oldtext)) + text oldtext)))) (nconc elems (list (list key 1 now text)))))) (defun ecomplete-get-item (type key) @@ -110,19 +116,23 @@ string that was matched." (defun ecomplete-save () "Write the .ecompleterc file." - (with-temp-buffer - (let ((coding-system-for-write ecomplete-database-file-coding-system)) - (insert "(") - (cl-loop for (type . elems) in ecomplete-database - do - (insert (format "(%s\n" type)) - (dolist (entry elems) - (prin1 entry (current-buffer)) - (insert "\n")) - (insert ")\n")) - (insert ")") - (write-region (point-min) (point-max) - ecomplete-database-file nil 'silent)))) + ;; If the database is empty, it might be because we haven't called + ;; `ecomplete-setup', so better not save at all, lest we lose the real + ;; database! + (when ecomplete-database + (with-temp-buffer + (let ((coding-system-for-write ecomplete-database-file-coding-system)) + (insert "(") + (cl-loop for (type . elems) in ecomplete-database + do + (insert (format "(%s\n" type)) + (dolist (entry elems) + (prin1 entry (current-buffer)) + (insert "\n")) + (insert ")\n")) + (insert ")") + (write-region (point-min) (point-max) + ecomplete-database-file nil 'silent))))) (defun ecomplete-get-matches (type match) (let* ((elems (cdr (assq type ecomplete-database))) diff --git a/lisp/edmacro.el b/lisp/edmacro.el index 11d5541203a..26f3ae02aba 100644 --- a/lisp/edmacro.el +++ b/lisp/edmacro.el @@ -99,8 +99,7 @@ With a prefix argument, format the macro in a more concise way." (when keys (let ((cmd (if (arrayp keys) (key-binding keys) keys)) (cmd-noremap (when (arrayp keys) (key-binding keys nil t))) - (mac nil) (mac-counter nil) (mac-format nil) - kmacro) + (mac nil) (mac-counter nil) (mac-format nil)) (cond (store-hook (setq mac keys) (setq cmd nil)) @@ -131,10 +130,10 @@ With a prefix argument, format the macro in a more concise way." (t (setq mac cmd) (setq cmd nil))) - (when (setq kmacro (kmacro-extract-lambda mac)) - (setq mac (car kmacro) - mac-counter (nth 1 kmacro) - mac-format (nth 2 kmacro))) + (when (kmacro-p mac) + (setq mac (kmacro--keys mac) + mac-counter (kmacro--counter mac) + mac-format (kmacro--format mac))) (unless (arrayp mac) (error "Key sequence %s is not a keyboard macro" (key-description keys))) @@ -252,15 +251,14 @@ or nil, use a compact 80-column format." ((looking-at "Key:\\(.*\\)$") (when edmacro-store-hook (error "\"Key\" line not allowed in this context")) - (let ((key (edmacro-parse-keys - (match-string 1)))) + (let ((key (kbd (match-string 1)))) (unless (equal key "") (if (equal key "none") (setq no-keys t) (push key keys) (let ((b (key-binding key))) (and b (commandp b) (not (arrayp b)) - (not (kmacro-extract-lambda b)) + (not (kmacro-p b)) (or (not (fboundp b)) (not (or (arrayp (symbol-function b)) (get b 'kmacro)))) @@ -313,10 +311,7 @@ or nil, use a compact 80-column format." (when cmd (if (= (length mac) 0) (fmakunbound cmd) - (fset cmd - (if (and mac-counter mac-format) - (kmacro-lambda-form mac mac-counter mac-format) - mac)))) + (fset cmd (kmacro mac mac-counter mac-format)))) (if no-keys (when cmd (cl-loop for key in (where-is-internal cmd '(keymap)) do @@ -327,10 +322,8 @@ or nil, use a compact 80-column format." (cl-loop for key in keys do (global-set-key key (or cmd - (if (and mac-counter mac-format) - (kmacro-lambda-form - mac mac-counter mac-format) - mac)))))))))) + (kmacro mac mac-counter + mac-format)))))))))) (kill-buffer buf) (when (buffer-name obuf) (switch-to-buffer obuf)) @@ -610,6 +603,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) @@ -639,102 +638,11 @@ 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))) +(defun edmacro-parse-keys (string &optional _need-vector) + (let ((result (kbd string))) + (if (stringp result) + (seq-into result 'vector) + result))) (provide 'edmacro) diff --git a/lisp/ehelp.el b/lisp/ehelp.el index 8c1555249ca..0c2f02639fc 100644 --- a/lisp/ehelp.el +++ b/lisp/ehelp.el @@ -76,7 +76,10 @@ (define-key map [?\C-7] 'electric-help-undefined) (define-key map [?\C-8] 'electric-help-undefined) (define-key map [?\C-9] 'electric-help-undefined) - (define-key map (char-to-string help-char) 'electric-help-help) + (define-key map (if (characterp help-char) + (char-to-string help-char) + (vector help-char)) + 'electric-help-help) (define-key map "?" 'electric-help-help) (define-key map " " 'scroll-up) (define-key map [?\S-\ ] 'scroll-down) diff --git a/lisp/elec-pair.el b/lisp/elec-pair.el index 964d21f11c6..231dcdeb980 100644 --- a/lisp/elec-pair.el +++ b/lisp/elec-pair.el @@ -256,7 +256,7 @@ cache is flushed from position START, defaulting to point." (defun electric-pair--syntax-ppss (&optional pos where) "Like `syntax-ppss', but sometimes fallback to `parse-partial-sexp'. -WHERE is a list defaulting to '(string comment) and indicates +WHERE is a list defaulting to \\='(string comment) and indicates when to fallback to `parse-partial-sexp'." (let* ((pos (or pos (point))) (where (or where '(string comment))) @@ -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 57cdff38ed4..0cf3a299cfa 100644 --- a/lisp/electric.el +++ b/lisp/electric.el @@ -512,11 +512,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 @@ -620,7 +620,7 @@ This requotes when a quoting key is typed." (define-minor-mode electric-quote-mode "Toggle on-the-fly requoting (Electric Quote mode). -When enabled, as you type this replaces \\=` with ‘, \\=' with ’, +When enabled, as you type this replaces \\=` with \\=‘, \\=' with \\=’, \\=`\\=` with “, and \\='\\=' with ”. This occurs only in comments, strings, and text paragraphs, and these are selectively controlled with `electric-quote-comment', `electric-quote-string', and diff --git a/lisp/elide-head.el b/lisp/elide-head.el index d2e3ac6a996..90bf1fe35b5 100644 --- a/lisp/elide-head.el +++ b/lisp/elide-head.el @@ -26,12 +26,12 @@ ;; notices) in file headers to avoid clutter when you know what it ;; says. ;; -;; `elide-head-headers-to-hide' controls what is elided by the command -;; `elide-head'. A buffer-local invisible overlay manages the -;; elision. +;; `elide-head-headers-to-hide' controls what is elided by the minor +;; mode `elide-head-mode'. A buffer-local invisible overlay manages +;; the elision. -;; You might add `elide-head' to appropriate major mode hooks or to -;; `find-file-hook'. Please do not do this in site init files. If +;; You might add `elide-head-mode' to appropriate major mode hooks or +;; to `find-file-hook'. Please do not do this in site init files. If ;; you do, information may be hidden from users who don't know it ;; already. @@ -50,24 +50,99 @@ :group 'tools) (defcustom elide-head-headers-to-hide - '(("is free software[:;] you can redistribute it" . ; GNU boilerplate - "\\(Boston, MA 0211\\(1-1307\\|0-1301\\), USA\\|\ -If not, see <https?://www\\.gnu\\.org/licenses/>\\)\\.") - ("The Regents of the University of California\\. All rights reserved\\." . - "SUCH DAMAGE\\.") ; BSD - ("Permission is hereby granted, free of charge" . ; X11 - "authorization from the X Consortium\\.")) + `(;; GNU GPL + ("is free software[:;] you can redistribute it" . + ,(rx (or (seq "If not, see " (? "<") + "http" (? "s") "://www.gnu.org/licenses/" + (? ">") (? " ")) + (seq "Boston, MA " (? " ") + "0211" (or "1-1307" "0-1301") + (or " " ", ") "USA") + "675 Mass Ave, Cambridge, MA 02139, USA") + (? "."))) + ;; FreeBSD license / Modified BSD license (3-clause) + (,(rx (or "The Regents of the University of California. All rights reserved." + "Redistribution and use in source and binary")) + . "POSSIBILITY OF SUCH DAMAGE\\.") + ;; X11 and Expat + ("Permission is hereby granted, free of charge" . + ,(rx (or "authorization from the X Consortium." ; X11 + "THE USE OR OTHER DEALINGS IN THE SOFTWARE.")))) ; Expat "Alist of regexps defining start and end of text to elide. The cars of elements of the list are searched for in order. Text is elided with an invisible overlay from the end of the line where the first match is found to the end of the match for the corresponding -cdr." +cdr. + +This affects `elide-head-mode'." :type '(alist :key-type (regexp :tag "Start regexp") - :value-type (regexp :tag "End regexp"))) + :value-type (regexp :tag "End regexp")) + :version "29.1") (defvar-local elide-head-overlay nil) +(defun elide-head--delete-overlay () + "Delete the overlay in `elide-head-overlay'." + (when (overlayp elide-head-overlay) + (delete-overlay elide-head-overlay))) + +(defun elide-head--hide () + "Hide elided (hidden) headers." + (save-excursion + (save-restriction + (let ((rest elide-head-headers-to-hide) + beg end) + (widen) + (goto-char (point-min)) + (while rest + (save-excursion + (when (re-search-forward (caar rest) nil t) + (setq beg (point)) + (when (re-search-forward (cdar rest) nil t) + (setq end (point-marker) + rest nil)))) + (if rest (setq rest (cdr rest)))) + (if (not (and beg end)) + (if (called-interactively-p 'interactive) + (message "No header found")) + (goto-char beg) + (end-of-line) + (if (overlayp elide-head-overlay) + (move-overlay elide-head-overlay (point-marker) end) + (setq elide-head-overlay (make-overlay (point-marker) end))) + (overlay-put elide-head-overlay 'invisible t) + (overlay-put elide-head-overlay 'evaporate t) + (overlay-put elide-head-overlay 'after-string "...")))))) + +(defun elide-head--show () + "Show elided (hidden) headers." + (if (and (overlayp elide-head-overlay) + (overlay-buffer elide-head-overlay)) + (elide-head--delete-overlay) + (if (called-interactively-p 'interactive) + (message "No header hidden")))) + +;;;###autoload +(define-minor-mode elide-head-mode + "Toggle eliding (hiding) header material in the current buffer. + +When Elide Header mode is enabled, headers are hidden according +to `elide-head-headers-to-hide'. + +This is suitable as an entry on `find-file-hook' or appropriate +mode hooks." + :group 'elide-head + (if elide-head-mode + (progn + (elide-head--hide) + (add-hook 'change-major-mode-hook 'elide-head--delete-overlay nil 'local)) + (elide-head--show) + (remove-hook 'change-major-mode-hook 'elide-head--delete-overlay 'local))) + + +;;; Obsolete + ;;;###autoload (defun elide-head (&optional arg) "Hide header material in buffer according to `elide-head-headers-to-hide'. @@ -76,43 +151,17 @@ The header is made invisible with an overlay. With a prefix arg, show an elided material again. This is suitable as an entry on `find-file-hook' or appropriate mode hooks." + (declare (obsolete elide-head-mode "29.1")) (interactive "P") (if arg - (elide-head-show) - (save-excursion - (save-restriction - (let ((rest elide-head-headers-to-hide) - beg end) - (widen) - (goto-char (point-min)) - (while rest - (save-excursion - (when (re-search-forward (caar rest) nil t) - (setq beg (point)) - (when (re-search-forward (cdar rest) nil t) - (setq end (point-marker) - rest nil)))) - (if rest (setq rest (cdr rest)))) - (if (not (and beg end)) - (if (called-interactively-p 'interactive) - (message "No header found")) - (goto-char beg) - (end-of-line) - (if (overlayp elide-head-overlay) - (move-overlay elide-head-overlay (point-marker) end) - (setq elide-head-overlay (make-overlay (point-marker) end))) - (overlay-put elide-head-overlay 'invisible t) - (overlay-put elide-head-overlay 'evaporate t) - (overlay-put elide-head-overlay 'after-string "..."))))))) + (elide-head-mode -1) + (elide-head-mode 1))) (defun elide-head-show () "Show a header in the current buffer elided by \\[elide-head]." + (declare (obsolete elide-head-mode "29.1")) (interactive) - (if (and (overlayp elide-head-overlay) - (overlay-buffer elide-head-overlay)) - (delete-overlay elide-head-overlay) - (if (called-interactively-p 'interactive) - (message "No header hidden")))) + (elide-head-mode -1)) (provide 'elide-head) diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 8e43ae68072..86a42b208e7 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -1814,8 +1814,7 @@ Redefining advices affect the construction of an advised definition." (if (symbolp function) (setq function (if (fboundp function) (advice--strip-macro (symbol-function function))))) - (while (advice--p function) (setq function (advice--cdr function))) - function) + (advice--cd*r function)) (defun ad-clear-advicefunname-definition (function) (let ((advicefunname (ad-get-advice-info-field function 'advicefunname))) diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index 756cac6d0b7..d324a7fc70c 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -28,11 +28,15 @@ ;; Lisp source files in various useful ways. To learn more, read the ;; source; if you're going to use this, you'd better be able to. +;; The functions in this file have been largely superseded by +;; loaddefs-gen.el. + ;;; Code: (require 'lisp-mode) ;for `doc-string-elt' properties. (require 'lisp-mnt) -(eval-when-compile (require 'cl-lib)) +(require 'cl-lib) +(require 'loaddefs-gen) (defvar generated-autoload-file nil "File into which to write autoload definitions. @@ -112,165 +116,7 @@ then we use the timestamp of the output file instead. As a result: (defvar autoload-modified-buffers) ;Dynamically scoped var. -(defun make-autoload (form file &optional expansion) - "Turn FORM into an autoload or defvar for source file FILE. -Returns nil if FORM is not a special autoload form (i.e. a function definition -or macro definition or a defcustom). -If EXPANSION is non-nil, we're processing the macro expansion of an -expression, in which case we want to handle forms differently." - (let ((car (car-safe form)) expand) - (cond - ((and expansion (eq car 'defalias)) - (pcase-let* - ((`(,_ ,_ ,arg . ,rest) form) - ;; `type' is non-nil if it defines a macro. - ;; `fun' is the function part of `arg' (defaults to `arg'). - ((or (and (or `(cons 'macro ,fun) `'(macro . ,fun)) (let type t)) - (and (let fun arg) (let type nil))) - arg) - ;; `lam' is the lambda expression in `fun' (or nil if not - ;; recognized). - (lam (if (memq (car-safe fun) '(quote function)) (cadr fun))) - ;; `args' is the list of arguments (or t if not recognized). - ;; `body' is the body of `lam' (or t if not recognized). - ((or `(lambda ,args . ,body) - (and (let args t) (let body t))) - lam) - ;; Get the `doc' from `body' or `rest'. - (doc (cond ((stringp (car-safe body)) (car body)) - ((stringp (car-safe rest)) (car rest)))) - ;; Look for an interactive spec. - (interactive (pcase body - ((or `((interactive . ,iargs) . ,_) - `(,_ (interactive . ,iargs) . ,_)) - ;; List of modes or just t. - (if (nthcdr 1 iargs) - (list 'quote (nthcdr 1 iargs)) - t))))) - ;; Add the usage form at the end where describe-function-1 - ;; can recover it. - (when (consp args) (setq doc (help-add-fundoc-usage doc args))) - ;; (message "autoload of %S" (nth 1 form)) - `(autoload ,(nth 1 form) ,file ,doc ,interactive ,type))) - - ((and expansion (memq car '(progn prog1))) - (let ((end (memq :autoload-end form))) - (when end ;Cut-off anything after the :autoload-end marker. - (setq form (copy-sequence form)) - (setcdr (memq :autoload-end form) nil)) - (let ((exps (delq nil (mapcar (lambda (form) - (make-autoload form file expansion)) - (cdr form))))) - (when exps (cons 'progn exps))))) - - ;; For complex cases, try again on the macro-expansion. - ((and (memq car '(easy-mmode-define-global-mode define-global-minor-mode - define-globalized-minor-mode defun defmacro - easy-mmode-define-minor-mode define-minor-mode - define-inline cl-defun cl-defmacro cl-defgeneric - cl-defstruct pcase-defmacro)) - (macrop car) - (setq expand (let ((load-true-file-name file) - (load-file-name file)) - (macroexpand form))) - (memq (car expand) '(progn prog1 defalias))) - (make-autoload expand file 'expansion)) ;Recurse on the expansion. - - ;; For special function-like operators, use the `autoload' function. - ((memq car '(define-skeleton define-derived-mode - define-compilation-mode define-generic-mode - easy-mmode-define-global-mode define-global-minor-mode - define-globalized-minor-mode - easy-mmode-define-minor-mode define-minor-mode - cl-defun defun* cl-defmacro defmacro* - define-overloadable-function)) - (let* ((macrop (memq car '(defmacro cl-defmacro defmacro*))) - (name (nth 1 form)) - (args (pcase car - ((or 'defun 'defmacro - 'defun* 'defmacro* 'cl-defun 'cl-defmacro - 'define-overloadable-function) - (nth 2 form)) - ('define-skeleton '(&optional str arg)) - ((or 'define-generic-mode 'define-derived-mode - 'define-compilation-mode) - nil) - (_ t))) - (body (nthcdr (or (function-get car 'doc-string-elt) 3) form)) - (doc (if (stringp (car body)) (pop body)))) - ;; Add the usage form at the end where describe-function-1 - ;; can recover it. - (when (listp args) (setq doc (help-add-fundoc-usage doc args))) - ;; `define-generic-mode' quotes the name, so take care of that - `(autoload ,(if (listp name) name (list 'quote name)) - ,file ,doc - ,(or (and (memq car '(define-skeleton define-derived-mode - define-generic-mode - easy-mmode-define-global-mode - define-global-minor-mode - define-globalized-minor-mode - easy-mmode-define-minor-mode - define-minor-mode)) - t) - (and (eq (car-safe (car body)) 'interactive) - ;; List of modes or just t. - (or (if (nthcdr 1 (car body)) - (list 'quote (nthcdr 1 (car body))) - t)))) - ,(if macrop ''macro nil)))) - - ;; For defclass forms, use `eieio-defclass-autoload'. - ((eq car 'defclass) - (let ((name (nth 1 form)) - (superclasses (nth 2 form)) - (doc (nth 4 form))) - (list 'eieio-defclass-autoload (list 'quote name) - (list 'quote superclasses) file doc))) - - ;; Convert defcustom to less space-consuming data. - ((eq car 'defcustom) - (let* ((varname (car-safe (cdr-safe form))) - (props (nthcdr 4 form)) - (initializer (plist-get props :initialize)) - (init (car-safe (cdr-safe (cdr-safe form)))) - (doc (car-safe (cdr-safe (cdr-safe (cdr-safe form))))) - ;; (rest (cdr-safe (cdr-safe (cdr-safe (cdr-safe form))))) - ) - `(progn - ,(if (not (member initializer '(nil 'custom-initialize-default - #'custom-initialize-default - 'custom-initialize-reset - #'custom-initialize-reset))) - form - `(defvar ,varname ,init ,doc)) - ;; When we include the complete `form', this `custom-autoload' - ;; is not indispensable, but it still helps in case the `defcustom' - ;; doesn't specify its group explicitly, and probably in a few other - ;; corner cases. - (custom-autoload ',varname ,file - ,(condition-case nil - (null (plist-get props :set)) - (error nil))) - ;; Propagate the :safe property to the loaddefs file. - ,@(when-let ((safe (plist-get props :safe))) - `((put ',varname 'safe-local-variable ,safe)))))) - - ((eq car 'defgroup) - ;; In Emacs this is normally handled separately by cus-dep.el, but for - ;; third party packages, it can be convenient to explicitly autoload - ;; a group. - (let ((groupname (nth 1 form))) - `(let ((loads (get ',groupname 'custom-loads))) - (if (member ',file loads) nil - (put ',groupname 'custom-loads (cons ',file loads)))))) - - ;; When processing a macro expansion, any expression - ;; before a :autoload-end should be included. These are typically (put - ;; 'fun 'prop val) and things like that. - ((and expansion (consp form)) form) - - ;; nil here indicates that this is not a special autoload form. - (t nil)))) +(defalias 'make-autoload #'loaddefs-generate--make-autoload) ;; Forms which have doc-strings which should be printed specially. ;; A doc-string-elt property of ELT says that (nth ELT FORM) is @@ -340,7 +186,7 @@ put the output in." (t (let ((doc-string-elt (function-get (car-safe form) 'doc-string-elt)) (outbuf autoload-print-form-outbuf)) - (if (and doc-string-elt (stringp (nth doc-string-elt form))) + (if (and (numberp doc-string-elt) (stringp (nth doc-string-elt form))) ;; We need to hack the printing because the ;; doc-string must be printed specially for ;; make-docfile (sigh). @@ -379,39 +225,7 @@ put the output in." (print-escape-nonascii t)) (print form outbuf))))))) -(defun autoload-rubric (file &optional type feature) - "Return a string giving the appropriate autoload rubric for FILE. -TYPE (default \"autoloads\") is a string stating the type of -information contained in FILE. TYPE \"package\" acts like the default, -but adds an extra line to the output to modify `load-path'. - -If FEATURE is non-nil, FILE will provide a feature. FEATURE may -be a string naming the feature, otherwise it will be based on -FILE's name." - (let ((basename (file-name-nondirectory file)) - (lp (if (equal type "package") (setq type "autoloads")))) - (concat ";;; " basename - " --- automatically extracted " (or type "autoloads") - " -*- lexical-binding: t -*-\n" - ";;\n" - ";;; Code:\n\n" - (if lp - "(add-to-list 'load-path (directory-file-name - (or (file-name-directory #$) (car load-path))))\n\n") - "\n" - ;; This is used outside of autoload.el, eg cus-dep, finder. - (if feature - (format "(provide '%s)\n" - (if (stringp feature) feature - (file-name-sans-extension basename)))) - ";; Local Variables:\n" - ";; version-control: never\n" - ";; no-byte-compile: t\n" ;; #$ is byte-compiled into nil. - ";; no-update-autoloads: t\n" - ";; coding: utf-8\n" - ";; End:\n" - ";;; " basename - " ends here\n"))) +(defalias 'autoload-rubric #'loaddefs-generate--rubric) (defvar autoload-ensure-writable nil "Non-nil means `autoload-find-generated-file' makes existing file writable.") @@ -478,35 +292,13 @@ if `autoload-timestamps' is non-nil, otherwise a fixed fake time is inserted)." (hack-local-variables)) (current-buffer))) +(defalias 'autoload-insert-section-header + #'loaddefs-generate--insert-section-header) + (defvar no-update-autoloads nil "File local variable to prevent scanning this file for autoload cookies.") -(defun autoload-file-load-name (file outfile) - "Compute the name that will be used to load FILE. -OUTFILE should be the name of the global loaddefs.el file, which -is expected to be at the root directory of the files we are -scanning for autoloads and will be in the `load-path'." - (let* ((name (file-relative-name file (file-name-directory outfile))) - (names '()) - (dir (file-name-directory outfile))) - ;; If `name' has directory components, only keep the - ;; last few that are really needed. - (while name - (setq name (directory-file-name name)) - (push (file-name-nondirectory name) names) - (setq name (file-name-directory name))) - (while (not name) - (cond - ((null (cdr names)) (setq name (car names))) - ((file-exists-p (expand-file-name "subdirs.el" dir)) - ;; FIXME: here we only check the existence of subdirs.el, - ;; without checking its content. This makes it generate wrong load - ;; names for cases like lisp/term which is not added to load-path. - (setq dir (expand-file-name (pop names) dir))) - (t (setq name (mapconcat #'identity names "/"))))) - (if (string-match "\\.elc?\\(\\.\\|\\'\\)" name) - (substring name 0 (match-beginning 0)) - name))) +(defalias 'autoload-file-load-name #'loaddefs-generate--file-load-name) (defun generate-file-autoloads (file) "Insert at point a loaddefs autoload section for FILE. @@ -520,13 +312,6 @@ Return non-nil in the case where no autoloads were added at point." (autoload-generate-file-autoloads file (current-buffer) buffer-file-name) autoload-modified-buffers)) -(defvar autoload-compute-prefixes t - "If non-nil, autoload will add code to register the prefixes used in a file. -Standard prefixes won't be registered anyway. I.e. if a file \"foo.el\" defines -variables or functions that use \"foo-\" as prefix, that will not be registered. -But all other prefixes will be included.") -(put 'autoload-compute-prefixes 'safe #'booleanp) - (defconst autoload-def-prefixes-max-entries 5 "Target length of the list of definition prefixes per file. If set too small, the prefixes will be too generic (i.e. they'll use little @@ -538,102 +323,7 @@ cost more memory use).") "Target size of definition prefixes. Don't try to split prefixes that are already longer than that.") -(require 'radix-tree) - -(defun autoload--make-defs-autoload (defs file) - - ;; Remove the defs that obey the rule that file foo.el (or - ;; foo-mode.el) uses "foo-" as prefix. - ;; FIXME: help--symbol-completion-table still doesn't know how to use - ;; the rule that file foo.el (or foo-mode.el) uses "foo-" as prefix. - ;;(let ((prefix - ;; (concat (substring file 0 (string-match "-mode\\'" file)) "-"))) - ;; (dolist (def (prog1 defs (setq defs nil))) - ;; (unless (string-prefix-p prefix def) - ;; (push def defs)))) - - ;; Then compute a small set of prefixes that cover all the - ;; remaining definitions. - (let* ((tree (let ((tree radix-tree-empty)) - (dolist (def defs) - (setq tree (radix-tree-insert tree def t))) - tree)) - (prefixes nil)) - ;; Get the root prefixes, that we should include in any case. - (radix-tree-iter-subtrees - tree (lambda (prefix subtree) - (push (cons prefix subtree) prefixes))) - ;; In some cases, the root prefixes are too short, e.g. if you define - ;; "cc-helper" and "c-mode", you'll get "c" in the root prefixes. - (dolist (pair (prog1 prefixes (setq prefixes nil))) - (let ((s (car pair))) - (if (or (and (> (length s) 2) ; Long enough! - ;; But don't use "def" from deffoo-pkg-thing. - (not (string= "def" s))) - (string-match ".[[:punct:]]\\'" s) ;A real (tho short) prefix? - (radix-tree-lookup (cdr pair) "")) ;Nothing to expand! - (push pair prefixes) ;Keep it as is. - (radix-tree-iter-subtrees - (cdr pair) (lambda (prefix subtree) - (push (cons (concat s prefix) subtree) prefixes)))))) - ;; FIXME: The expansions done below are mostly pointless, such as - ;; for `yenc', where we replace "yenc-" with an exhaustive list (5 - ;; elements). - ;; (while - ;; (let ((newprefixes nil) - ;; (changes nil)) - ;; (dolist (pair prefixes) - ;; (let ((prefix (car pair))) - ;; (if (or (> (length prefix) autoload-def-prefixes-max-length) - ;; (radix-tree-lookup (cdr pair) "")) - ;; ;; No point splitting it any further. - ;; (push pair newprefixes) - ;; (setq changes t) - ;; (radix-tree-iter-subtrees - ;; (cdr pair) (lambda (sprefix subtree) - ;; (push (cons (concat prefix sprefix) subtree) - ;; newprefixes)))))) - ;; (and changes - ;; (<= (length newprefixes) - ;; autoload-def-prefixes-max-entries) - ;; (let ((new nil) - ;; (old nil)) - ;; (dolist (pair prefixes) - ;; (unless (memq pair newprefixes) ;Not old - ;; (push pair old))) - ;; (dolist (pair newprefixes) - ;; (unless (memq pair prefixes) ;Not new - ;; (push pair new))) - ;; (cl-assert new) - ;; (message "Expanding %S to %S" - ;; (mapcar #'car old) (mapcar #'car new)) - ;; t) - ;; (setq prefixes newprefixes) - ;; (< (length prefixes) autoload-def-prefixes-max-entries)))) - - ;; (message "Final prefixes %s : %S" file (mapcar #'car prefixes)) - (when prefixes - (let ((strings - (mapcar - (lambda (x) - (let ((prefix (car x))) - (if (or (> (length prefix) 2) ;Long enough! - (and (eq (length prefix) 2) - (string-match "[[:punct:]]" prefix))) - prefix - ;; Some packages really don't follow the rules. - ;; Drop the most egregious cases such as the - ;; one-letter prefixes. - (let ((dropped ())) - (radix-tree-iter-mappings - (cdr x) (lambda (s _) - (push (concat prefix s) dropped))) - (message "%s:0: Warning: Not registering prefix \"%s\". Affects: %S" - file prefix dropped) - nil)))) - prefixes))) - `(register-definition-prefixes ,file ',(sort (delq nil strings) - 'string<)))))) +(defalias 'autoload--make-defs-autoload #'loaddefs-generate--make-prefixes) (defun autoload--setup-output (otherbuf outbuf absfile load-name output-file) (let ((outbuf @@ -685,21 +375,6 @@ Don't try to split prefixes that are already longer than that.") (defvar autoload-builtin-package-versions nil) -(defvar autoload-ignored-definitions - '("define-obsolete-function-alias" - "define-obsolete-variable-alias" - "define-category" "define-key" - "defgroup" "defface" "defadvice" - "def-edebug-spec" - ;; Hmm... this is getting ugly: - "define-widget" - "define-erc-module" - "define-erc-response-handler" - "defun-rcirc-command") - "List of strings naming definitions to ignore for prefixes. -More specifically those definitions will not be considered for the -`register-definition-prefixes' call.") - (defun autoload-generate-file-autoloads (file &optional outbuf outfile) "Insert an autoload section for FILE in the appropriate buffer. Autoloads are generated for defuns and defmacros in FILE @@ -1106,6 +781,9 @@ directory or directories specified." ;; Files with no autoload cookies or whose autoloads go to other ;; files because of file-local autoload-generated-file settings. (no-autoloads nil) + ;; Ensure that we don't do odd things when putting the doc + ;; strings into the autoloads file. + (left-margin 0) (autoload-modified-buffers nil) (output-time (and (file-exists-p output-file) @@ -1194,9 +872,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 7b320cd9e02..3231877a30c 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/benchmark.el b/lisp/emacs-lisp/benchmark.el index c5f621c6c86..882b1d68c48 100644 --- a/lisp/emacs-lisp/benchmark.el +++ b/lisp/emacs-lisp/benchmark.el @@ -121,7 +121,11 @@ result. The overhead of the `lambda's is accounted for." (unless (or (natnump repetitions) (and repetitions (symbolp repetitions))) (setq forms (cons repetitions forms) repetitions 1)) - `(benchmark-call (byte-compile '(lambda () ,@forms)) ,repetitions)) + `(benchmark-call (,(if (native-comp-available-p) + 'native-compile + 'byte-compile) + '(lambda () ,@forms)) + ,repetitions)) ;;;###autoload (defun benchmark (repetitions form) diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el index c6d64975eca..0725b677cff 100644 --- a/lisp/emacs-lisp/bindat.el +++ b/lisp/emacs-lisp/bindat.el @@ -165,12 +165,12 @@ (if (stringp s) s (apply #'unibyte-string s)))) -(defun bindat--unpack-strz (len) +(defun bindat--unpack-strz (&optional len) (let ((i 0) s) (while (and (if len (< i len) t) (/= (aref bindat-raw (+ bindat-idx i)) 0)) (setq i (1+ i))) (setq s (substring bindat-raw bindat-idx (+ bindat-idx i))) - (setq bindat-idx (+ bindat-idx len)) + (setq bindat-idx (+ bindat-idx (or len (1+ i)))) (if (stringp s) s (apply #'unibyte-string s)))) @@ -688,12 +688,12 @@ is the name of a variable that will hold the value we need to pack.") ('unpack `(bindat--unpack-strz ,len)) (`(length ,val) `(cl-incf bindat-idx ,(cond - ((null len) `(length ,val)) + ((null len) `(1+ (length ,val))) ((numberp len) len) - (t `(or ,len (length ,val)))))) + (t `(or ,len (1+ (length ,val))))))) (`(pack . ,args) (macroexp-let2 nil len len - `(if ,len + `(if (numberp ,len) ;; Same as non-zero terminated strings since we don't actually add ;; the terminating zero anyway (because we rely on the fact that ;; `bindat-raw' was presumably initialized with all-zeroes before diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 5f83a217061..69795f9c112 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -34,128 +34,13 @@ ;; still not going to make it go faster than 70 mph, but it might be easier ;; to get it there. ;; - ;; TO DO: ;; -;; (apply (lambda (x &rest y) ...) 1 (foo)) -;; -;; maintain a list of functions known not to access any global variables -;; (actually, give them a 'dynamically-safe property) and then -;; (let ( v1 v2 ... vM vN ) <...dynamically-safe...> ) ==> -;; (let ( v1 v2 ... vM ) vN <...dynamically-safe...> ) -;; by recursing on this, we might be able to eliminate the entire let. -;; However certain variables should never have their bindings optimized -;; away, because they affect everything. -;; (put 'debug-on-error 'binding-is-magic t) -;; (put 'debug-on-abort 'binding-is-magic t) -;; (put 'debug-on-next-call 'binding-is-magic t) -;; (put 'inhibit-quit 'binding-is-magic t) -;; (put 'quit-flag 'binding-is-magic t) -;; (put 't 'binding-is-magic t) -;; (put 'nil 'binding-is-magic t) -;; possibly also -;; (put 'gc-cons-threshold 'binding-is-magic t) -;; (put 'track-mouse 'binding-is-magic t) -;; others? -;; -;; Simple defsubsts often produce forms like -;; (let ((v1 (f1)) (v2 (f2)) ...) -;; (FN v1 v2 ...)) -;; It would be nice if we could optimize this to -;; (FN (f1) (f2) ...) -;; but we can't unless FN is dynamically-safe (it might be dynamically -;; referring to the bindings that the lambda arglist established.) -;; One of the uncountable lossages introduced by dynamic scope... -;; -;; Maybe there should be a control-structure that says "turn on -;; fast-and-loose type-assumptive optimizations here." Then when -;; we see a form like (car foo) we can from then on assume that -;; the variable foo is of type cons, and optimize based on that. -;; But, this won't win much because of (you guessed it) dynamic -;; scope. Anything down the stack could change the value. -;; (Another reason it doesn't work is that it is perfectly valid -;; to call car with a null argument.) A better approach might -;; be to allow type-specification of the form -;; (put 'foo 'arg-types '(float (list integer) dynamic)) -;; (put 'foo 'result-type 'bool) -;; It should be possible to have these types checked to a certain -;; degree. -;; -;; collapse common subexpressions -;; -;; It would be nice if redundant sequences could be factored out as well, -;; when they are known to have no side-effects: -;; (list (+ a b c) (+ a b c)) --> a b add c add dup list-2 -;; but beware of traps like -;; (cons (list x y) (list x y)) -;; -;; Tail-recursion elimination is not really possible in Emacs Lisp. -;; Tail-recursion elimination is almost always impossible when all variables -;; have dynamic scope, but given that the "return" byteop requires the -;; binding stack to be empty (rather than emptying it itself), there can be -;; no truly tail-recursive Emacs Lisp functions that take any arguments or -;; make any bindings. -;; -;; Here is an example of an Emacs Lisp function which could safely be -;; byte-compiled tail-recursively: -;; -;; (defun tail-map (fn list) -;; (cond (list -;; (funcall fn (car list)) -;; (tail-map fn (cdr list))))) -;; -;; However, if there was even a single let-binding around the COND, -;; it could not be byte-compiled, because there would be an "unbind" -;; byte-op between the final "call" and "return." Adding a -;; Bunbind_all byteop would fix this. -;; -;; (defun foo (x y z) ... (foo a b c)) -;; ... (const foo) (varref a) (varref b) (varref c) (call 3) END: (return) -;; ... (varref a) (varbind x) (varref b) (varbind y) (varref c) (varbind z) (goto 0) END: (unbind-all) (return) -;; ... (varref a) (varset x) (varref b) (varset y) (varref c) (varset z) (goto 0) END: (return) -;; -;; this also can be considered tail recursion: -;; -;; ... (const foo) (varref a) (call 1) (goto X) ... X: (return) -;; could generalize this by doing the optimization -;; (goto X) ... X: (return) --> (return) -;; -;; But this doesn't solve all of the problems: although by doing tail- -;; recursion elimination in this way, the call-stack does not grow, the -;; binding-stack would grow with each recursive step, and would eventually -;; overflow. I don't believe there is any way around this without lexical -;; scope. -;; -;; Wouldn't it be nice if Emacs Lisp had lexical scope. -;; -;; Idea: the form (lexical-scope) in a file means that the file may be -;; compiled lexically. This proclamation is file-local. Then, within -;; that file, "let" would establish lexical bindings, and "let-dynamic" -;; would do things the old way. (Or we could use CL "declare" forms.) -;; We'd have to notice defvars and defconsts, since those variables should -;; always be dynamic, and attempting to do a lexical binding of them -;; should simply do a dynamic binding instead. -;; But! We need to know about variables that were not necessarily defvared -;; in the file being compiled (doing a boundp check isn't good enough.) -;; Fdefvar() would have to be modified to add something to the plist. -;; -;; A major disadvantage of this scheme is that the interpreter and compiler -;; would have different semantics for files compiled with (dynamic-scope). -;; Since this would be a file-local optimization, there would be no way to -;; modify the interpreter to obey this (unless the loader was hacked -;; in some grody way, but that's a really bad idea.) - -;; Other things to consider: - -;; ;; Associative math should recognize subcalls to identical function: -;; (disassemble (lambda (x) (+ (+ (foo) 1) (+ (bar) 2)))) -;; ;; This should generate the same as (1+ x) and (1- x) - -;; (disassemble (lambda (x) (cons (+ x 1) (- x 1)))) ;; ;; An awful lot of functions always return a non-nil value. If they're ;; ;; error free also they may act as true-constants. - +;; ;; (disassemble (lambda (x) (and (point) (foo)))) + ;; ;; When ;; ;; - all but one arguments to a function are constant ;; ;; - the non-constant argument is an if-expression (cond-expression?) @@ -188,10 +73,6 @@ (eval-when-compile (require 'subr-x)) (defun byte-compile-log-lap-1 (format &rest args) - ;; Newer byte codes for stack-ref make the slot 0 non-nil again. - ;; But the "old disassembler" is *really* ancient by now. - ;; (if (aref byte-code-vector 0) - ;; (error "The old version of the disassembler is loaded. Reload new-bytecomp as well")) (byte-compile-log-1 (apply #'format-message format (let (c a) @@ -264,8 +145,9 @@ Earlier variables shadow later ones with the same name.") (cdr (assq name byte-compile-function-environment))))) (pcase fn ('nil - (byte-compile-warn "attempt to inline `%s' before it was defined" - name) + (byte-compile-warn-x name + "attempt to inline `%s' before it was defined" + name) form) (`(autoload . ,_) (error "File `%s' didn't define `%s'" (nth 1 fn) name)) @@ -342,8 +224,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) @@ -417,8 +303,8 @@ for speeding up processing.") (t form))) (`(quote . ,v) (if (or (not v) (cdr v)) - (byte-compile-warn "malformed quote form: `%s'" - (prin1-to-string form))) + (byte-compile-warn-x form "malformed quote form: `%s'" + form)) ;; Map (quote nil) to nil to simplify optimizer logic. ;; Map quoted constants to nil if for-effect (just because). (and (car v) @@ -436,8 +322,9 @@ for speeding up processing.") (cons (byte-optimize-form (car clause) nil) (byte-optimize-body (cdr clause) for-effect)) - (byte-compile-warn "malformed cond form: `%s'" - (prin1-to-string clause)) + (byte-compile-warn-x + clause "malformed cond form: `%s'" + clause) clause)) clauses))) (`(progn . ,exps) @@ -451,7 +338,7 @@ for speeding up processing.") (let ((exps-opt (byte-optimize-body exps t))) (if (macroexp-const-p exp-opt) `(progn ,@exps-opt ,exp-opt) - `(prog1 ,exp-opt ,@exps-opt))) + `(,fn ,exp-opt ,@exps-opt))) exp-opt))) (`(,(or `save-excursion `save-restriction `save-current-buffer) . ,exps) @@ -471,7 +358,7 @@ for speeding up processing.") (then-opt (and test-opt (byte-optimize-form then for-effect))) (else-opt (and (not (and test-opt const)) (byte-optimize-body else for-effect)))) - `(if ,test-opt ,then-opt . ,else-opt))) + `(,fn ,test-opt ,then-opt . ,else-opt))) (`(,(or 'and 'or) . ,exps) ;; FIXME: We have to traverse the expressions in left-to-right @@ -510,11 +397,10 @@ for speeding up processing.") ;; as mutated variables have been marked as non-substitutable. (condition (byte-optimize-form (car condition-body) nil)) (body (byte-optimize-body (cdr condition-body) t))) - `(while ,condition . ,body))) + `(,fn ,condition . ,body))) (`(interactive . ,_) - (byte-compile-warn "misplaced interactive spec: `%s'" - (prin1-to-string form)) + (byte-compile-warn-x form "misplaced interactive spec: `%s'" form) nil) (`(function . ,_) @@ -523,7 +409,7 @@ for speeding up processing.") form) (`(condition-case ,var ,exp . ,clauses) - `(condition-case ,var ;Not evaluated. + `(,fn ,var ;Not evaluated. ,(byte-optimize-form exp for-effect) ,@(mapcar (lambda (clause) (let ((byte-optimize--lexvars @@ -546,14 +432,14 @@ for speeding up processing.") (let ((bodyform (byte-optimize-form exp for-effect))) (pcase exps (`(:fun-body ,f) - `(unwind-protect ,bodyform + `(,fn ,bodyform :fun-body ,(byte-optimize-form f nil))) (_ - `(unwind-protect ,bodyform + `(,fn ,bodyform . ,(byte-optimize-body exps t)))))) (`(catch ,tag . ,exps) - `(catch ,(byte-optimize-form tag nil) + `(,fn ,(byte-optimize-form tag nil) . ,(byte-optimize-body exps for-effect))) ;; Needed as long as we run byte-optimize-form after cconv. @@ -582,7 +468,7 @@ for speeding up processing.") (while args (unless (and (consp args) (symbolp (car args)) (consp (cdr args))) - (byte-compile-warn "malformed setq form: %S" form)) + (byte-compile-warn-x form "malformed setq form: %S" form)) (let* ((var (car args)) (expr (cadr args)) (lexvar (assq var byte-optimize--lexvars)) @@ -609,14 +495,13 @@ for speeding up processing.") (cons (byte-optimize-form (car rest) nil) (cdr rest))))) (push name byte-optimize--dynamic-vars) - `(defvar ,name . ,optimized-rest))) + `(,fn ,name . ,optimized-rest))) (`(,(pred byte-code-function-p) . ,exps) (cons fn (mapcar #'byte-optimize-form exps))) (`(,(pred (not symbolp)) . ,_) - (byte-compile-warn "`%s' is a malformed function" - (prin1-to-string fn)) + (byte-compile-warn-x fn "`%s' is a malformed function" fn) form) ((guard (when for-effect @@ -624,8 +509,10 @@ for speeding up processing.") (or byte-compile-delete-errors (eq tmp 'error-free) (progn - (byte-compile-warn "value returned from %s is unused" - (prin1-to-string form)) + (byte-compile-warn-x + form + "value returned from %s is unused" + form) nil))))) (byte-compile-log " %s called for effect; deleted" fn) ;; appending a nil here might not be necessary, but it can't hurt. @@ -674,49 +561,50 @@ for speeding up processing.") (defun byte-optimize--rename-var (var new-var form) "Replace VAR with NEW-VAR in FORM." - (pcase form - ((pred symbolp) (if (eq form var) new-var form)) - (`(setq . ,args) - (let ((new-args nil)) - (while args - (push (byte-optimize--rename-var var new-var (car args)) new-args) - (push (byte-optimize--rename-var var new-var (cadr args)) new-args) - (setq args (cddr args))) - `(setq . ,(nreverse new-args)))) - ;; In binding constructs like `let', `let*' and `condition-case' we - ;; rename everything for simplicity, even new bindings named VAR. - (`(,(and head (or 'let 'let*)) ,bindings . ,body) - `(,head - ,(mapcar (lambda (b) (byte-optimize--rename-var-body var new-var b)) - bindings) - ,@(byte-optimize--rename-var-body var new-var body))) - (`(condition-case ,res-var ,protected-form . ,handlers) - `(condition-case ,(byte-optimize--rename-var var new-var res-var) - ,(byte-optimize--rename-var var new-var protected-form) - ,@(mapcar (lambda (h) - (cons (car h) - (byte-optimize--rename-var-body var new-var (cdr h)))) - handlers))) - (`(internal-make-closure ,vars ,env . ,rest) - `(internal-make-closure - ,vars ,(byte-optimize--rename-var-body var new-var env) . ,rest)) - (`(defvar ,name . ,rest) - ;; NAME is not renamed here; we only care about lexical variables. - `(defvar ,name . ,(byte-optimize--rename-var-body var new-var rest))) - - (`(cond . ,clauses) - `(cond ,@(mapcar (lambda (c) - (byte-optimize--rename-var-body var new-var c)) - clauses))) - - (`(function . ,_) form) - (`(quote . ,_) form) - (`(lambda . ,_) form) - - ;; Function calls and special forms not handled above. - (`(,head . ,args) - `(,head . ,(byte-optimize--rename-var-body var new-var args))) - (_ form))) + (let ((fn (car-safe form))) + (pcase form + ((pred symbolp) (if (eq form var) new-var form)) + (`(setq . ,args) + (let ((new-args nil)) + (while args + (push (byte-optimize--rename-var var new-var (car args)) new-args) + (push (byte-optimize--rename-var var new-var (cadr args)) new-args) + (setq args (cddr args))) + `(,fn . ,(nreverse new-args)))) + ;; In binding constructs like `let', `let*' and `condition-case' we + ;; rename everything for simplicity, even new bindings named VAR. + (`(,(and head (or 'let 'let*)) ,bindings . ,body) + `(,head + ,(mapcar (lambda (b) (byte-optimize--rename-var-body var new-var b)) + bindings) + ,@(byte-optimize--rename-var-body var new-var body))) + (`(condition-case ,res-var ,protected-form . ,handlers) + `(,fn ,(byte-optimize--rename-var var new-var res-var) + ,(byte-optimize--rename-var var new-var protected-form) + ,@(mapcar (lambda (h) + (cons (car h) + (byte-optimize--rename-var-body var new-var (cdr h)))) + handlers))) + (`(internal-make-closure ,vars ,env . ,rest) + `(,fn + ,vars ,(byte-optimize--rename-var-body var new-var env) . ,rest)) + (`(defvar ,name . ,rest) + ;; NAME is not renamed here; we only care about lexical variables. + `(,fn ,name . ,(byte-optimize--rename-var-body var new-var rest))) + + (`(cond . ,clauses) + `(,fn ,@(mapcar (lambda (c) + (byte-optimize--rename-var-body var new-var c)) + clauses))) + + (`(function . ,_) form) + (`(quote . ,_) form) + (`(lambda . ,_) form) + + ;; Function calls and special forms not handled above. + (`(,head . ,args) + `(,head . ,(byte-optimize--rename-var-body var new-var args))) + (_ form)))) (defun byte-optimize-let-form (head form for-effect) ;; Recursively enter the optimizer for the bindings and body @@ -821,7 +709,8 @@ for speeding up processing.") (if (symbolp binding) binding (when (or (atom binding) (cddr binding)) - (byte-compile-warn "malformed let binding: `%S'" binding)) + (byte-compile-warn-x + binding "malformed let binding: `%S'" binding)) (list (car binding) (byte-optimize-form (nth 1 binding) nil)))) (car form)) @@ -1161,6 +1050,14 @@ See Info node `(elisp) Integer Basics'." form ; No improvement. (cons 'concat (nreverse newargs))))) +(defun byte-optimize-string-greaterp (form) + ;; Rewrite in terms of `string-lessp' which has its own bytecode. + (pcase (cdr form) + (`(,a ,b) (let ((arg1 (make-symbol "arg1"))) + `(let ((,arg1 ,a)) + (string-lessp ,b ,arg1)))) + (_ form))) + (put 'identity 'byte-optimizer #'byte-optimize-identity) (put 'memq 'byte-optimizer #'byte-optimize-memq) (put 'memql 'byte-optimizer #'byte-optimize-member) @@ -1184,6 +1081,9 @@ See Info node `(elisp) Integer Basics'." (put 'string= 'byte-optimizer #'byte-optimize-binary-predicate) (put 'string-equal 'byte-optimizer #'byte-optimize-binary-predicate) +(put 'string-greaterp 'byte-optimizer #'byte-optimize-string-greaterp) +(put 'string> 'byte-optimizer #'byte-optimize-string-greaterp) + (put 'concat 'byte-optimizer #'byte-optimize-concat) ;; I'm not convinced that this is necessary. Doesn't the optimizer loop @@ -1261,7 +1161,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) @@ -1275,21 +1175,21 @@ See Info node `(elisp) Integer Basics'." (proper-list-p clause)) (if (null (cddr clause)) ;; A trivial `progn'. - (byte-optimize-if `(if ,(cadr clause) ,@(nthcdr 2 form))) + (byte-optimize-if `(,(car form) ,(cadr clause) ,@(nthcdr 2 form))) (nconc (butlast clause) (list (byte-optimize-if - `(if ,(car (last clause)) ,@(nthcdr 2 form))))))) + `(,(car form) ,(car (last clause)) ,@(nthcdr 2 form))))))) ((byte-compile-trueconstp clause) `(progn ,clause ,(nth 2 form))) ((byte-compile-nilconstp clause) `(progn ,clause ,@(nthcdr 3 form))) ((nth 2 form) (if (equal '(nil) (nthcdr 3 form)) - (list 'if clause (nth 2 form)) + (list (car form) clause (nth 2 form)) form)) ((or (nth 3 form) (nthcdr 4 form)) - (list 'if + (list (car form) ;; Don't make a double negative; ;; instead, take away the one that is there. (if (and (consp clause) (memq (car clause) '(not null)) @@ -1304,7 +1204,7 @@ See Info node `(elisp) Integer Basics'." (defun byte-optimize-while (form) (when (< (length form) 2) - (byte-compile-warn "too few arguments for `while'")) + (byte-compile-warn-x form "too few arguments for `while'")) (if (nth 1 form) form)) @@ -1342,9 +1242,10 @@ See Info node `(elisp) Integer Basics'." (let ((butlast (nreverse (cdr (reverse (cdr (cdr form))))))) (nconc (list 'funcall fn) butlast (mapcar (lambda (x) (list 'quote x)) (nth 1 last)))) - (byte-compile-warn + (byte-compile-warn-x + last "last arg to apply can't be a literal atom: `%s'" - (prin1-to-string last)) + last) nil)) form)))) @@ -1367,7 +1268,7 @@ See Info node `(elisp) Integer Basics'." (and (consp binding) (cadr binding))) bindings) ,const) - `(let* ,(butlast bindings) + `(,head ,(butlast bindings) ,@(and (consp (car (last bindings))) (cdar (last bindings))) ,const))) @@ -1382,7 +1283,7 @@ See Info node `(elisp) Integer Basics'." `(progn ,@(mapcar (lambda (binding) (and (consp binding) (cadr binding))) bindings)) - `(let* ,(butlast bindings) + `(,head ,(butlast bindings) ,@(and (consp (car (last bindings))) (cdar (last bindings)))))) @@ -1460,13 +1361,14 @@ See Info node `(elisp) Integer Basics'." (let ((side-effect-free-fns '(% * + - / /= 1+ 1- < <= = > >= abs acos append aref ash asin atan assq + base64-decode-string base64-encode-string base64url-encode-string bool-vector-count-consecutive bool-vector-count-population bool-vector-subsetp boundp buffer-file-name buffer-local-variables buffer-modified-p buffer-substring byte-code-function-p capitalize car-less-than-car car cdr ceiling char-after char-before char-equal char-to-string char-width compare-strings - compare-window-configurations concat coordinates-in-window-p + window-configuration-equal-p concat coordinates-in-window-p copy-alist copy-sequence copy-marker copysign cos count-lines current-time-string current-time-zone decode-char @@ -1616,6 +1518,7 @@ See Info node `(elisp) Integer Basics'." assq rassq rassoc plist-get lax-plist-get plist-member aref elt + base64-decode-string base64-encode-string base64url-encode-string bool-vector-subsetp bool-vector-count-population bool-vector-count-consecutive ))) diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 77e077f0442..92c2699c6e3 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -30,6 +30,76 @@ ;;; Code: +(defvar byte-run--ssp-seen nil + "Which conses/vectors/records have been processed in strip-symbol-positions? +The value is a hash table, the keys being the elements and the values being t. + +The purpose of this is to detect circular structures.") + +(defalias 'byte-run--strip-list + #'(lambda (arg) + "Strip the positions from symbols with position in the list ARG. +This is done by destructively modifying ARG. Return ARG." + (let ((a arg)) + (while + (and + (not (gethash a byte-run--ssp-seen)) + (progn + (puthash a t byte-run--ssp-seen) + (cond + ((symbol-with-pos-p (car a)) + (setcar a (bare-symbol (car a)))) + ((consp (car a)) + (byte-run--strip-list (car a))) + ((or (vectorp (car a)) (recordp (car a))) + (byte-run--strip-vector/record (car a)))) + (consp (cdr a)))) + (setq a (cdr a))) + (cond + ((symbol-with-pos-p (cdr a)) + (setcdr a (bare-symbol (cdr a)))) + ((or (vectorp (cdr a)) (recordp (cdr a))) + (byte-run--strip-vector/record (cdr a)))) + arg))) + +(defalias 'byte-run--strip-vector/record + #'(lambda (arg) + "Strip the positions from symbols with position in the vector/record ARG. +This is done by destructively modifying ARG. Return ARG." + (unless (gethash arg byte-run--ssp-seen) + (let ((len (length arg)) + (i 0) + elt) + (puthash arg t byte-run--ssp-seen) + (while (< i len) + (setq elt (aref arg i)) + (cond + ((symbol-with-pos-p elt) + (aset arg i elt)) + ((consp elt) + (byte-run--strip-list elt)) + ((or (vectorp elt) (recordp elt)) + (byte-run--strip-vector/record elt))) + (setq i (1+ i))))) + arg)) + +(defalias 'byte-run-strip-symbol-positions + #'(lambda (arg) + "Strip all positions from symbols in ARG. +This modifies destructively then returns ARG. + +ARG is any Lisp object, but is usually a list or a vector or a +record, containing symbols with position." + (setq byte-run--ssp-seen (make-hash-table :test 'eq)) + (cond + ((symbol-with-pos-p arg) + (bare-symbol arg)) + ((consp arg) + (byte-run--strip-list arg)) + ((or (vectorp arg) (recordp arg)) + (byte-run--strip-vector/record arg)) + (t arg)))) + (defalias 'function-put ;; We don't want people to just use `put' because we can't conveniently ;; hook into `put' to remap old properties to new ones. But for now, there's @@ -38,7 +108,7 @@ "Set FUNCTION's property PROP to VALUE. The namespace for PROP is shared with symbols. So far, FUNCTION can only be a symbol, not a lambda expression." - (put function prop value))) + (put (bare-symbol function) prop value))) (function-put 'defmacro 'doc-string-elt 3) (function-put 'defmacro 'lisp-indent-function 2) @@ -134,6 +204,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 @@ -253,11 +324,11 @@ The return value is undefined. #'(lambda (x) (let ((f (cdr (assq (car x) macro-declarations-alist)))) (if f (apply (car f) name arglist (cdr x)) - (macroexp-warn-and-return + (macroexp-warn-and-return (format-message "Unknown macro property %S in %S" (car x) name) - nil)))) + nil nil nil (car x))))) decls))) ;; Refresh font-lock if this is a new macro, or it is an ;; existing macro whose 'no-font-lock-keyword declaration @@ -329,7 +400,7 @@ The return value is undefined. (macroexp-warn-and-return (format-message "Unknown defun property `%S' in %S" (car x) name) - nil))))) + nil nil nil (car x)))))) decls)) (def (list 'defalias (list 'quote name) @@ -380,7 +451,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 +505,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))) @@ -463,7 +534,7 @@ made obsolete, for example a date or a release number. This macro evaluates all its parameters, and both OBSOLETE-NAME and CURRENT-NAME should be symbols, so a typical usage would look like: - (define-obsolete-variable-alias 'foo-thing 'bar-thing \"28.1\") + (define-obsolete-variable-alias \\='foo-thing \\='bar-thing \"28.1\") This macro uses `defvaralias' and `make-obsolete-variable' (which see). See the Info node `(elisp)Variable Aliases' for more details. @@ -483,7 +554,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. @@ -574,7 +645,7 @@ For the `mapcar' case, only the `mapcar' function can be used in the symbol list. For `suspicious', only `set-buffer' can be used." ;; Note: during compilation, this definition is overridden by the one in ;; byte-compile-initial-macro-environment. - (declare (debug (sexp &optional body)) (indent 1)) + (declare (debug (sexp body)) (indent 1)) (if (not (and (featurep 'macroexp) (boundp 'byte-compile--suppressed-warnings))) ;; If `macroexp' is not yet loaded, we're in the middle of diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 7629e190401..2e89504e8ff 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,10 +321,12 @@ 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 - `fill-column' characters, whichever is bigger). + `fill-column' characters, whichever is bigger) or + have other stylistic issues. suspicious constructs that usually don't do what the coder wanted. If the list begins with `not', then the remaining elements specify warnings to @@ -343,6 +345,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)) @@ -466,9 +469,10 @@ Return the compile-time value of FORM." ;; 3.2.3.1, "Processing of Top Level Forms". The semantics are very ;; subtle: see test/lisp/emacs-lisp/bytecomp-tests.el for interesting ;; cases. - (setf form (macroexp-macroexpand form byte-compile-macro-environment)) + (let ((print-symbols-bare t)) ; Possibly redundant binding. + (setf form (macroexp-macroexpand form byte-compile-macro-environment))) (if (eq (car-safe form) 'progn) - (cons 'progn + (cons (car form) (mapcar (lambda (subform) (byte-compile-recurse-toplevel subform non-toplevel-case)) @@ -497,8 +501,9 @@ Return the compile-time value of FORM." byte-compile-new-defuns)) (setf result (byte-compile-eval - (byte-compile-top-level - (byte-compile-preprocess form))))))) + (byte-run-strip-symbol-positions + (byte-compile-top-level + (byte-compile-preprocess form)))))))) (list 'quote result)))) (eval-and-compile . ,(lambda (&rest body) (byte-compile-recurse-toplevel @@ -507,10 +512,12 @@ Return the compile-time value of FORM." ;; Don't compile here, since we don't know ;; whether to compile as byte-compile-form ;; or byte-compile-file-form. - (let ((expanded - (macroexpand-all - form - macroexpand-all-environment))) + (let* ((print-symbols-bare t) ; Possibly redundant binding. + (expanded + (byte-run-strip-symbol-positions + (macroexpand--all-toplevel + form + macroexpand-all-environment)))) (eval expanded lexical-binding) expanded))))) (with-suppressed-warnings @@ -613,8 +620,8 @@ Each element is (INDEX . VALUE)") "Hash byte-code -> byte-to-native-lambda.") (defvar byte-to-native-top-level-forms nil "List of top level forms.") -(defvar byte-to-native-output-file nil - "Temporary file containing the byte-compilation output.") +(defvar byte-to-native-output-buffer-file nil + "Pair holding byte-compilation output buffer, elc filename.") (defvar byte-to-native-plist-environment nil "To spill `overriding-plist-environment'.") @@ -792,11 +799,7 @@ the unwind-action") (byte-defop 144 0 byte-temp-output-buffer-setup-OBSOLETE) (byte-defop 145 -1 byte-temp-output-buffer-show-OBSOLETE) -;; these ops are new to v19 - -;; To unbind back to the beginning of this frame. -;; Not used yet, but will be needed for tail-recursion elimination. -(byte-defop 146 0 byte-unbind-all) +;; unused: 146 ;; these ops are new to v19 (byte-defop 147 -2 byte-set-marker) @@ -1007,13 +1010,22 @@ CONST2 may be evaluated multiple times." ;; Similarly, replace TAGs in all jump tables with the correct PC index. (dolist (hash-table byte-compile-jump-tables) - (maphash #'(lambda (value tag) - (setq pc (cadr tag)) - ;; We don't need to split PC here, as it is stored as a lisp - ;; object in the hash table (whereas other goto-* ops store - ;; it within 2 bytes in the byte string). - (puthash value pc hash-table)) - hash-table)) + (let (alist) + (maphash #'(lambda (value tag) + (setq pc (cadr tag)) + ;; We don't need to split PC here, as it is stored as a + ;; lisp object in the hash table (whereas other goto-* + ;; ops store it within 2 bytes in the byte string). + ;; De-position any symbols with position in `value'. + ;; Since this may change the hash table key, we remove + ;; the entry from the table and reinsert it outside the + ;; scope of the `maphash'. + (setq value (byte-run-strip-symbol-positions value)) + (push (cons value pc) alist) + (remhash value hash-table)) + hash-table) + (dolist (elt alist) + (puthash (car elt) (cdr elt) hash-table)))) (let ((bytecode (apply 'unibyte-string (nreverse bytes)))) (when byte-native-compiling ;; Spill LAP for the native compiler here. @@ -1031,30 +1043,29 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'." (hist-nil-orig current-load-list)) (prog1 (eval form lexical-binding) (when (byte-compile-warning-enabled-p 'noruntime) - (let ((hist-new load-history) - (hist-nil-new current-load-list)) + (let* ((hist-new + ;; Get new `current-load-list' for the locally defined funs. + (cons (butlast current-load-list + (length hist-nil-orig)) + load-history))) ;; Go through load-history, look for newly loaded files ;; and mark all the functions defined therein. (while (and hist-new (not (eq hist-new hist-orig))) - (let ((xs (pop hist-new)) - old-autoloads) + (let ((xs (pop hist-new))) ;; Make sure the file was not already loaded before. (unless (assoc (car xs) hist-orig) (dolist (s xs) - (cond - ((and (consp s) (eq t (car s))) - (push (cdr s) old-autoloads)) - ((and (consp s) (memq (car s) '(autoload defun))) - (unless (memq (cdr s) old-autoloads) - (push (cdr s) byte-compile-noruntime-functions)))))))) - ;; Go through current-load-list for the locally defined funs. - (let (old-autoloads) - (while (and hist-nil-new (not (eq hist-nil-new hist-nil-orig))) - (let ((s (pop hist-nil-new))) - (when (and (symbolp s) (not (memq s old-autoloads))) - (push s byte-compile-noruntime-functions)) - (when (and (consp s) (eq t (car s))) - (push (cdr s) old-autoloads)))))))))) + (pcase s + (`(defun . ,f) + ;; If `f' has a history, it's presumably because + ;; it was already defined beforehand (typically + ;; as an autoload). It could also be because it + ;; was defined twice during `form', in which case + ;; we arguably should add it to b-c-noruntime-functions, + ;; but it's not clear it's worth the trouble + ;; trying to recognize that case. + (unless (get f 'function-history) + (push f byte-compile-noruntime-functions))))))))))))) (defun byte-compile-eval-before-compile (form) "Evaluate FORM for `eval-and-compile'." @@ -1145,11 +1156,6 @@ message buffer `default-directory'." (t (insert (format "%s\n" string))))))) -(defvar byte-compile-read-position nil - "Character position we began the last `read' from.") -(defvar byte-compile-last-position nil - "Last known character position in the input.") - ;; copied from gnus-util.el (defsubst byte-compile-delete-first (elt list) (if (eq (car list) elt) @@ -1162,43 +1168,6 @@ message buffer `default-directory'." (setcdr list (cddr list))) total))) -;; The purpose of `byte-compile-set-symbol-position' is to attempt to -;; set `byte-compile-last-position' to the "current position" in the -;; raw source code. This is used for warning and error messages. -;; -;; The function should be called for most occurrences of symbols in -;; the forms being compiled, strictly in the order they occur in the -;; source code. It should never be called twice for any single -;; occurrence, and should not be called for symbols generated by the -;; byte compiler itself. -;; -;; The function works by scanning the elements in the alist -;; `read-symbol-positions-list' for the next match for the symbol -;; after the current value of `byte-compile-last-position', setting -;; that variable to the match's character position, then deleting the -;; matching element from the list. Thus the new value for -;; `byte-compile-last-position' is later than the old value unless, -;; perhaps, ALLOW-PREVIOUS is non-nil. -;; -;; So your're probably asking yourself: Isn't this function a gross -;; hack? And the answer, of course, would be yes. -(defun byte-compile-set-symbol-position (sym &optional allow-previous) - (when byte-compile-read-position - (let ((last byte-compile-last-position) - entry) - (while (progn - (setq entry (assq sym read-symbol-positions-list)) - (when entry - (setq byte-compile-last-position - (+ byte-compile-read-position (cdr entry)) - read-symbol-positions-list - (byte-compile-delete-first - entry read-symbol-positions-list))) - (and entry - (or (and allow-previous - (not (= last byte-compile-last-position))) - (> last byte-compile-last-position)))))))) - (defvar byte-compile-last-warned-form nil) (defvar byte-compile-last-logged-file nil) (defvar byte-compile-root-dir nil @@ -1211,6 +1180,36 @@ message buffer `default-directory'." (f2 (file-relative-name file dir))) (if (< (length f2) (length f1)) f2 f1))) +(defun byte-compile--first-symbol-with-pos (form) + "Return the first symbol with position in form, or nil if none. +Order is by depth-first search." + (cond + ((symbol-with-pos-p form) form) + ((consp form) + (or (byte-compile--first-symbol-with-pos (car form)) + (let ((sym nil)) + (setq form (cdr form)) + (while (and (consp form) + (not (setq sym (byte-compile--first-symbol-with-pos + (car form))))) + (setq form (cdr form))) + (or sym + (and form (byte-compile--first-symbol-with-pos form)))))) + ((or (vectorp form) (recordp form)) + (let ((len (length form)) + (i 0) + (sym nil)) + (while (and (< i len) + (not (setq sym (byte-compile--first-symbol-with-pos + (aref form i))))) + (setq i (1+ i))) + sym)))) + +(defun byte-compile--warning-source-offset () + "Return a source offset from `byte-compile-form-stack' or nil if none." + (let ((sym (byte-compile--first-symbol-with-pos byte-compile-form-stack))) + (and sym (symbol-with-pos-pos sym)))) + ;; This is used as warning-prefix for the compiler. ;; It is always called with the warnings buffer current. (defun byte-compile-warning-prefix (level entry) @@ -1228,16 +1227,16 @@ message buffer `default-directory'." (format "%s:" (byte-compile-abbreviate-file load-file-name dir))) (t ""))) + (offset (byte-compile--warning-source-offset)) (pos (if (and byte-compile-current-file - (integerp byte-compile-read-position)) + (or offset (not symbols-with-pos-enabled))) (with-current-buffer byte-compile-current-buffer - (format "%d:%d:" - (save-excursion - (goto-char byte-compile-last-position) - (1+ (count-lines (point-min) (point-at-bol)))) - (save-excursion - (goto-char byte-compile-last-position) - (1+ (current-column))))) + (let (new-l new-c) + (save-excursion + (goto-char offset) + (setq new-l (1+ (count-lines (point-min) (point-at-bol))) + new-c (1+ (current-column))) + (format "%d:%d:" new-l new-c)))) "")) (form (if (eq byte-compile-current-form :end) "end of data" (or byte-compile-current-form "toplevel form")))) @@ -1312,20 +1311,21 @@ Called with arguments (STRING POSITION FILL LEVEL). STRING is a message describing the problem. POSITION is a buffer position where the problem was detected. FILL is a prefix as in `warning-fill-prefix'. LEVEL is the level of the -problem (`:warning' or `:error'). POSITION, FILL and LEVEL may be -nil.") +problem (`:warning' or `:error'). FILL and LEVEL may be nil.") (defun byte-compile-log-warning (string &optional fill level) "Log a byte-compilation warning. STRING, FILL and LEVEL are as described in `byte-compile-log-warning-function', which see." (funcall byte-compile-log-warning-function - string byte-compile-last-position + string + (or (byte-compile--warning-source-offset) + (point)) fill level)) -(defun byte-compile--log-warning-for-byte-compile (string &optional - _position +(defun byte-compile--log-warning-for-byte-compile (string _position + &optional fill level) "Log a message STRING in `byte-compile-log-buffer'. @@ -1346,6 +1346,14 @@ function directly; use `byte-compile-warn' or (error "%s" format) ; byte-compile-file catches and logs it (byte-compile-log-warning format t :warning))) +(defun byte-compile-warn-x (arg format &rest args) + "Issue a byte compiler warning. +ARG is the source element (likely a symbol with position) central to + the warning, intended to supply source position information. +FORMAT and ARGS are as in `byte-compile-warn'." + (let ((byte-compile-form-stack (cons arg byte-compile-form-stack))) + (apply #'byte-compile-warn format args))) + (defun byte-compile-warn-obsolete (symbol) "Warn that SYMBOL (a variable or function) is obsolete." (when (byte-compile-warning-enabled-p 'obsolete symbol) @@ -1355,7 +1363,7 @@ function directly; use `byte-compile-warn' or (or funcp (get symbol 'byte-obsolete-variable)) (if funcp "function" "variable")))) (unless (and funcp (memq symbol byte-compile-not-obsolete-funcs)) - (byte-compile-warn "%s" msg))))) + (byte-compile-warn-x symbol "%s" msg))))) (defun byte-compile-report-error (error-info &optional fill) "Report Lisp error in compilation. @@ -1433,7 +1441,7 @@ when printing the error message." (and (eq 'macro (car-safe f)) (setq f (cdr f))) ;; Advice wrappers have "catch all" args, so fetch the actual underlying ;; function to find the real arguments. - (while (advice--p f) (setq f (advice--cdr f))) + (setq f (advice--cd*r f)) (if (eq (car-safe f) 'declared) (byte-compile-arglist-signature (nth 1 f)) (condition-case nil @@ -1458,7 +1466,6 @@ when printing the error message." (t (format "%d-%d" (car signature) (cdr signature))))) (defun byte-compile-function-warn (f nargs def) - (byte-compile-set-symbol-position f) (when (and (get f 'byte-obsolete-info) (byte-compile-warning-enabled-p 'obsolete f)) (byte-compile-warn-obsolete f)) @@ -1475,19 +1482,24 @@ when printing the error message." (if cons (or (memq nargs (cddr cons)) (push nargs (cddr cons))) - (push (list f byte-compile-last-position nargs) + (push (list f + (if (symbol-with-pos-p f) + (symbol-with-pos-pos f) + 1) ; Should never happen. + nargs) byte-compile-unresolved-functions))))) (defun byte-compile-emit-callargs-warn (name actual-args min-args max-args) - (byte-compile-set-symbol-position name) - (byte-compile-warn - "%s called with %d argument%s, but %s %s" - name actual-args - (if (= 1 actual-args) "" "s") - (if (< actual-args min-args) - "requires" - "accepts only") - (byte-compile-arglist-signature-string (cons min-args max-args)))) + (when (byte-compile-warning-enabled-p 'callargs name) + (byte-compile-warn-x + name + "`%s' called with %d argument%s, but %s %s" + name actual-args + (if (= 1 actual-args) "" "s") + (if (< actual-args min-args) + "requires" + "accepts only") + (byte-compile-arglist-signature-string (cons min-args max-args))))) (defun byte-compile--check-arity-bytecode (form bytecode) "Check that the call in FORM matches that allowed by BYTECODE." @@ -1546,22 +1558,46 @@ extra args." n))) (nargs (- (length form) 2))) (unless (= nargs nfields) - (byte-compile-warn + (byte-compile-warn-x (car form) "`%s' called with %d args to fill %d format field(s)" (car form) nargs nfields))))) (dolist (elt '(format message error)) (put elt 'byte-compile-format-like t)) +(defun byte-compile--suspicious-defcustom-choice (type) + "Say whether defcustom TYPE looks odd." + ;; Check whether there's anything like (choice (const :tag "foo" ;; 'bar)). + ;; We don't actually follow the syntax for defcustom types, but this + ;; should be good enough. + (catch 'found + (if (and (consp type) + (proper-list-p type)) + (if (memq (car type) '(const other)) + (when (assq 'quote type) + (throw 'found t)) + (when (memq t (mapcar #'byte-compile--suspicious-defcustom-choice + type)) + (throw 'found t))) + nil))) + ;; Warn if a custom definition fails to specify :group, or :type. (defun byte-compile-nogroup-warn (form) (let ((keyword-args (cdr (cdr (cdr (cdr form))))) (name (cadr form))) (when (eq (car-safe name) 'quote) - (or (not (eq (car form) 'custom-declare-variable)) - (plist-get keyword-args :type) - (byte-compile-warn - "defcustom for `%s' fails to specify type" (cadr name))) + (when (eq (car form) 'custom-declare-variable) + (let ((type (plist-get keyword-args :type))) + (cond + ((not type) + (byte-compile-warn-x (cadr name) + "defcustom for `%s' fails to specify type" + (cadr name))) + ((byte-compile--suspicious-defcustom-choice type) + (byte-compile-warn-x + (cadr name) + "defcustom for `%s' has syntactically odd type `%s'" + (cadr name) type))))) (if (and (memq (car form) '(custom-declare-face custom-declare-variable)) byte-compile-current-group) ;; The group will be provided implicitly. @@ -1569,7 +1605,7 @@ extra args." (or (and (eq (car form) 'custom-declare-group) (equal name ''emacs)) (plist-get keyword-args :group) - (byte-compile-warn + (byte-compile-warn-x (cadr name) "%s for `%s' fails to specify containing group" (cdr (assq (car form) '((custom-declare-group . defgroup) @@ -1585,32 +1621,31 @@ extra args." ;; number of arguments. (defun byte-compile-arglist-warn (name arglist macrop) ;; This is the first definition. See if previous calls are compatible. - (let ((calls (assq name byte-compile-unresolved-functions)) - nums sig min max) - (when (and calls macrop) - (byte-compile-warn "macro `%s' defined too late" name)) - (setq byte-compile-unresolved-functions - (delq calls byte-compile-unresolved-functions)) - (setq calls (delq t calls)) ;Ignore higher-order uses of the function. - (when (cddr calls) - (when (and (symbolp name) - (eq (function-get name 'byte-optimizer) - 'byte-compile-inline-expand)) - (byte-compile-warn "defsubst `%s' was used before it was defined" - name)) - (setq sig (byte-compile-arglist-signature arglist) - nums (sort (copy-sequence (cddr calls)) (function <)) - min (car nums) - max (car (nreverse nums))) - (when (or (< min (car sig)) - (and (cdr sig) (> max (cdr sig)))) - (byte-compile-set-symbol-position name) - (byte-compile-warn - "%s being defined to take %s%s, but was previously called with %s" - name - (byte-compile-arglist-signature-string sig) - (if (equal sig '(1 . 1)) " arg" " args") - (byte-compile-arglist-signature-string (cons min max)))))) + (let ((calls (assq name byte-compile-unresolved-functions))) + (when calls + (when macrop + (byte-compile-warn-x name "macro `%s' defined too late" name)) + (setq byte-compile-unresolved-functions + (delq calls byte-compile-unresolved-functions)) + (let ((nums (delq t (cddr calls)))) ; Ignore higher-order uses. + (when nums + (when (and (symbolp name) + (eq (function-get name 'byte-optimizer) + 'byte-compile-inline-expand)) + (byte-compile-warn-x + name "defsubst `%s' was used before it was defined" name)) + (let ((sig (byte-compile-arglist-signature arglist)) + (min (apply #'min nums)) + (max (apply #'max nums))) + (when (or (< min (car sig)) + (and (cdr sig) (> max (cdr sig)))) + (byte-compile-warn-x + name + "%s being defined to take %s%s, but was previously called with %s" + name + (byte-compile-arglist-signature-string sig) + (if (equal sig '(1 . 1)) " arg" " args") + (byte-compile-arglist-signature-string (cons min max))))))))) (let* ((old (byte-compile-fdefinition name macrop)) (initial (and macrop (cdr (assq name @@ -1623,8 +1658,8 @@ extra args." (let ((sig1 (byte-compile--function-signature old)) (sig2 (byte-compile-arglist-signature arglist))) (unless (byte-compile-arglist-signatures-congruent-p sig1 sig2) - (byte-compile-set-symbol-position name) - (byte-compile-warn + (byte-compile-warn-x + name "%s %s used to take %s %s, now takes %s" (if macrop "macro" "function") name @@ -1671,9 +1706,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. @@ -1685,8 +1725,12 @@ value, it will override this variable." :safe #'integerp :version "28.1") -(defun byte-compile-docstring-length-warn (form) - "Warn if documentation string of FORM is too wide. +(define-obsolete-function-alias 'byte-compile-docstring-length-warn + 'byte-compile-docstring-style-warn "29.1") + +(defun byte-compile-docstring-style-warn (form) + "Warn if there are stylistic problems with the docstring in FORM. +Warn if documentation string of FORM is too wide. It is too wide if it has any lines longer than the largest of `fill-column' and `byte-compile-docstring-max-column'." (when (byte-compile-warning-enabled-p 'docstrings) @@ -1705,11 +1749,19 @@ 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) "")) - (when (and kind docs (stringp docs) - (byte-compile--wide-docstring-p docs col)) - (byte-compile-warn "%s%s docstring wider than %s characters" - kind name col)))) + (setq name (if name (format " `%s' " name) "")) + (when (and kind docs (stringp docs)) + (when (byte-compile--wide-docstring-p docs col) + (byte-compile-warn-x + name + "%s%sdocstring wider than %s characters" + kind name col)) + ;; There's a "naked" ' character before a symbol/list, so it + ;; should probably be quoted with \=. + (when (string-match-p "\\( \"\\|[ \t]\\|^\\)'[a-z(]" docs) + (byte-compile-warn-x + name "%s%sdocstring has wrong usage of unescaped single quotes (use \\= or different quoting)" + kind name))))) form) ;; If we have compiled any calls to functions which are not known to be @@ -1723,10 +1775,10 @@ It is too wide if it has any lines longer than the largest of (dolist (urf byte-compile-unresolved-functions) (let ((f (car urf))) (when (not (memq f byte-compile-new-defuns)) - (let ((byte-compile-last-position (cadr urf))) - (byte-compile-warn - (if (fboundp f) "the function `%s' might not be defined at runtime." "the function `%s' is not known to be defined.") - (car urf)))))))) + (byte-compile-warn-x + f + (if (fboundp f) "the function `%s' might not be defined at runtime." "the function `%s' is not known to be defined.") + (car urf))))))) nil) @@ -1782,7 +1834,8 @@ It is too wide if it has any lines longer than the largest of (warning-series-started (and (markerp warning-series) (eq (marker-buffer warning-series) - (get-buffer byte-compile-log-buffer))))) + (get-buffer byte-compile-log-buffer)))) + (byte-compile-form-stack byte-compile-form-stack)) (if (or (eq warning-series 'byte-compile-warning-series) warning-series-started) ;; warning-series does come from compilation, @@ -1969,6 +2022,42 @@ If compilation is needed, this functions returns the result of (defvar byte-compile-level 0 ; bug#13787 "Depth of a recursive byte compilation.") +(defun byte-write-target-file (buffer target-file) + "Write BUFFER into TARGET-FILE." + (with-current-buffer buffer + ;; We must disable any code conversion here. + (let* ((coding-system-for-write 'no-conversion) + ;; Write to a tempfile so that if another Emacs + ;; process is trying to load target-file (eg in a + ;; parallel bootstrap), it does not risk getting a + ;; half-finished file. (Bug#4196) + (tempfile + (make-temp-file (when (file-writable-p target-file) + (expand-file-name target-file)))) + (default-modes (default-file-modes)) + (temp-modes (logand default-modes #o600)) + (desired-modes (logand default-modes #o666)) + (kill-emacs-hook + (cons (lambda () (ignore-errors + (delete-file tempfile))) + kill-emacs-hook))) + (unless (= temp-modes desired-modes) + (set-file-modes tempfile desired-modes 'nofollow)) + (write-region (point-min) (point-max) tempfile nil 1) + ;; This has the intentional side effect that any + ;; hard-links to target-file continue to + ;; point to the old file (this makes it possible + ;; for installed files to share disk space with + ;; the build tree, without causing problems when + ;; emacs-lisp files in the build tree are + ;; recompiled). Previously this was accomplished by + ;; deleting target-file before writing it. + (if byte-native-compiling + ;; Defer elc final renaming. + (setf byte-to-native-output-buffer-file + (cons tempfile target-file)) + (rename-file tempfile target-file t))))) + ;;;###autoload (defun byte-compile-file (filename &optional load) "Compile a file of Lisp code named FILENAME into a file of byte code. @@ -2100,38 +2189,11 @@ See also `emacs-lisp-byte-compile-and-load'." ;; Need to expand in case TARGET-FILE doesn't ;; include a directory (Bug#45287). (expand-file-name target-file)))) - ;; We must disable any code conversion here. - (let* ((coding-system-for-write 'no-conversion) - ;; Write to a tempfile so that if another Emacs - ;; process is trying to load target-file (eg in a - ;; parallel bootstrap), it does not risk getting a - ;; half-finished file. (Bug#4196) - (tempfile - (make-temp-file (when (file-writable-p target-file) - (expand-file-name target-file)))) - (default-modes (default-file-modes)) - (temp-modes (logand default-modes #o600)) - (desired-modes (logand default-modes #o666)) - (kill-emacs-hook - (cons (lambda () (ignore-errors - (delete-file tempfile))) - kill-emacs-hook))) - (unless (= temp-modes desired-modes) - (set-file-modes tempfile desired-modes 'nofollow)) - (write-region (point-min) (point-max) tempfile nil 1) - ;; This has the intentional side effect that any - ;; hard-links to target-file continue to - ;; point to the old file (this makes it possible - ;; for installed files to share disk space with - ;; the build tree, without causing problems when - ;; emacs-lisp files in the build tree are - ;; recompiled). Previously this was accomplished by - ;; deleting target-file before writing it. - (if byte-native-compiling - ;; Defer elc final renaming. - (setf byte-to-native-output-file - (cons tempfile target-file)) - (rename-file tempfile target-file t))) + (if byte-native-compiling + ;; Defer elc production. + (setf byte-to-native-output-buffer-file + (cons (current-buffer) target-file)) + (byte-write-target-file (current-buffer) target-file)) (or noninteractive byte-native-compiling (message "Wrote %s" target-file))) @@ -2152,7 +2214,8 @@ See also `emacs-lisp-byte-compile-and-load'." "Cannot overwrite file" "Directory not writable or nonexistent") target-file)))))) - (kill-buffer (current-buffer))) + (unless byte-native-compiling + (kill-buffer (current-buffer)))) (if (and byte-compile-generate-call-tree (or (eq t byte-compile-generate-call-tree) (y-or-n-p (format "Report call tree for %s? " @@ -2182,19 +2245,20 @@ With argument ARG, insert value in current buffer after the form." (save-excursion (end-of-defun) (beginning-of-defun) - (let* ((byte-compile-current-file (current-buffer)) + (let* ((print-symbols-bare t) ; For the final `message'. + (byte-compile-current-file (current-buffer)) (byte-compile-current-buffer (current-buffer)) - (byte-compile-read-position (point)) - (byte-compile-last-position byte-compile-read-position) + (start-read-position (point)) (byte-compile-last-warned-form 'nothing) + (symbols-with-pos-enabled t) (value (eval - (let ((read-with-symbol-positions (current-buffer)) - (read-symbol-positions-list nil)) - (displaying-byte-compile-warnings - (byte-compile-sexp + (displaying-byte-compile-warnings + (byte-compile-sexp + (let ((form (read-positioning-symbols (current-buffer)))) + (push form byte-compile-form-stack) (eval-sexp-add-defvars - (read (current-buffer)) - byte-compile-read-position)))) + form + start-read-position)))) lexical-binding))) (cond (arg (message "Compiling from buffer... done.") @@ -2204,13 +2268,12 @@ With argument ARG, insert value in current buffer after the form." (defun byte-compile-from-buffer (inbuffer) (let ((byte-compile-current-buffer inbuffer) - (byte-compile-read-position nil) - (byte-compile-last-position nil) ;; Prevent truncation of flonums and lists as we read and print them (float-output-format nil) (case-fold-search nil) (print-length nil) (print-level nil) + (print-symbols-bare t) ;; Prevent edebug from interfering when we compile ;; and put the output into a file. ;; (edebug-all-defs nil) @@ -2223,13 +2286,9 @@ 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. - (read-with-symbol-positions inbuffer) - (read-symbol-positions-list nil) ;; #### This is bound in b-c-close-variables. ;; (byte-compile-warnings byte-compile-warnings) - ) + (symbols-with-pos-enabled t)) (byte-compile-close-variables (with-current-buffer (setq byte-compile--outbuffer @@ -2275,18 +2334,17 @@ With argument ARG, insert value in current buffer after the form." (= (following-char) ?\;)) (forward-line 1)) (not (eobp))) - (setq byte-compile-read-position (point) - byte-compile-last-position byte-compile-read-position) (let* ((lread--unescaped-character-literals nil) - (form (read inbuffer)) + ;; Don't bind `load-read-function' to + ;; `read-positioning-symbols' here. Calls to `read' + ;; at a lower level must not get symbols with + ;; position. + (form (read-positioning-symbols inbuffer)) (warning (byte-run--unescaped-character-literals-warning))) - (when warning (byte-compile-warn "%s" warning)) + (when warning (byte-compile-warn-x form "%s" warning)) (byte-compile-toplevel-file-form form))) ;; Compile pending forms at end of file. (byte-compile-flush-pending) - ;; Make warnings about unresolved functions - ;; give the end of the file as their position. - (setq byte-compile-last-position (point-max)) (byte-compile-warn-about-unresolved-functions))) byte-compile--outbuffer))) @@ -2344,7 +2402,8 @@ Call from the source buffer." ;; Spill output for the native compiler here (push (make-byte-to-native-top-level :form form :lexical lexical-binding) byte-to-native-top-level-forms)) - (let ((print-escape-newlines t) + (let ((print-symbols-bare t) ; Possibly redundant binding. + (print-escape-newlines t) (print-length nil) (print-level nil) (print-quoted t) @@ -2379,8 +2438,8 @@ list that represents a doc string reference. ;; in the input buffer (now current), not in the output buffer. (let ((dynamic-docstrings byte-compile-dynamic-docstrings)) (with-current-buffer byte-compile--outbuffer - (let (position) - + (let (position + (print-symbols-bare t)) ; Possibly redundant binding. ;; Insert the doc string, and make it a comment with #@LENGTH. (and (>= (nth 1 info) 0) dynamic-docstrings @@ -2490,7 +2549,8 @@ list that represents a doc string reference. byte-compile-jump-tables nil)))) (defun byte-compile-preprocess (form &optional _for-effect) - (setq form (macroexpand-all form byte-compile-macro-environment)) + (let ((print-symbols-bare t)) ; Possibly redundant binding. + (setq form (macroexpand-all form byte-compile-macro-environment))) ;; FIXME: We should run byte-optimize-form here, but it currently does not ;; recurse through all the code, so we'd have to fix this first. ;; Maybe a good fix would be to merge byte-optimize-form into @@ -2503,11 +2563,16 @@ list that represents a doc string reference. ;; byte-hunk-handlers cannot call this! (defun byte-compile-toplevel-file-form (top-level-form) - (byte-compile-recurse-toplevel - top-level-form - (lambda (form) - (let ((byte-compile-current-form nil)) ; close over this for warnings. - (byte-compile-file-form (byte-compile-preprocess form t)))))) + ;; (let ((byte-compile-form-stack + ;; (cons top-level-form byte-compile-form-stack))) + (push top-level-form byte-compile-form-stack) + (prog1 + (byte-compile-recurse-toplevel + top-level-form + (lambda (form) + (let ((byte-compile-current-form nil)) ; close over this for warnings. + (byte-compile-file-form (byte-compile-preprocess form t))))) + (pop byte-compile-form-stack))) ;; byte-hunk-handlers can call this. (defun byte-compile-file-form (form) @@ -2556,8 +2621,9 @@ list that represents a doc string reference. (delq (assq funsym byte-compile-unresolved-functions) byte-compile-unresolved-functions))))) (if (stringp (nth 3 form)) - (prog1 form - (byte-compile-docstring-length-warn form)) + (prog1 + form + (byte-compile-docstring-style-warn form)) ;; No doc string, so we can compile this as a normal form. (byte-compile-keep-pending form 'byte-compile-normal-call))) @@ -2568,7 +2634,8 @@ list that represents a doc string reference. (when (and (symbolp sym) (not (string-match "[-*/:$]" (symbol-name sym))) (byte-compile-warning-enabled-p 'lexical sym)) - (byte-compile-warn "global/dynamic var `%s' lacks a prefix" sym))) + (byte-compile-warn-x + sym "global/dynamic var `%s' lacks a prefix" sym))) (defun byte-compile--declare-var (sym) (byte-compile--check-prefixed-var sym) @@ -2576,7 +2643,7 @@ list that represents a doc string reference. (setq byte-compile-lexical-variables (delq sym byte-compile-lexical-variables)) (when (byte-compile-warning-enabled-p 'lexical sym) - (byte-compile-warn "Variable `%S' declared after its first use" sym))) + (byte-compile-warn-x sym "Variable `%S' declared after its first use" sym))) (push sym byte-compile-bound-variables) (push sym byte-compile--seen-defvars)) @@ -2588,11 +2655,11 @@ list that represents a doc string reference. (if (and (null (cddr form)) ;No `value' provided. (eq (car form) 'defvar)) ;Just a declaration. nil - (byte-compile-docstring-length-warn form) - (cond ((consp (nth 2 form)) - (setq form (copy-sequence form)) - (setcar (cdr (cdr form)) - (byte-compile-top-level (nth 2 form) nil 'file)))) + (byte-compile-docstring-style-warn form) + (setq form (copy-sequence form)) + (when (consp (nth 2 form)) + (setcar (cdr (cdr form)) + (byte-compile-top-level (nth 2 form) nil 'file))) form)) (put 'define-abbrev-table 'byte-hunk-handler @@ -2610,9 +2677,10 @@ list that represents a doc string reference. (`(defvaralias ,_ ',newname . ,_) (when (memq newname byte-compile-bound-variables) (if (byte-compile-warning-enabled-p 'suspicious) - (byte-compile-warn + (byte-compile-warn-x + newname "Alias for `%S' should be declared before its referent" newname))))) - (byte-compile-docstring-length-warn form) + (byte-compile-docstring-style-warn form) (byte-compile-keep-pending form)) (put 'custom-declare-variable 'byte-hunk-handler @@ -2624,8 +2692,11 @@ list that represents a doc string reference. (put 'require 'byte-hunk-handler 'byte-compile-file-form-require) (defun byte-compile-file-form-require (form) - (let ((args (mapcar 'eval (cdr form))) - hist-new prov-cons) + (let* ((args (mapcar 'eval (cdr form))) + ;; The following is for the byte-compile-warn in + ;; `do-after-load-evaluation' (in subr.el). + (byte-compile-form-stack (cons (car args) byte-compile-form-stack)) + hist-new prov-cons) (apply 'require args) ;; Record the functions defined by the require in `byte-compile-new-defuns'. @@ -2669,16 +2740,8 @@ list that represents a doc string reference. (put 'make-obsolete 'byte-hunk-handler 'byte-compile-file-form-make-obsolete) (defun byte-compile-file-form-make-obsolete (form) (prog1 (byte-compile-keep-pending form) - (apply 'make-obsolete (mapcar 'eval (cdr form))))) - -;; This handler is not necessary, but it makes the output from dont-compile -;; and similar macros cleaner. -(put 'eval 'byte-hunk-handler 'byte-compile-file-form-eval) -(defun byte-compile-file-form-eval (form) - (if (and (eq (car-safe (nth 1 form)) 'quote) - (equal (nth 2 form) lexical-binding)) - (nth 1 (nth 1 form)) - (byte-compile-keep-pending form))) + (apply 'make-obsolete + (mapcar 'eval (cdr form))))) (defun byte-compile-file-form-defmumble (name macro arglist body rest) "Process a `defalias' for NAME. @@ -2693,23 +2756,23 @@ not to take responsibility for the actual compilation of the code." 'byte-compile-macro-environment)) (this-one (assq name (symbol-value this-kind))) (that-one (assq name (symbol-value that-kind))) + (bare-name (bare-symbol name)) (byte-compile-current-form name)) ; For warnings. - (byte-compile-set-symbol-position name) - (push name byte-compile-new-defuns) + (push bare-name byte-compile-new-defuns) ;; When a function or macro is defined, add it to the call tree so that ;; we can tell when functions are not used. (if byte-compile-generate-call-tree - (or (assq name byte-compile-call-tree) + (or (assq bare-name byte-compile-call-tree) (setq byte-compile-call-tree - (cons (list name nil nil) byte-compile-call-tree)))) + (cons (list bare-name nil nil) byte-compile-call-tree)))) (if (byte-compile-warning-enabled-p 'redefine name) (byte-compile-arglist-warn name arglist macro)) (if byte-compile-verbose (message "Compiling %s... (%s)" - (or byte-compile-current-file "") name)) + (or byte-compile-current-file "") bare-name)) (cond ((not (or macro (listp body))) ;; We do not know positively if the definition is a macro ;; or a function, so we shouldn't emit warnings. @@ -2718,29 +2781,34 @@ not to take responsibility for the actual compilation of the code." (that-one (if (and (byte-compile-warning-enabled-p 'redefine name) ;; Don't warn when compiling the stubs in byte-run... - (not (assq name byte-compile-initial-macro-environment))) - (byte-compile-warn + (not (assq bare-name byte-compile-initial-macro-environment))) + (byte-compile-warn-x + name "`%s' defined multiple times, as both function and macro" - name)) + bare-name)) (setcdr that-one nil)) (this-one (when (and (byte-compile-warning-enabled-p 'redefine name) ;; Hack: Don't warn when compiling the magic internal ;; byte-compiler macros in byte-run.el... - (not (assq name byte-compile-initial-macro-environment))) - (byte-compile-warn "%s `%s' defined multiple times in this file" - (if macro "macro" "function") - name))) - ((eq (car-safe (symbol-function name)) + (not (assq bare-name byte-compile-initial-macro-environment))) + (byte-compile-warn-x + name + "%s `%s' defined multiple times in this file" + (if macro "macro" "function") + bare-name))) + ((eq (car-safe (symbol-function bare-name)) (if macro 'lambda 'macro)) - (when (byte-compile-warning-enabled-p 'redefine name) - (byte-compile-warn "%s `%s' being redefined as a %s" - (if macro "function" "macro") - name - (if macro "macro" "function"))) + (when (byte-compile-warning-enabled-p 'redefine bare-name) + (byte-compile-warn-x + name + "%s `%s' being redefined as a %s" + (if macro "function" "macro") + bare-name + (if macro "macro" "function"))) ;; Shadow existing definition. (set this-kind - (cons (cons name nil) + (cons (cons bare-name nil) (symbol-value this-kind)))) ) @@ -2749,10 +2817,8 @@ not to take responsibility for the actual compilation of the code." (symbolp (car-safe (cdr-safe body))) (car-safe (cdr-safe body)) (stringp (car-safe (cdr-safe (cdr-safe body))))) - ;; FIXME: We've done that already just above, so this looks wrong! - ;;(byte-compile-set-symbol-position name) - (byte-compile-warn "probable `\"' without `\\' in doc string of %s" - name)) + (byte-compile-warn-x + name "probable `\"' without `\\' in doc string of %s" bare-name)) (if (not (listp body)) ;; The precise definition requires evaluation to find out, so it @@ -2760,7 +2826,7 @@ not to take responsibility for the actual compilation of the code." ;; For a macro, that means we can't use that macro in the same file. (progn (unless macro - (push (cons name (if (listp arglist) `(declared ,arglist) t)) + (push (cons bare-name (if (listp arglist) `(declared ,arglist) t)) byte-compile-function-environment)) ;; Tell the caller that we didn't compile it yet. nil) @@ -2770,10 +2836,10 @@ not to take responsibility for the actual compilation of the code." ;; A definition in b-c-initial-m-e should always take precedence ;; during compilation, so don't let it be redefined. (Bug#8647) (or (and macro - (assq name byte-compile-initial-macro-environment)) + (assq bare-name byte-compile-initial-macro-environment)) (setcdr this-one code)) (set this-kind - (cons (cons name code) + (cons (cons bare-name code) (symbol-value this-kind)))) (if rest @@ -2789,18 +2855,19 @@ not to take responsibility for the actual compilation of the code." (if (not (stringp (documentation code t))) -1 4))) (when byte-native-compiling ;; Spill output for the native compiler here. - (push (if macro - (make-byte-to-native-top-level - :form `(defalias ',name '(macro . ,code) nil) - :lexical lexical-binding) - (make-byte-to-native-func-def :name name - :byte-func code)) - byte-to-native-top-level-forms)) + (push + (if macro + (make-byte-to-native-top-level + :form `(defalias ',name '(macro . ,code) nil) + :lexical lexical-binding) + (make-byte-to-native-func-def :name name + :byte-func code)) + byte-to-native-top-level-forms)) ;; Output the form by hand, that's much simpler than having ;; b-c-output-file-form analyze the defalias. (byte-compile-output-docform "\n(defalias '" - name + bare-name (if macro `(" '(macro . #[" ,index "])") `(" #[" ,index "]")) (append code nil) ; Turn byte-code-function-p into list. (and (atom code) byte-compile-dynamic @@ -2883,37 +2950,38 @@ If FORM is a lambda or a macro, byte-compile it as a function." (macro (eq (car-safe fun) 'macro))) (if macro (setq fun (cdr fun))) - (cond - ;; Up until Emacs-24.1, byte-compile silently did nothing when asked to - ;; compile something invalid. So let's tune down the complaint from an - ;; error to a simple message for the known case where signaling an error - ;; causes problems. - ((byte-code-function-p fun) - (message "Function %s is already compiled" - (if (symbolp form) form "provided")) - fun) - (t - (let (final-eval) - (when (or (symbolp form) (eq (car-safe fun) 'closure)) - ;; `fun' is a function *value*, so try to recover its corresponding - ;; source code. - (setq lexical-binding (eq (car fun) 'closure)) - (setq fun (byte-compile--reify-function fun)) - (setq final-eval t)) - ;; Expand macros. - (setq fun (byte-compile-preprocess fun)) - (setq fun (byte-compile-top-level fun nil 'eval)) - (if (symbolp form) - ;; byte-compile-top-level returns an *expression* equivalent to the - ;; `fun' expression, so we need to evaluate it, tho normally - ;; this is not needed because the expression is just a constant - ;; byte-code object, which is self-evaluating. - (setq fun (eval fun t))) - (if final-eval - (setq fun (eval fun t))) - (if macro (push 'macro fun)) - (if (symbolp form) (fset form fun)) - fun))))))) + (prog1 + (cond + ;; Up until Emacs-24.1, byte-compile silently did nothing when asked to + ;; compile something invalid. So let's tune down the complaint from an + ;; error to a simple message for the known case where signaling an error + ;; causes problems. + ((byte-code-function-p fun) + (message "Function %s is already compiled" + (if (symbolp form) form "provided")) + fun) + (t + (let (final-eval) + (when (or (symbolp form) (eq (car-safe fun) 'closure)) + ;; `fun' is a function *value*, so try to recover its corresponding + ;; source code. + (setq lexical-binding (eq (car fun) 'closure)) + (setq fun (byte-compile--reify-function fun)) + (setq final-eval t)) + ;; Expand macros. + (setq fun (byte-compile-preprocess fun)) + (setq fun (byte-compile-top-level fun nil 'eval)) + (if (symbolp form) + ;; byte-compile-top-level returns an *expression* equivalent to the + ;; `fun' expression, so we need to evaluate it, tho normally + ;; this is not needed because the expression is just a constant + ;; byte-code object, which is self-evaluating. + (setq fun (eval fun t))) + (if final-eval + (setq fun (eval fun t))) + (if macro (push 'macro fun)) + (if (symbolp form) (fset form fun)) + fun)))))))) (defun byte-compile-sexp (sexp) "Compile and return SEXP." @@ -2926,8 +2994,6 @@ If FORM is a lambda or a macro, byte-compile it as a function." (let (vars) (while list (let ((arg (car list))) - (when (symbolp arg) - (byte-compile-set-symbol-position arg)) (cond ((or (not (symbolp arg)) (macroexp--const-symbol-p arg t)) (error "Invalid lambda variable %s" arg)) @@ -2944,7 +3010,8 @@ If FORM is a lambda or a macro, byte-compile it as a function." ((and (memq arg vars) ;; Allow repetitions for unused args. (not (string-match "\\`_" (symbol-name arg)))) - (byte-compile-warn "repeated variable %s in lambda-list" arg)) + (byte-compile-warn-x + arg "repeated variable %s in lambda-list" arg)) (t (push arg vars)))) (setq list (cdr list))))) @@ -2987,7 +3054,8 @@ If FORM is a lambda or a macro, byte-compile it as a function." (defun byte-compile--warn-lexical-dynamic (var context) (when (byte-compile-warning-enabled-p 'lexical-dynamic var) - (byte-compile-warn + (byte-compile-warn-x + var "`%s' lexically bound in %s here but declared dynamic in: %s" var context (mapconcat #'identity @@ -2999,20 +3067,16 @@ If FORM is a lambda or a macro, byte-compile it as a function." (defun byte-compile-lambda (fun &optional add-lambda reserved-csts) "Byte-compile a lambda-expression and return a valid function. The value is usually a compiled function but may be the original -lambda-expression. -When ADD-LAMBDA is non-nil, the symbol `lambda' is added as head -of the list FUN and `byte-compile-set-symbol-position' is not called. -Use this feature to avoid calling `byte-compile-set-symbol-position' -for symbols generated by the byte compiler itself." +lambda-expression." (if add-lambda (setq fun (cons 'lambda fun)) (unless (eq 'lambda (car-safe fun)) - (error "Not a lambda list: %S" fun)) - (byte-compile-set-symbol-position 'lambda)) - (byte-compile-docstring-length-warn fun) + (error "Not a lambda list: %S" fun))) + (byte-compile-docstring-style-warn fun) (byte-compile-check-lambda-list (nth 1 fun)) (let* ((arglist (nth 1 fun)) - (arglistvars (byte-compile-arglist-vars arglist)) + (arglistvars (byte-run-strip-symbol-positions + (byte-compile-arglist-vars arglist))) (byte-compile-bound-variables (append (if (not lexical-binding) arglistvars) byte-compile-bound-variables)) @@ -3031,7 +3095,6 @@ for symbols generated by the byte compiler itself." (byte-compile--warn-lexical-dynamic var 'lambda)))) ;; Process the interactive spec. (when int - (byte-compile-set-symbol-position 'interactive) ;; Skip (interactive) if it is in front (the most usual location). (if (eq int (car body)) (setq body (cdr body))) @@ -3039,8 +3102,8 @@ for symbols generated by the byte compiler itself." ;; Check that the bit after the `interactive' spec is ;; just a list of symbols (i.e., modes). (unless (seq-every-p #'symbolp (cdr (cdr int))) - (byte-compile-warn "malformed interactive specc: %s" - (prin1-to-string int))) + (byte-compile-warn-x int "malformed interactive specc: %s" + int)) (setq command-modes (cdr (cdr int))) ;; If the interactive spec is a call to `list', don't ;; compile it, because `call-interactively' looks at the @@ -3052,16 +3115,17 @@ for symbols generated by the byte compiler itself." (while (consp (cdr form)) (setq form (cdr form))) (setq form (car form))) - (when (or (not (eq (car-safe form) 'list)) - ;; For code using lexical-binding, form is not - ;; valid lisp, but rather an intermediate form - ;; which may include "calls" to - ;; internal-make-closure (Bug#29988). - lexical-binding) - (setq int `(interactive ,newform))))) + (if (or (not (eq (car-safe form) 'list)) + ;; For code using lexical-binding, form is not + ;; valid lisp, but rather an intermediate form + ;; which may include "calls" to + ;; internal-make-closure (Bug#29988). + lexical-binding) + (setq int `(,(car int) ,newform)) + (setq int (byte-run-strip-symbol-positions int))))) ; for compile-defun. ((cdr int) ; Invalid (interactive . something). - (byte-compile-warn "malformed interactive spec: %s" - (prin1-to-string int))))) + (byte-compile-warn-x int "malformed interactive spec: %s" + int)))) ;; Process the body. (let ((compiled (byte-compile-top-level (cons 'progn body) nil 'lambda @@ -3072,14 +3136,15 @@ for symbols generated by the byte compiler itself." (and lexical-binding (byte-compile-make-lambda-lexenv arglistvars)) - reserved-csts))) + reserved-csts)) + (bare-arglist (byte-run-strip-symbol-positions arglist))) ; for compile-defun. ;; Build the actual byte-coded function. (cl-assert (eq 'byte-code (car-safe compiled))) (let ((out (apply #'make-byte-code (if lexical-binding (byte-compile-make-args-desc arglist) - arglist) + bare-arglist) (append ;; byte-string, constants-vector, stack depth (cdr compiled) @@ -3087,7 +3152,7 @@ for symbols generated by the byte compiler itself." (cond ((and lexical-binding arglist) ;; byte-compile-make-args-desc lost the args's names, ;; so preserve them in the docstring. - (list (help-add-fundoc-usage doc arglist))) + (list (help-add-fundoc-usage doc bare-arglist))) ((or doc int) (list doc))) ;; optionally, the interactive spec (and the modes the @@ -3292,7 +3357,8 @@ for symbols generated by the byte compiler itself." (setq byte-compile-noruntime-functions (delq fn byte-compile-noruntime-functions)) ;; Delegate the rest to the normal macro definition. - (macroexpand `(declare-function ,fn ,file ,@args))) + (let ((print-symbols-bare t)) ; Possibly redundant binding. + (macroexpand `(declare-function ,fn ,file ,@args)))) ;; This is the recursive entry point for compiling each subform of an @@ -3310,18 +3376,14 @@ for symbols generated by the byte compiler itself." ;; (defun byte-compile-form (form &optional for-effect) (let ((byte-compile--for-effect for-effect)) + (push form byte-compile-form-stack) (cond ((not (consp form)) (cond ((or (not (symbolp form)) (macroexp--const-symbol-p form)) - (when (symbolp form) - (byte-compile-set-symbol-position form)) (byte-compile-constant form)) ((and byte-compile--for-effect byte-compile-delete-errors) - (when (symbolp form) - (byte-compile-set-symbol-position form)) (setq byte-compile--for-effect nil)) - (t - (byte-compile-variable-ref form)))) + (t (byte-compile-variable-ref form)))) ((symbolp (car form)) (let* ((fn (car form)) (handler (get fn 'byte-compile)) @@ -3344,20 +3406,20 @@ for symbols generated by the byte compiler itself." (byte-compile-check-variable (cadr hook) nil)))) (when (and (byte-compile-warning-enabled-p 'suspicious) (macroexp--const-symbol-p fn)) - (byte-compile-warn "`%s' called as a function" fn)) + (byte-compile-warn-x fn "`%s' called as a function" fn)) (when (and (byte-compile-warning-enabled-p 'interactive-only fn) interactive-only) - (byte-compile-warn "`%s' is for interactive use only%s" - fn - (cond ((stringp interactive-only) - (format "; %s" - (substitute-command-keys - interactive-only))) - ((and (symbolp 'interactive-only) - (not (eq interactive-only t))) - (format-message "; use `%s' instead." - interactive-only)) - (t ".")))) + (byte-compile-warn-x fn "`%s' is for interactive use only%s" + fn + (cond ((stringp interactive-only) + (format "; %s" + (substitute-command-keys + interactive-only))) + ((and (symbolp 'interactive-only) + (not (eq interactive-only t))) + (format-message "; use `%s' instead." + interactive-only)) + (t ".")))) (if (eq (car-safe (symbol-function (car form))) 'macro) (byte-compile-report-error (format "`%s' defined after use in %S (missing `require' of a library file?)" @@ -3382,7 +3444,8 @@ for symbols generated by the byte compiler itself." (setq byte-compile--for-effect nil)) ((byte-compile-normal-call form))) (if byte-compile--for-effect - (byte-compile-discard)))) + (byte-compile-discard)) + (pop byte-compile-form-stack))) (defun byte-compile-normal-call (form) (when (and (symbolp (car form)) @@ -3396,8 +3459,8 @@ for symbols generated by the byte compiler itself." (byte-compile-annotate-call-tree form)) (when (and byte-compile--for-effect (eq (car form) 'mapcar) (byte-compile-warning-enabled-p 'mapcar 'mapcar)) - (byte-compile-set-symbol-position 'mapcar) - (byte-compile-warn + (byte-compile-warn-x + (car form) "`mapcar' called for effect; use `mapc' or `dolist' instead")) (byte-compile-push-constant (car form)) (mapc 'byte-compile-form (cdr form)) ; wasteful, but faster. @@ -3528,16 +3591,16 @@ for symbols generated by the byte compiler itself." (defun byte-compile-check-variable (var access-type) "Do various error checks before a use of the variable VAR." - (when (symbolp var) - (byte-compile-set-symbol-position var)) (cond ((or (not (symbolp var)) (macroexp--const-symbol-p var)) (when (byte-compile-warning-enabled-p 'constants (and (symbolp var) var)) - (byte-compile-warn (if (eq access-type 'let-bind) - "attempt to let-bind %s `%s'" - "variable reference to %s `%s'") - (if (symbolp var) "constant" "nonvariable") - (prin1-to-string var)))) + (byte-compile-warn-x + var + (if (eq access-type 'let-bind) + "attempt to let-bind %s `%s'" + "variable reference to %s `%s'") + (if (symbolp var) "constant" "nonvariable") + var))) ((let ((od (get var 'byte-obsolete-variable))) (and od (not (memq var byte-compile-not-obsolete-vars)) @@ -3562,9 +3625,10 @@ for symbols generated by the byte compiler itself." (push var byte-compile-bound-variables) (byte-compile-dynamic-variable-op 'byte-varbind var)) -(defun byte-compile-free-vars-warn (var &optional assignment) +(defun byte-compile-free-vars-warn (arg var &optional assignment) "Warn if symbol VAR refers to a free variable. VAR must not be lexically bound. +ARG is a position argument, used by byte-compile-warn-x. If optional argument ASSIGNMENT is non-nil, this is treated as an assignment (i.e. `setq')." (unless (or (not (byte-compile-warning-enabled-p 'free-vars var)) @@ -3576,9 +3640,9 @@ assignment (i.e. `setq')." (let* ((varname (prin1-to-string var)) (desc (if assignment "assignment" "reference")) (suggestions (help-uni-confusable-suggestions varname))) - (byte-compile-warn "%s to free variable `%s'%s" - desc varname - (if suggestions (concat "\n " suggestions) ""))) + (byte-compile-warn-x arg "%s to free variable `%s'%s" + desc var + (if suggestions (concat "\n " suggestions) ""))) (push var (if assignment byte-compile-free-assignments byte-compile-free-references)))) @@ -3591,7 +3655,7 @@ assignment (i.e. `setq')." ;; VAR is lexically bound (byte-compile-stack-ref (cdr lex-binding)) ;; VAR is dynamically bound - (byte-compile-free-vars-warn var) + (byte-compile-free-vars-warn var var) (byte-compile-dynamic-variable-op 'byte-varref var)))) (defun byte-compile-variable-set (var) @@ -3602,7 +3666,7 @@ assignment (i.e. `setq')." ;; VAR is lexically bound. (byte-compile-stack-set (cdr lex-binding)) ;; VAR is dynamically bound. - (byte-compile-free-vars-warn var t) + (byte-compile-free-vars-warn var var t) (byte-compile-dynamic-variable-op 'byte-varset var)))) (defmacro byte-compile-get-constant (const) @@ -3627,9 +3691,9 @@ assignment (i.e. `setq')." ;; Use this for a constant that is not the value of its containing form. ;; This ignores byte-compile--for-effect. (defun byte-compile-push-constant (const) - (when (symbolp const) - (byte-compile-set-symbol-position const)) - (byte-compile-out 'byte-constant (byte-compile-get-constant const))) + (byte-compile-out + 'byte-constant + (byte-compile-get-constant const))) ;; Compile those primitive ordinary functions ;; which have special byte codes just for speed. @@ -3781,12 +3845,13 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (defun byte-compile-subr-wrong-args (form n) - (byte-compile-set-symbol-position (car form)) - (byte-compile-warn "`%s' called with %d arg%s, but requires %s" - (car form) (length (cdr form)) - (if (= 1 (length (cdr form))) "" "s") n) - ;; Get run-time wrong-number-of-args error. - (byte-compile-normal-call form)) + (when (byte-compile-warning-enabled-p 'callargs (car form)) + (byte-compile-warn-x (car form) + "`%s' called with %d arg%s, but requires %s" + (car form) (length (cdr form)) + (if (= 1 (length (cdr form))) "" "s") n) + ;; Get run-time wrong-number-of-args error. + (byte-compile-normal-call form))) (defun byte-compile-no-args (form) (if (not (= (length form) 1)) @@ -3895,7 +3960,9 @@ discarding." (byte-defop-compiler-1 internal-get-closed-var byte-compile-get-closed-var) (defun byte-compile-make-closure (form) - "Byte-compile the special `internal-make-closure' form." + "Byte-compile the special `internal-make-closure' form. + +This function is never called when `lexical-binding' is nil." (if byte-compile--for-effect (setq byte-compile--for-effect nil) (let* ((vars (nth 1 form)) (env (nth 2 form)) @@ -3907,7 +3974,7 @@ discarding." docstring-exp)) ;Otherwise, we don't need a closure. (cl-assert (byte-code-function-p fun)) (byte-compile-form - (if (or (not docstring-exp) (stringp docstring-exp)) + (if (macroexp-const-p docstring-exp) ;; Use symbols V0, V1 ... as placeholders for closure variables: ;; they should be short (to save space in the .elc file), yet ;; distinct when disassembled. @@ -3917,24 +3984,33 @@ discarding." (number-sequence 4 (1- (length fun))))) (proto-fun (apply #'make-byte-code - (aref fun 0) (aref fun 1) + (aref fun 0) ; The arglist is always the 15-bit + ; form, never the list of symbols. + (aref fun 1) ; The byte-code. ;; Prepend dummy cells to the constant vector, ;; to get the indices right when disassembling. (vconcat dummy-vars (aref fun 2)) - (aref fun 3) + (aref fun 3) ; Stack depth of function (if docstring-exp - (cons docstring-exp (cdr opt-args)) + (cons + (eval (byte-run-strip-symbol-positions + docstring-exp) + t) + (cdr opt-args)) ; The interactive spec will + ; have been stripped in + ; `byte-compile-lambda'. opt-args)))) `(make-closure ,proto-fun ,@env)) ;; Nontrivial doc string expression: create a bytecode object ;; from small pieces at run time. `(make-byte-code - ',(aref fun 0) ',(aref fun 1) - (vconcat (vector . ,env) ',(aref fun 2)) + ',(aref fun 0) ; 15-bit form of arglist descriptor. + ',(aref fun 1) ; The byte-code. + (vconcat (vector . ,env) ',(aref fun 2)) ; constant vector. ,@(let ((rest (nthcdr 3 (mapcar (lambda (x) `',x) fun)))) (if docstring-exp `(,(car rest) - ,docstring-exp + ,(byte-run-strip-symbol-positions docstring-exp) ,@(cddr rest)) rest)))) )))) @@ -4093,7 +4169,8 @@ discarding." (if (eq 'interactive (car-safe (car body))) (setq body (cdr body))) (if (and (consp (car body)) (not (eq 'byte-code (car (car body))))) - (byte-compile-warn + (byte-compile-warn-x + (nth 2 form) "A quoted lambda form is the second argument of `fset'. This is probably not what you want, as that lambda cannot be compiled. Consider using the syntax #'(lambda (...) ...) instead."))))) @@ -4178,10 +4255,11 @@ discarding." (macroexp--const-symbol-p var t)) (byte-compile-warning-enabled-p 'constants (and (symbolp var) var)) - (byte-compile-warn + (byte-compile-warn-x + var "variable assignment to %s `%s'" (if (symbolp var) "constant" "nonvariable") - (prin1-to-string var))))) + var)))) (byte-compile-normal-call form))) (defun byte-compile-quote (form) @@ -4714,7 +4792,6 @@ binding slots have been popped." ;; Even when optimization is off, /= is optimized to (not (= ...)). (defun byte-compile-negation-optimizer (form) ;; an optimizer for forms where <form1> is less efficient than (not <form2>) - (byte-compile-set-symbol-position (car form)) (list 'not (cons (or (get (car form) 'byte-compile-negated-op) (error @@ -4764,18 +4841,17 @@ binding slots have been popped." (cons (byte-compile-make-tag) clause)) failure-handlers)) (endtag (byte-compile-make-tag))) - (byte-compile-set-symbol-position 'condition-case) (unless (symbolp var) - (byte-compile-warn - "`%s' is not a variable-name or nil (in condition-case)" var)) + (byte-compile-warn-x + var "`%s' is not a variable-name or nil (in condition-case)" var)) (dolist (clause (reverse clauses)) (let ((condition (nth 1 clause))) (unless (consp condition) (setq condition (list condition))) (dolist (c condition) (unless (and c (symbolp c)) - (byte-compile-warn - "`%S' is not a condition name (in condition-case)" c)) + (byte-compile-warn-x + c "`%S' is not a condition name (in condition-case)" c)) ;; In reality, the `error-conditions' property is only required ;; for the argument to `signal', not to `condition-case'. ;;(unless (consp (get c 'error-conditions)) @@ -4826,7 +4902,8 @@ binding slots have been popped." (defun byte-compile-save-excursion (form) (if (and (eq 'set-buffer (car-safe (car-safe (cdr form)))) (byte-compile-warning-enabled-p 'suspicious 'set-buffer)) - (byte-compile-warn + (byte-compile-warn-x + form "Use `with-current-buffer' rather than save-excursion+set-buffer")) (byte-compile-out 'byte-save-excursion 0) (byte-compile-body-do-effect (cdr form)) @@ -4860,25 +4937,25 @@ binding slots have been popped." (push (nth 1 (nth 1 form)) byte-compile-global-not-obsolete-vars)) (byte-compile-normal-call form)) -(defconst byte-compile-tmp-var (make-symbol "def-tmp-var")) - (defun byte-compile-defvar (form) ;; This is not used for file-level defvar/consts. (when (and (symbolp (nth 1 form)) (not (string-match "[-*/:$]" (symbol-name (nth 1 form)))) (byte-compile-warning-enabled-p 'lexical (nth 1 form))) - (byte-compile-warn "global/dynamic var `%s' lacks a prefix" - (nth 1 form))) - (byte-compile-docstring-length-warn form) + (byte-compile-warn-x + (nth 1 form) + "global/dynamic var `%s' lacks a prefix" + (nth 1 form))) + (byte-compile-docstring-style-warn form) (let ((fun (nth 0 form)) (var (nth 1 form)) (value (nth 2 form)) (string (nth 3 form))) - (byte-compile-set-symbol-position fun) (when (or (> (length form) 4) (and (eq fun 'defconst) (null (cddr form)))) (let ((ncall (length (cdr form)))) - (byte-compile-warn + (byte-compile-warn-x + fun "`%s' called with %d argument%s, but %s %s" fun ncall (if (= 1 ncall) "" "s") @@ -4888,28 +4965,29 @@ binding slots have been popped." (if (eq fun 'defconst) (push var byte-compile-const-variables)) (when (and string (not (stringp string))) - (byte-compile-warn "third arg to `%s %s' is not a string: %s" - fun var string)) + (byte-compile-warn-x + string + "third arg to `%s %s' is not a string: %s" + fun var string)) + ;; Delegate the actual work to the function version of the + ;; special form, named with a "-1" suffix. (byte-compile-form-do-effect - (if (cddr form) ; `value' provided - ;; Quote with `quote' to prevent byte-compiling the body, - ;; which would lead to an inf-loop. - `(funcall '(lambda (,byte-compile-tmp-var) - (,fun ,var ,byte-compile-tmp-var ,@(nthcdr 3 form))) - ,value) - (if (eq fun 'defconst) - ;; This will signal an appropriate error at runtime. - `(eval ',form) - ;; A simple (defvar foo) just returns foo. - `',var))))) + (cond + ((eq fun 'defconst) `(defconst-1 ',var ,@(nthcdr 2 form))) + ((not (cddr form)) `',var) ; A simple (defvar foo) just returns foo. + (t `(defvar-1 ',var + ;; Don't eval `value' if `defvar' wouldn't eval it either. + ,(if (macroexp-const-p value) value + `(if (boundp ',var) nil ,value)) + ,@(nthcdr 3 form))))))) (defun byte-compile-autoload (form) - (byte-compile-set-symbol-position 'autoload) (and (macroexp-const-p (nth 1 form)) (macroexp-const-p (nth 5 form)) (memq (eval (nth 5 form)) '(t macro)) ; macro-p (not (fboundp (eval (nth 1 form)))) - (byte-compile-warn + (byte-compile-warn-x + form "The compiler ignores `autoload' except at top level. You should probably put the autoload of the macro `%s' at top-level." (eval (nth 1 form)))) @@ -4918,7 +4996,6 @@ binding slots have been popped." ;; Lambdas in valid places are handled as special cases by various code. ;; The ones that remain are errors. (defun byte-compile-lambda-form (_form) - (byte-compile-set-symbol-position 'lambda) (error "`lambda' used as function name is invalid")) ;; Compile normally, but deal with warnings for the function being defined. @@ -4929,13 +5006,13 @@ binding slots have been popped." ;; if it weren't for the fact that we need to figure out when a defalias ;; defines a macro, so as to add it to byte-compile-macro-environment. ;; - ;; FIXME: we also use this hunk-handler to implement the function's dynamic - ;; docstring feature. We could actually implement it more elegantly in - ;; byte-compile-lambda so it applies to all lambdas, but the problem is that - ;; the resulting .elc format will not be recognized by make-docfile, so - ;; either we stop using DOC for the docstrings of preloaded elc files (at the - ;; cost of around 24KB on 32bit hosts, double on 64bit hosts) or we need to - ;; build DOC in a more clever way (e.g. handle anonymous elements). + ;; FIXME: we also use this hunk-handler to implement the function's + ;; dynamic docstring feature (via byte-compile-file-form-defmumble). + ;; We should actually implement it (more elegantly) in + ;; byte-compile-lambda so it applies to all lambdas. We did it here + ;; so the resulting .elc format was recognizable by make-docfile, + ;; but since then we stopped using DOC for the docstrings of + ;; preloaded elc files so that obstacle is gone. (let ((byte-compile-free-references nil) (byte-compile-free-assignments nil)) (pcase form @@ -4944,7 +5021,7 @@ binding slots have been popped." ;; - `arg' is the expression to which it is defined. ;; - `rest' is the rest of the arguments. (`(,_ ',name ,arg . ,rest) - (byte-compile-docstring-length-warn form) + (byte-compile-docstring-style-warn form) (pcase-let* ;; `macro' is non-nil if it defines a macro. ;; `fun' is the function part of `arg' (defaults to `arg'). @@ -4998,7 +5075,8 @@ binding slots have been popped." (defun byte-compile-make-variable-buffer-local (form) (if (and (eq (car-safe (car-safe (cdr-safe form))) 'quote) (byte-compile-warning-enabled-p 'make-local)) - (byte-compile-warn + (byte-compile-warn-x + form "`make-variable-buffer-local' not called at toplevel")) (byte-compile-normal-call form)) (put 'make-variable-buffer-local @@ -5042,6 +5120,8 @@ binding slots have been popped." nil)) (_ (byte-compile-keep-pending form)))) + + ;;; tags @@ -5076,7 +5156,7 @@ binding slots have been popped." OP and OPERAND are as passed to `byte-compile-out'." (if (memq op '(byte-call byte-discardN byte-discardN-preserve-tos)) ;; For calls, OPERAND is the number of args, so we pop OPERAND + 1 - ;; elements, and the push the result, for a total of -OPERAND. + ;; elements, and then push the result, for a total of -OPERAND. ;; For discardN*, of course, we just pop OPERAND elements. (- operand) (or (aref byte-stack+-info (symbol-value op)) @@ -5086,6 +5166,11 @@ OP and OPERAND are as passed to `byte-compile-out'." (- 1 operand)))) (defun byte-compile-out (op &optional operand) + "Push the operation onto `byte-compile-output'. +OP is an opcode, a symbol. OPERAND is either nil or a number or +a one-element list of a lisp form." + (when (and (consp operand) (null (cdr operand))) + (setq operand (byte-run-strip-symbol-positions operand))) (push (cons op operand) byte-compile-output) (if (eq op 'byte-return) ;; This is actually an unnecessary case, because there should be no @@ -5100,24 +5185,26 @@ OP and OPERAND are as passed to `byte-compile-out'." ;;; call tree stuff (defun byte-compile-annotate-call-tree (form) - (let (entry) + (let ((current-form (byte-run-strip-symbol-positions + byte-compile-current-form)) + (bare-car-form (byte-run-strip-symbol-positions (car form))) + entry) ;; annotate the current call - (if (setq entry (assq (car form) byte-compile-call-tree)) - (or (memq byte-compile-current-form (nth 1 entry)) ;callers + (if (setq entry (assq bare-car-form byte-compile-call-tree)) + (or (memq current-form (nth 1 entry)) ;callers (setcar (cdr entry) - (cons byte-compile-current-form (nth 1 entry)))) + (cons current-form (nth 1 entry)))) (setq byte-compile-call-tree - (cons (list (car form) (list byte-compile-current-form) nil) + (cons (list bare-car-form (list current-form) nil) byte-compile-call-tree))) ;; annotate the current function - (if (setq entry (assq byte-compile-current-form byte-compile-call-tree)) - (or (memq (car form) (nth 2 entry)) ;called + (if (setq entry (assq current-form byte-compile-call-tree)) + (or (memq bare-car-form (nth 2 entry)) ;called (setcar (cdr (cdr entry)) - (cons (car form) (nth 2 entry)))) + (cons bare-car-form (nth 2 entry)))) (setq byte-compile-call-tree - (cons (list byte-compile-current-form nil (list (car form))) - byte-compile-call-tree))) - )) + (cons (list current-form nil (list bare-car-form)) + byte-compile-call-tree))))) ;; Renamed from byte-compile-report-call-tree ;; to avoid interfering with completion of byte-compile-file. @@ -5142,14 +5229,15 @@ invoked interactively." (set-buffer "*Call-Tree*") (erase-buffer) (message "Generating call tree... (sorting on %s)" - byte-compile-call-tree-sort) + (remove-pos-from-symbol byte-compile-call-tree-sort)) (insert "Call tree for " (cond ((null byte-compile-current-file) (or filename "???")) ((stringp byte-compile-current-file) byte-compile-current-file) (t (buffer-name byte-compile-current-file))) " sorted on " - (prin1-to-string byte-compile-call-tree-sort) + (prin1-to-string (remove-pos-from-symbol + byte-compile-call-tree-sort)) ":\n\n") (if byte-compile-call-tree-sort (setq byte-compile-call-tree @@ -5169,7 +5257,8 @@ invoked interactively." ('name (lambda (x y) (string< (car x) (car y)))) (_ (error "`byte-compile-call-tree-sort': `%s' - unknown sort mode" - byte-compile-call-tree-sort)))))) + (remove-pos-from-symbol + byte-compile-call-tree-sort))))))) (message "Generating call tree...") (let ((rest byte-compile-call-tree) (b (current-buffer)) @@ -5316,7 +5405,7 @@ already up-to-date." (or (not (file-exists-p dest)) (file-newer-than-file-p source dest)))) (if (null (batch-byte-compile-file (car command-line-args-left))) - (setq error t)))) + (setq error t)))) (setq command-line-args-left (cdr command-line-args-left))) (kill-emacs (if error 1 0)))) diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index ccb96d169d5..4535f1aa6eb 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -201,7 +201,10 @@ Returns a form where all lambdas don't have any free variables." (i 0) (new-env ())) ;; Build the "formal and actual envs" for the closure-converted function. - (dolist (fv fvs) + ;; Hack for OClosure: `nreverse' here intends to put the captured vars + ;; in the closure such that the first one is the one that is bound + ;; most closely. + (dolist (fv (nreverse fvs)) (let ((exp (or (cdr (assq fv env)) fv))) (pcase exp ;; If `fv' is a variable that's wrapped in a cons-cell, @@ -240,7 +243,7 @@ Returns a form where all lambdas don't have any free variables." ;; this case better, we'd need to traverse the tree one more time to ;; collect this data, and I think that it's not worth it. (mapcar (lambda (mapping) - (if (not (eq (cadr mapping) 'apply-partially)) + (if (not (eq (cadr mapping) #'apply-partially)) mapping (cl-assert (eq (car mapping) (nth 2 mapping))) `(,(car mapping) @@ -258,11 +261,11 @@ Returns a form where all lambdas don't have any free variables." ;; unused vars. (not (intern-soft var)) (eq ?_ (aref (symbol-name var) 0)) - ;; As a special exception, ignore "ignore". + ;; As a special exception, ignore "ignored". (eq var 'ignored)) (let ((suggestions (help-uni-confusable-suggestions (symbol-name var)))) (format "Unused lexical %s `%S'%s" - varkind var + varkind (bare-symbol var) (if suggestions (concat "\n " suggestions) ""))))) (define-inline cconv--var-classification (binder form) @@ -286,24 +289,38 @@ of converted forms." (let (and (pred stringp) msg) (cconv--warn-unused-msg arg "argument"))) (if (assq arg env) (push `(,arg . nil) env)) ;FIXME: Is it needed? - (push (lambda (body) (macroexp--warn-wrap msg body 'lexical)) wrappers)) + (push (lambda (body) (macroexp--warn-wrap arg msg body 'lexical)) wrappers)) (_ (if (assq arg env) (push `(,arg . nil) env))))) (setq funcbody (mapcar (lambda (form) (cconv-convert form env nil)) funcbody)) (if wrappers - (let ((special-forms '())) - ;; Keep special forms at the beginning of the body. - (while (or (and (cdr funcbody) (stringp (car funcbody))) ;docstring. - (memq (car-safe (car funcbody)) - '(interactive declare :documentation))) - (push (pop funcbody) special-forms)) - (let ((body (macroexp-progn funcbody))) + (pcase-let ((`(,decls . ,body) (macroexp-parse-body funcbody))) + (let ((body (macroexp-progn body))) (dolist (wrapper wrappers) (setq body (funcall wrapper body))) - `(,@(nreverse special-forms) ,@(macroexp-unprogn body)))) + `(,@decls ,@(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. @@ -353,7 +370,8 @@ places where they originally did not directly appear." (var (if (not (consp binder)) (prog1 binder (setq binder (list binder))) (when (cddr binder) - (byte-compile-warn + (byte-compile-warn-x + binder "Malformed `%S' binding: %S" letsym binder)) (setq value (cadr binder)) @@ -361,9 +379,9 @@ places where they originally did not directly appear." (cond ;; Ignore bindings without a valid name. ((not (symbolp var)) - (byte-compile-warn "attempt to let-bind nonvariable `%S'" var)) + (byte-compile-warn-x var "attempt to let-bind nonvariable `%S'" var)) ((or (booleanp var) (keywordp var)) - (byte-compile-warn "attempt to let-bind constant `%S'" var)) + (byte-compile-warn-x var "attempt to let-bind constant `%S'" var)) (t (let ((new-val (pcase (cconv--var-classification binder form) @@ -413,11 +431,14 @@ places where they originally did not directly appear." ;; Declared variable is unused. (if (assq var new-env) (push `(,var) new-env)) ;FIXME:Needed? - (let ((newval - `(ignore ,(cconv-convert value env extend))) - (msg (cconv--warn-unused-msg var "variable"))) + (let* ((Ignore (if (symbol-with-pos-p var) + (position-symbol 'ignore var) + 'ignore)) + (newval `(,Ignore + ,(cconv-convert value env extend))) + (msg (cconv--warn-unused-msg var "variable"))) (if (null msg) newval - (macroexp--warn-wrap msg newval 'lexical)))) + (macroexp--warn-wrap var msg newval 'lexical)))) ;; Normal default case. (_ @@ -428,10 +449,14 @@ 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)) + ;; FIXME: `closedsym' doesn't need to be added to `extend' + ;; but adding it makes it easier to write the assertion at + ;; the beginning of this function. (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 +474,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) @@ -476,11 +500,11 @@ places where they originally did not directly appear." args))) (`(cond . ,cond-forms) ; cond special form - `(cond . ,(mapcar (lambda (branch) - (mapcar (lambda (form) - (cconv-convert form env extend)) - branch)) - cond-forms))) + `(,(car form) . ,(mapcar (lambda (branch) + (mapcar (lambda (form) + (cconv-convert form env extend)) + branch)) + cond-forms))) (`(function (lambda ,args . ,body) . ,_) (let ((docstring (if (eq :documentation (car-safe (car body))) @@ -514,9 +538,9 @@ places where they originally did not directly appear." (msg (when (eq class :unused) (cconv--warn-unused-msg var "variable"))) (newprotform (cconv-convert protected-form env extend))) - `(condition-case ,var + `(,(car form) ,var ,(if msg - (macroexp--warn-wrap msg newprotform 'lexical) + (macroexp--warn-wrap var msg newprotform 'lexical) newprotform) ,@(mapcar (lambda (handler) @@ -530,9 +554,9 @@ places where they originally did not directly appear." `((let ((,var (list ,var))) ,@body)))))) handlers)))) - (`(unwind-protect ,form . ,body) - `(unwind-protect ,(cconv-convert form env extend) - :fun-body ,(cconv--convert-function () body env form))) + (`(unwind-protect ,form1 . ,body) + `(,(car form) ,(cconv-convert form1 env extend) + :fun-body ,(cconv--convert-function () body env form1))) (`(setq . ,forms) ; setq special form (if (= (logand (length forms) 1) 1) @@ -544,7 +568,7 @@ places where they originally did not directly appear." (sym-new (or (cdr (assq sym env)) sym)) (value (cconv-convert (pop forms) env extend))) (push (pcase sym-new - ((pred symbolp) `(setq ,sym-new ,value)) + ((pred symbolp) `(,(car form) ,sym-new ,value)) (`(car-safe ,iexp) `(setcar ,iexp ,value)) ;; This "should never happen", but for variables which are ;; mutated+captured+unused, we may end up trying to `setq' @@ -580,12 +604,20 @@ places where they originally did not directly appear." (cons fun args))))))) (`(interactive . ,forms) - `(interactive . ,(mapcar (lambda (form) + `(,(car form) . ,(mapcar (lambda (form) (cconv-convert form nil nil)) forms))) (`(declare . ,_) form) ;The args don't contain code. + (`(oclosure--fix-type (ignore . ,vars) ,exp) + (dolist (var vars) + (let ((x (assq var env))) + (pcase (cdr x) + (`(car-safe . ,_) (error "Slot %S should not be mutated" var)) + (_ (cl-assert (null (cdr x))))))) + (cconv-convert exp env extend)) + (`(,func . ,forms) ;; First element is function or whatever function-like forms are: or, and, ;; if, catch, progn, prog1, while, until @@ -608,10 +640,10 @@ 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-x + var "%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 ,_ ,_)) @@ -619,7 +651,7 @@ FORM is the parent form that binds this var." ;; so as to give better position information and obey ;; `byte-compile-warnings'. (unless (not (intern-soft var)) - (byte-compile-warn "Variable `%S' left uninitialized" var)))) + (byte-compile-warn-x var "Variable `%S' left uninitialized" var)))) (pcase vardata (`(,binder nil ,_ ,_ nil) (push (cons (cons binder form) :unused) cconv-var-classification)) @@ -648,7 +680,8 @@ FORM is the parent form that binds this var." (dolist (arg args) (cond ((byte-compile-not-lexical-var-p arg) - (byte-compile-warn + (byte-compile-warn-x + arg "Lexical argument shadows the dynamic variable %S" arg)) ((eq ?& (aref (symbol-name arg) 0)) nil) ;Ignore &rest, &optional, ... @@ -731,7 +764,8 @@ This function does not return anything but instead fills the (setq forms (cddr forms)))) (`((lambda . ,_) . ,_) ; First element is lambda expression. - (byte-compile-warn + (byte-compile-warn-x + (nth 1 (car form)) "Use of deprecated ((lambda %s ...) ...) form" (nth 1 (car form))) (dolist (exp `((function ,(car form)) . ,(cdr form))) (cconv-analyze-form exp env))) @@ -750,8 +784,8 @@ This function does not return anything but instead fills the (`(condition-case ,var ,protected-form . ,handlers) (cconv-analyze-form protected-form env) (when (and var (symbolp var) (byte-compile-not-lexical-var-p var)) - (byte-compile-warn - "Lexical variable shadows the dynamic variable %S" var)) + (byte-compile-warn-x + var "Lexical variable shadows the dynamic variable %S" var)) (let* ((varstruct (list var nil nil nil nil))) (if var (push varstruct env)) (dolist (handler handlers) diff --git a/lisp/emacs-lisp/chart.el b/lisp/emacs-lisp/chart.el index 4186a541f82..29fbcce7734 100644 --- a/lisp/emacs-lisp/chart.el +++ b/lisp/emacs-lisp/chart.el @@ -1,7 +1,6 @@ ;;; chart.el --- Draw charts (bar charts, etc) -*- lexical-binding: t -*- -;; Copyright (C) 1996, 1998-1999, 2001, 2004-2005, 2007-2022 Free -;; Software Foundation, Inc. +;; Copyright (C) 1996-2022 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> ;; Old-Version: 0.2 @@ -76,8 +75,7 @@ Colors will be the background color.") (defvar chart-face-pixmap-list - (if (and (fboundp 'display-graphic-p) - (display-graphic-p)) + (if (display-graphic-p) '("dimple1" "scales" "dot" "cross_weave" "boxes" "dimple3")) "If pixmaps are allowed, display these background pixmaps. Useful if new Emacs is used on B&W display.") diff --git a/lisp/emacs-lisp/check-declare.el b/lisp/emacs-lisp/check-declare.el index eeefb3de10c..83187acf71e 100644 --- a/lisp/emacs-lisp/check-declare.el +++ b/lisp/emacs-lisp/check-declare.el @@ -319,10 +319,7 @@ Returns non-nil if any false statements are found." (setq root (directory-file-name (file-relative-name root))) (or (file-directory-p root) (error "Directory `%s' not found" root)) - (let ((files (process-lines find-program root - "-name" "*.el" - "-exec" grep-program - "-l" "^[ \t]*(declare-function" "{}" "+"))) + (let ((files (directory-files-recursively root "\\.el\\'"))) (when files (apply #'check-declare-files files)))) diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index 660b7062d1e..5700afbb03e 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -166,7 +166,7 @@ (require 'help-mode) ;; for help-xref-info-regexp (require 'thingatpt) ;; for handy thing-at-point-looking-at (require 'lisp-mode) ;; for lisp-mode-symbol-regexp -(require 'dired) ;; for dired-get-filename and dired-map-over-marks +(eval-when-compile (require 'dired)) ;; for dired-map-over-marks (require 'lisp-mnt) (defvar compilation-error-regexp-alist) @@ -327,7 +327,7 @@ This should be set in an Emacs Lisp file's local variables." ;;;###autoload(put 'checkdoc-symbol-words 'safe-local-variable #'checkdoc-list-of-strings-p) (defcustom checkdoc-column-zero-backslash-before-paren t - "Non-nil means to warn if there is no '\\' before '(' in column zero. + "Non-nil means to warn if there is no \"\\\" before \"(\" in column zero. This backslash is no longer needed on Emacs 27.1 or later. See Info node `(elisp) Documentation Tips' for background." @@ -340,6 +340,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 @@ -494,6 +495,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 @@ -1113,18 +1117,27 @@ 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 extension (\".el\"). When called from Lisp, FILES is a list of filenames." (interactive - (list - (delq nil - (mapcar - ;; skip anything that doesn't look like an Emacs Lisp library - (lambda (f) (if (equal (file-name-extension f) "el") f nil)) - (nreverse (dired-map-over-marks (dired-get-filename) nil))))) + (progn + ;; These Dired functions must be defined since we're in a Dired buffer. + (declare-function dired-get-filename "dired" + (&optional localp no-error-if-not-filep)) + ;; These functions are used by the expansion of `dired-map-over-marks'. + (declare-function dired-move-to-filename "dired" + (&optional raise-error eol)) + (declare-function dired-marker-regexp "dired" ()) + (list + (delq nil + (mapcar + ;; skip anything that doesn't look like an Emacs Lisp library + (lambda (f) (if (equal (file-name-extension f) "el") f nil)) + (nreverse (dired-map-over-marks (dired-get-filename) nil)))))) dired-mode) (if (null files) (error "No files to run checkdoc on") @@ -1270,27 +1283,27 @@ TEXT, START, END and UNFIXABLE conform to (let ((map (make-sparse-keymap)) (pmap (make-sparse-keymap))) ;; Override some bindings - (define-key map "\C-\M-x" 'checkdoc-eval-defun) - (define-key map "\C-x`" 'checkdoc-continue) + (define-key map "\C-\M-x" #'checkdoc-eval-defun) + (define-key map "\C-x`" #'checkdoc-continue) (define-key map [menu-bar emacs-lisp eval-buffer] - 'checkdoc-eval-current-buffer) + #'checkdoc-eval-current-buffer) ;; Add some new bindings under C-c ? - (define-key pmap "x" 'checkdoc-defun) - (define-key pmap "X" 'checkdoc-ispell-defun) - (define-key pmap "`" 'checkdoc-continue) - (define-key pmap "~" 'checkdoc-ispell-continue) - (define-key pmap "s" 'checkdoc-start) - (define-key pmap "S" 'checkdoc-ispell-start) - (define-key pmap "d" 'checkdoc) - (define-key pmap "D" 'checkdoc-ispell) - (define-key pmap "b" 'checkdoc-current-buffer) - (define-key pmap "B" 'checkdoc-ispell-current-buffer) - (define-key pmap "e" 'checkdoc-eval-current-buffer) - (define-key pmap "m" 'checkdoc-message-text) - (define-key pmap "M" 'checkdoc-ispell-message-text) - (define-key pmap "c" 'checkdoc-comments) - (define-key pmap "C" 'checkdoc-ispell-comments) - (define-key pmap " " 'checkdoc-rogue-spaces) + (define-key pmap "x" #'checkdoc-defun) + (define-key pmap "X" #'checkdoc-ispell-defun) + (define-key pmap "`" #'checkdoc-continue) + (define-key pmap "~" #'checkdoc-ispell-continue) + (define-key pmap "s" #'checkdoc-start) + (define-key pmap "S" #'checkdoc-ispell-start) + (define-key pmap "d" #'checkdoc) + (define-key pmap "D" #'checkdoc-ispell) + (define-key pmap "b" #'checkdoc-current-buffer) + (define-key pmap "B" #'checkdoc-ispell-current-buffer) + (define-key pmap "e" #'checkdoc-eval-current-buffer) + (define-key pmap "m" #'checkdoc-message-text) + (define-key pmap "M" #'checkdoc-ispell-message-text) + (define-key pmap "c" #'checkdoc-comments) + (define-key pmap "C" #'checkdoc-ispell-comments) + (define-key pmap " " #'checkdoc-rogue-spaces) ;; bind our submap into map (define-key map "\C-c?" pmap) @@ -2126,13 +2139,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") @@ -2223,7 +2234,7 @@ If the offending word is in a piece of quoted text, then it is skipped." ;; (defvar ispell-process) (declare-function ispell-buffer-local-words "ispell" ()) -(declare-function ispell-correct-p "ispell" ()) +(declare-function ispell-correct-p "ispell" (&optional following)) (declare-function ispell-set-spellchecker-params "ispell" ()) (declare-function ispell-accept-buffer-local-defs "ispell" ()) (declare-function ispell-error-checking-word "ispell" (word)) @@ -2411,7 +2422,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))) @@ -2453,11 +2464,9 @@ Code:, and others referenced in the style guide." pos) (goto-char (point-min)) ;; match ";;;###autoload" cookie to keep it with the form - (require 'autoload) (while (and cont (re-search-forward - (concat "^\\(" - (regexp-quote generate-autoload-cookie) - "\n\\)?" + (concat "^\\(" lisp-mode-autoload-regexp + "\n\\)?" "(") nil t)) (setq pos (match-beginning 0) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index add8e7fda0c..200af057cd7 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) @@ -135,13 +144,20 @@ SPECIALIZERS-FUNCTION takes as first argument a tag value TAG (cl-defstruct (cl--generic-method (:constructor nil) (:constructor cl--generic-make-method - (specializers qualifiers uses-cnm function)) + (specializers qualifiers call-con function)) (:predicate nil)) (specializers nil :read-only t :type list) (qualifiers nil :read-only t :type (list-of atom)) - ;; USES-CNM is a boolean indicating if FUNCTION expects an extra argument - ;; holding the next-method. - (uses-cnm nil :read-only t :type boolean) + ;; CALL-CON indicates the calling convention expected by FUNCTION: + ;; - nil: FUNCTION is just a normal function with no extra arguments for + ;; `call-next-method' or `next-method-p' (which it hence can't use). + ;; - `curried': FUNCTION is a curried function that first takes the + ;; "next combined method" and return the resulting combined method. + ;; It can distinguish `next-method-p' by checking if that next method + ;; is `cl--generic-isnot-nnm-p'. + ;; - t: FUNCTION takes the `call-next-method' function as its first (extra) + ;; argument. + (call-con nil :read-only t :type symbol) (function nil :read-only t :type function)) (cl-defstruct (cl--generic @@ -253,6 +269,16 @@ DEFAULT-BODY, if present, is used as the body of a default method. (declarations nil) (methods ()) (options ()) + (warnings + (let ((nonsymargs + (delq nil (mapcar (lambda (arg) (unless (symbolp arg) arg)) + args)))) + (when nonsymargs + (list + (macroexp-warn-and-return + (format "Non-symbol arguments to cl-defgeneric: %s" + (mapconcat #'prin1-to-string nonsymargs "")) + nil nil nil nonsymargs))))) next-head) (while (progn (setq next-head (car-safe (car options-and-methods))) (or (keywordp next-head) @@ -275,12 +301,17 @@ DEFAULT-BODY, if present, is used as the body of a default method. (setq name (gv-setter (cadr name)))) `(prog1 (progn + ,@warnings (defalias ',name (cl-generic-define ',name ',args ',(nreverse options)) - ,(help-add-fundoc-usage doc args)) + ,(if (consp doc) ;An expression rather than a constant. + `(help-add-fundoc-usage ,doc ',args) + (help-add-fundoc-usage doc args))) :autoload-end - ,@(mapcar (lambda (method) `(cl-defmethod ,name ,@method)) - (nreverse methods))) + ,(when methods + `(with-suppressed-warnings ((obsolete ,name)) + ,@(mapcar (lambda (method) `(cl-defmethod ,name ,@method)) + (nreverse methods))))) ,@(mapcar (lambda (declaration) (let ((f (cdr (assq (car declaration) defun-declarations-alist)))) @@ -370,14 +401,16 @@ the specializer used will be the one returned by BODY." . ,(lambda () spec-args)) macroexpand-all-environment))) (require 'cl-lib) ;Needed to expand `cl-flet' and `cl-function'. - (when (interactive-form (cadr fun)) - (message "Interactive forms unsupported in generic functions: %S" - (interactive-form (cadr fun)))) + (when (assq 'interactive body) + (message "Interactive forms not supported in generic functions: %S" + (assq 'interactive body))) ;; First macroexpand away the cl-function stuff (e.g. &key and ;; destructuring args, `declare' and whatnot). (pcase (macroexpand fun macroenv) (`#'(lambda ,args . ,body) (let* ((parsed-body (macroexp-parse-body body)) + (nm (make-symbol "cl--nm")) + (arglist (make-symbol "cl--args")) (cnm (make-symbol "cl--cnm")) (nmp (make-symbol "cl--nmp")) (nbody (macroexpand-all @@ -390,15 +423,49 @@ the specializer used will be the one returned by BODY." ;; is used. ;; FIXME: Also, optimize the case where call-next-method is ;; only called with explicit arguments. - (uses-cnm (macroexp--fgrep `((,cnm) (,nmp)) nbody))) - (cons (not (not uses-cnm)) - `#'(lambda (,@(if uses-cnm (list cnm)) ,@args) - ,@(car parsed-body) - ,(if (not (assq nmp uses-cnm)) - nbody - `(let ((,nmp (lambda () - (cl--generic-isnot-nnm-p ,cnm)))) - ,nbody)))))) + (uses-cnm (macroexp--fgrep `((,cnm) (,nmp)) nbody)) + (λ-lift (mapcar #'car uses-cnm))) + (if (not uses-cnm) + (cons nil + `#'(lambda (,@args) + ,@(car parsed-body) + ,nbody)) + (cons 'curried + `#'(lambda (,nm) ;Called when constructing the effective method. + (let ((,nmp (if (cl--generic-isnot-nnm-p ,nm) + #'always #'ignore))) + ;; This `(λ (&rest x) .. (apply (λ (args) ..) x))' + ;; dance is needed because we need to get the original + ;; args as a list when `cl-call-next-method' is + ;; called with no arguments. It's important to + ;; capture it as a list since it needs to distinguish + ;; the nil case from the absent case in optional + ;; arguments and it needs to properly remember the + ;; original value if `nbody' mutates some of its + ;; formal args. + ;; FIXME: This `(λ (&rest ,arglist)' could be skipped + ;; when we know `cnm' is always called with args, and + ;; it could be implemented more efficiently if `cnm' + ;; is always called directly and there are no + ;; `&optional' args. + (lambda (&rest ,arglist) + ,@(let* ((prebody (car parsed-body)) + (ds (if (stringp (car prebody)) + prebody + (setq prebody (cons nil prebody)))) + (usage (help-split-fundoc (car ds) nil))) + (unless usage + (setcar ds (help-add-fundoc-usage (car ds) + args))) + prebody) + (let ((,cnm (lambda (&rest args) + (apply ,nm (or args ,arglist))))) + ;; This `apply+lambda' basically parses + ;; `arglist' according to `args'. + ;; A destructuring-bind would do the trick + ;; as well when/if it's more efficient. + (apply (lambda (,@λ-lift ,@args) ,nbody) + ,@λ-lift ,arglist))))))))) (f (error "Unexpected macroexpansion result: %S" f)))))) (put 'cl-defmethod 'function-documentation @@ -495,23 +562,18 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (require 'gv) (declare-function gv-setter "gv" (name)) (setq name (gv-setter (cadr name)))) - (pcase-let* ((`(,uses-cnm . ,fun) (cl--generic-lambda args body))) + (pcase-let* ((`(,call-con . ,fun) (cl--generic-lambda args body))) `(progn - ,(and (get name 'byte-obsolete-info) - (or (not (fboundp 'byte-compile-warning-enabled-p)) - (byte-compile-warning-enabled-p 'obsolete name)) - (let* ((obsolete (get name 'byte-obsolete-info))) - (macroexp-warn-and-return - (macroexp--obsolete-warning name obsolete "generic function") - nil))) ;; You could argue that `defmethod' modifies rather than defines the ;; function, so warnings like "not known to be defined" are fair game. ;; But in practice, it's common to use `cl-defmethod' ;; without a previous `cl-defgeneric'. ;; The ",'" is a no-op that pacifies check-declare. (,'declare-function ,name "") - (cl-generic-define-method ',name ',(nreverse qualifiers) ',args - ,uses-cnm ,fun))))) + ;; We use #' to quote `name' so as to trigger an + ;; obsolescence warning when applicable. + (cl-generic-define-method #',name ',(nreverse qualifiers) ',args + ',call-con ,fun))))) (defun cl--generic-member-method (specializers qualifiers methods) (while @@ -529,7 +591,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined `(,name ,qualifiers . ,specializers)) ;;;###autoload -(defun cl-generic-define-method (name qualifiers args uses-cnm function) +(defun cl-generic-define-method (name qualifiers args call-con function) (pcase-let* ((generic (cl-generic-ensure-function name)) (`(,spec-args . ,_) (cl--generic-split-args args)) @@ -538,7 +600,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined spec-arg (cdr spec-arg))) spec-args)) (method (cl--generic-make-method - specializers qualifiers uses-cnm function)) + specializers qualifiers call-con function)) (mt (cl--generic-method-table generic)) (me (cl--generic-member-method specializers qualifiers mt)) (dispatches (cl--generic-dispatches generic)) @@ -589,19 +651,18 @@ 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)) +(defvar cl--generic-compiler + ;; Don't byte-compile the dispatchers if cl-generic itself is not + ;; compiled. Otherwise the byte-compiler and all the code on + ;; which it depends needs to be usable before cl-generic is loaded, + ;; which imposes a significant burden on the bootstrap. + (if (consp (lambda (x) (+ x 1))) + (lambda (exp) (eval exp t)) #'byte-compile)) + (defun cl--generic-get-dispatcher (dispatch) - (cl--generic-with-memoization + (with-memoization ;; We need `copy-sequence` here because this `dispatch' object might be ;; modified by side-effect in `cl-generic-define-method' (bug#46722). (gethash (copy-sequence dispatch) cl--generic-dispatchers) @@ -644,12 +705,16 @@ The set of acceptable TYPEs (also called \"specializers\") is defined ;; FIXME: For generic functions with a single method (or with 2 methods, ;; one of which always matches), using a tagcode + hash-table is ;; overkill: better just use a `cl-typep' test. - (byte-compile + (funcall + cl--generic-compiler `(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 @@ -686,14 +751,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 @@ -712,29 +777,38 @@ for all those different tags in the method-cache.") (list (cl--generic-name generic))) f)))) -(defun cl--generic-no-next-method-function (generic method) - (lambda (&rest args) - (apply #'cl-no-next-method generic method args))) +(oclosure-define (cl--generic-nnm) + "Special type for `call-next-method's that just call `no-next-method'.") (defun cl-generic-call-method (generic method &optional fun) "Return a function that calls METHOD. FUN is the function that should be called when METHOD calls `call-next-method'." - (if (not (cl--generic-method-uses-cnm method)) - (cl--generic-method-function method) - (let ((met-fun (cl--generic-method-function method)) - (next (or fun (cl--generic-no-next-method-function - generic method)))) - (lambda (&rest args) - (apply met-fun - ;; FIXME: This sucks: passing just `next' would - ;; be a lot more efficient than the lambda+apply - ;; quasi-η, but we need this to implement the - ;; "if call-next-method is called with no - ;; arguments, then use the previous arguments". - (lambda (&rest cnm-args) - (apply next (or cnm-args args))) - args))))) + (let ((met-fun (cl--generic-method-function method))) + (pcase (cl--generic-method-call-con method) + ('nil met-fun) + ('curried + (funcall met-fun (or fun + (oclosure-lambda (cl--generic-nnm) (&rest args) + (apply #'cl-no-next-method generic method + args))))) + ;; FIXME: backward compatibility with old convention for `.elc' files + ;; compiled before the `curried' convention. + (_ + (lambda (&rest args) + (apply met-fun + (if fun + ;; FIXME: This sucks: passing just `next' would + ;; be a lot more efficient than the lambda+apply + ;; quasi-η, but we need this to implement the + ;; "if call-next-method is called with no + ;; arguments, then use the previous arguments". + (lambda (&rest cnm-args) + (apply fun (or cnm-args args))) + (oclosure-lambda (cl--generic-nnm) (&rest cnm-args) + (apply #'cl-no-next-method generic method + (or cnm-args args)))) + args)))))) ;; Standard CLOS name. (defalias 'cl-method-qualifiers #'cl--generic-method-qualifiers) @@ -869,11 +943,20 @@ those methods.") (setq arg-or-context `(&context . ,arg-or-context))) (unless (fboundp 'cl--generic-get-dispatcher) (require 'cl-generic)) - (let ((fun (cl--generic-get-dispatcher - `(,arg-or-context - ,@(apply #'append - (mapcar #'cl-generic-generalizers specializers)) - ,cl--generic-t-generalizer)))) + (let ((fun + ;; Let-bind cl--generic-dispatchers so we *re*compute the function + ;; from scratch, since the one in the cache may be non-compiled! + (let ((cl--generic-dispatchers (make-hash-table)) + ;; When compiling `cl-generic' during bootstrap, make sure + ;; we prefill with compiled dispatchers even though the loaded + ;; `cl-generic' is still interpreted. + (cl--generic-compiler + (if (featurep 'bytecomp) #'byte-compile cl--generic-compiler))) + (cl--generic-get-dispatcher + `(,arg-or-context + ,@(apply #'append + (mapcar #'cl-generic-generalizers specializers)) + ,cl--generic-t-generalizer))))) ;; Recompute dispatch at run-time, since the generalizers may be slightly ;; different (e.g. byte-compiled rather than interpreted). ;; FIXME: There is a risk that the run-time generalizer is not equivalent @@ -891,36 +974,9 @@ those methods.") "Standard support for :after, :before, :around, and `:extra NAME' qualifiers." (cl--generic-standard-method-combination generic methods)) -(defconst cl--generic-nnm-sample (cl--generic-no-next-method-function t t)) -(defconst cl--generic-cnm-sample - (funcall (cl--generic-build-combined-method - nil (list (cl--generic-make-method () () t #'identity))))) - (defun cl--generic-isnot-nnm-p (cnm) "Return non-nil if CNM is the function that calls `cl-no-next-method'." - ;; ¡Big Gross Ugly Hack! - ;; `next-method-p' just sucks, we should let it die. But EIEIO did support - ;; it, and some packages use it, so we need to support it. - (catch 'found - (cl-assert (function-equal cnm cl--generic-cnm-sample)) - (if (byte-code-function-p cnm) - (let ((cnm-constants (aref cnm 2)) - (sample-constants (aref cl--generic-cnm-sample 2))) - (dotimes (i (length sample-constants)) - (when (function-equal (aref sample-constants i) - cl--generic-nnm-sample) - (throw 'found - (not (function-equal (aref cnm-constants i) - cl--generic-nnm-sample)))))) - (cl-assert (eq 'closure (car-safe cl--generic-cnm-sample))) - (let ((cnm-env (cadr cnm))) - (dolist (vb (cadr cl--generic-cnm-sample)) - (when (function-equal (cdr vb) cl--generic-nnm-sample) - (throw 'found - (not (function-equal (cdar cnm-env) - cl--generic-nnm-sample)))) - (setq cnm-env (cdr cnm-env))))) - (error "Haven't found no-next-method-sample in cnm-sample"))) + (not (eq (oclosure-type cnm) 'cl--generic-nnm))) ;;; Define some pre-defined generic functions, used internally. @@ -996,9 +1052,12 @@ MET-NAME is as returned by `cl--generic-load-hist-format'." (defun cl--generic-method-info (method) (let* ((specializers (cl--generic-method-specializers method)) (qualifiers (cl--generic-method-qualifiers method)) - (uses-cnm (cl--generic-method-uses-cnm method)) + (call-con (cl--generic-method-call-con method)) (function (cl--generic-method-function method)) - (args (help-function-arglist function 'names)) + (args (help-function-arglist (if (not (eq call-con 'curried)) + function + (funcall function #'ignore)) + 'names)) (docstring (documentation function)) (qual-string (if (null qualifiers) "" @@ -1009,7 +1068,7 @@ MET-NAME is as returned by `cl--generic-load-hist-format'." (let ((split (help-split-fundoc docstring nil))) (if split (cdr split) docstring)))) (combined-args ())) - (if uses-cnm (setq args (cdr args))) + (if (eq t call-con) (setq args (cdr args))) (dolist (specializer specializers) (let ((arg (if (eq '&rest (car args)) (intern (format "arg%d" (length combined-args))) @@ -1019,6 +1078,19 @@ MET-NAME is as returned by `cl--generic-load-hist-format'." (setq combined-args (append (nreverse combined-args) args)) (list qual-string combined-args doconly))) +(defun cl--generic-upcase-formal-args (args) + (mapcar (lambda (arg) + (cond + ((symbolp arg) + (let ((name (symbol-name arg))) + (if (eq ?& (aref name 0)) arg + (intern (upcase name))))) + ((consp arg) + (cons (intern (upcase (symbol-name (car arg)))) + (cdr arg))) + (t arg))) + args)) + (add-hook 'help-fns-describe-function-functions #'cl--generic-describe) (defun cl--generic-describe (function) ;; Supposedly this is called from help-fns, so help-fns should be loaded at @@ -1035,9 +1107,20 @@ MET-NAME is as returned by `cl--generic-load-hist-format'." (insert (propertize "Implementations:\n\n" 'face 'bold)) ;; Loop over fanciful generics (dolist (method (cl--generic-method-table generic)) - (let* ((info (cl--generic-method-info method))) + (pcase-let* + ((`(,qualifiers ,args ,doc) (cl--generic-method-info method))) ;; FIXME: Add hyperlinks for the types as well. - (insert (format "%s%S" (nth 0 info) (nth 1 info))) + (let ((print-quoted nil) + (quals (if (length> qualifiers 0) + (concat (substring qualifiers + 0 (string-match " *\\'" + qualifiers)) + "\n") + ""))) + (insert (format "%s%S" + quals + (cons function + (cl--generic-upcase-formal-args args))))) (let* ((met-name (cl--generic-load-hist-format function (cl--generic-method-qualifiers method) @@ -1049,7 +1132,7 @@ MET-NAME is as returned by `cl--generic-load-hist-format'." 'help-function-def met-name file 'cl-defmethod) (insert (substitute-command-keys "'.\n")))) - (insert "\n" (or (nth 2 info) "Undocumented") "\n\n"))))))) + (insert "\n" (or doc "Undocumented") "\n\n"))))))) (defun cl--generic-specializers-apply-to-type-p (specializers type) "Return non-nil if a method with SPECIALIZERS applies to TYPE." @@ -1065,7 +1148,7 @@ MET-NAME is as returned by `cl--generic-load-hist-format'." (let ((sclass (cl--find-class specializer)) (tclass (cl--find-class type))) (when (and sclass tclass) - (member specializer (cl--generic-class-parents tclass)))))) + (member specializer (cl--class-allparents tclass)))))) (setq applies t))) applies)) @@ -1145,7 +1228,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))) @@ -1194,22 +1277,11 @@ These match if the argument is `eql' to VAL." ;; Use exactly the same code as for `typeof'. `(if ,name (type-of ,name) 'null)) -(defun cl--generic-class-parents (class) - (let ((parents ()) - (classes (list class))) - ;; BFS precedence. FIXME: Use a topological sort. - (while (let ((class (pop classes))) - (cl-pushnew (cl--class-name class) parents) - (setq classes - (append classes - (cl--class-parents class))))) - (nreverse parents))) - (defun cl--generic-struct-specializers (tag &rest _) (and (symbolp tag) (let ((class (get tag 'cl--class))) (when (cl-typep class 'cl-structure-class) - (cl--generic-class-parents class))))) + (cl--class-allparents class))))) (cl-generic-define-generalizer cl--generic-struct-generalizer 50 #'cl--generic-struct-tag @@ -1292,6 +1364,42 @@ Used internally for the (major-mode MODE) context specializers." (progn (cl-assert (null modes)) mode) `(derived-mode ,mode . ,modes)))) +;;; Dispatch on OClosure type + +;; It would make sense to put this into `oclosure.el' except that when +;; `oclosure.el' is loaded `cl-defmethod' is not available yet. + +(defun cl--generic-oclosure-tag (name &rest _) + `(oclosure-type ,name)) + +(defun cl-generic--oclosure-specializers (tag &rest _) + (and (symbolp tag) + (let ((class (cl--find-class tag))) + (when (cl-typep class 'oclosure--class) + (oclosure--class-allparents class))))) + +(cl-generic-define-generalizer cl-generic--oclosure-generalizer + ;; Give slightly higher priority than the struct specializer, so that + ;; for a generic function with methods dispatching structs and on OClosures, + ;; we first try `oclosure-type' before `type-of' since `type-of' will return + ;; non-nil for an OClosure as well. + 51 #'cl--generic-oclosure-tag + #'cl-generic--oclosure-specializers) + +(cl-defmethod cl-generic-generalizers :extra "oclosure-struct" (type) + "Support for dispatch on types defined by `oclosure-define'." + (or + (when (symbolp type) + ;; Use the "cl--struct-class*" (inlinable) functions/macros rather than + ;; the "cl-struct-*" variants which aren't inlined, so that dispatch can + ;; take place without requiring cl-lib. + (let ((class (cl--find-class type))) + (and (cl-typep class 'oclosure--class) + (list cl-generic--oclosure-generalizer)))) + (cl-call-next-method))) + +(cl--generic-prefill-dispatchers 0 oclosure) + ;;; Support for unloading. (cl-defmethod loadhist-unload-element ((x (head cl-defmethod))) diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index 8d63a3cccfa..3f40ab07605 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -114,7 +114,10 @@ a future Emacs interpreter will be able to use it.") (defmacro cl-incf (place &optional x) "Increment PLACE by X (1 by default). PLACE may be a symbol, or any generalized variable allowed by `setf'. -The return value is the incremented value of PLACE." +The return value is the incremented value of PLACE. + +If X is specified, it should be an expression that should +evaluate to a number." (declare (debug (place &optional form))) (if (symbolp place) (list 'setq place (if x (list '+ place x) (list '1+ place))) @@ -123,7 +126,10 @@ The return value is the incremented value of PLACE." (defmacro cl-decf (place &optional x) "Decrement PLACE by X (1 by default). PLACE may be a symbol, or any generalized variable allowed by `setf'. -The return value is the decremented value of PLACE." +The return value is the decremented value of PLACE. + +If X is specified, it should be an expression that should +evaluate to a number." (declare (debug cl-incf)) (if (symbolp place) (list 'setq place (if x (list '- place x) (list '1- place))) @@ -560,4 +566,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 c27a43f3baf..a9d422929f1 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -301,24 +301,31 @@ FORM is of the form (ARGS . BODY)." (t ;; `simple-args' doesn't handle all the parsing that we need, ;; so we pass the rest to cl--do-arglist which will do ;; "manual" parsing. - (let ((slen (length simple-args))) - (when (memq '&optional simple-args) - (cl-decf slen)) - (setq header + (let ((slen (length simple-args)) + (usage-str ;; Macro expansion can take place in the middle of ;; apparently harmless computation, so it should not ;; touch the match-data. (save-match-data - (cons (help-add-fundoc-usage - (if (stringp (car header)) (pop header)) - ;; Be careful with make-symbol and (back)quote, - ;; see bug#12884. - (help--docstring-quote - (let ((print-gensym nil) (print-quoted t) - (print-escape-newlines t)) - (format "%S" (cons 'fn (cl--make-usage-args - orig-args)))))) - header))) + (help--docstring-quote + (let ((print-gensym nil) (print-quoted t) + (print-escape-newlines t)) + (format "%S" (cons 'fn (cl--make-usage-args + orig-args)))))))) + (when (memq '&optional simple-args) + (cl-decf slen)) + (setq header + (cons + (if (eq :documentation (car-safe (car header))) + `(:documentation (help-add-fundoc-usage + ,(cadr (pop header)) + ,usage-str)) + (help-add-fundoc-usage + (if (stringp (car header)) (pop header)) + ;; Be careful with make-symbol and (back)quote, + ;; see bug#12884. + usage-str)) + header)) ;; FIXME: we'd want to choose an arg name for the &rest param ;; and pass that as `expr' to cl--do-arglist, but that ends up ;; generating code with a redundant let-binding, so we instead @@ -387,11 +394,17 @@ and BODY is implicitly surrounded by (cl-block NAME ...). `(iter-defun ,name ,@(cl--transform-lambda (cons args body) name))) ;; The lambda list for macros is different from that of normal lambdas. -;; Note that &environment is only allowed as first or last items in the + +;; `cl-macro-list' is shared between a few different use cases that +;; don't all support exactly the same set of special keywords: the +;; debug spec accepts hence a superset of what the macros +;; actually support. +;; For example &environment is only allowed as first or last items in the ;; top level list. (def-edebug-elem-spec 'cl-macro-list - '(([&optional "&environment" arg] + '(([&optional "&whole" arg] ; Only for compiler-macros or at lower levels. + [&optional "&environment" arg] ; Only at top-level. [&rest cl-macro-arg] [&optional ["&optional" &rest &or (cl-macro-arg &optional def-form cl-macro-arg) arg]] @@ -403,26 +416,12 @@ and BODY is implicitly surrounded by (cl-block NAME ...). &optional "&allow-other-keys"]] [&optional ["&aux" &rest &or (cl-macro-arg &optional def-form) arg]] - [&optional "&environment" arg] + [&optional "&environment" arg] ; Only at top-level. + . [&or arg nil] ; Only allowed at lower levels. ))) (def-edebug-elem-spec 'cl-macro-arg - '(&or arg cl-macro-list1)) - -(def-edebug-elem-spec 'cl-macro-list1 - '(([&optional "&whole" arg] ;; only allowed at lower levels - [&rest cl-macro-arg] - [&optional ["&optional" &rest - &or (cl-macro-arg &optional def-form cl-macro-arg) arg]] - [&optional [[&or "&rest" "&body"] cl-macro-arg]] - [&optional ["&key" [&rest - [&or ([&or (symbolp cl-macro-arg) arg] - &optional def-form cl-macro-arg) - arg]] - &optional "&allow-other-keys"]] - [&optional ["&aux" &rest - &or (cl-macro-arg &optional def-form) arg]] - . [&or arg nil]))) + '(&or arg cl-macro-list)) ;;;###autoload (defmacro cl-defmacro (name args &rest body) @@ -685,7 +684,7 @@ its argument list allows full Common Lisp conventions." (defmacro cl-destructuring-bind (args expr &rest body) "Bind the variables in ARGS to the result of EXPR and execute BODY." (declare (indent 2) - (debug (&define cl-macro-list1 def-form cl-declarations def-body))) + (debug (&define cl-macro-list def-form cl-declarations def-body))) (let* ((cl--bind-lets nil) (cl--bind-forms nil) (cl--bind-defs nil) @@ -2139,9 +2138,14 @@ Like `cl-flet' but the definitions can refer to previous ones. ;; setq the fresh new `ofargs' vars instead ;-) (let ((shadowings (mapcar (lambda (b) (if (consp b) (car b) b)) bindings))) - ;; If `var' is shadowed, then it clearly can't be - ;; tail-called any more. - (not (memq var shadowings))))) + (and + ;; If `var' is shadowed, then it clearly can't be + ;; tail-called any more. + (not (memq var shadowings)) + ;; If any of the new bindings is a dynamic + ;; variable, the body is not in tail position. + (not (delq nil (mapcar #'macroexp--dynamic-variable-p + shadowings))))))) `(,(car exp) ,bindings . ,(funcall opt-exps exps))) ((and `(condition-case ,err-var ,bodyform . ,handlers) (guard (not (eq err-var var)))) @@ -2417,14 +2421,66 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). (append bindings venv)) macroexpand-all-environment)))) (if malformed-bindings - (macroexp-warn-and-return - (format-message "Malformed `cl-symbol-macrolet' binding(s): %S" - (nreverse malformed-bindings)) - expansion) + (let ((rev-malformed-bindings (nreverse malformed-bindings))) + (macroexp-warn-and-return + (format-message "Malformed `cl-symbol-macrolet' binding(s): %S" + rev-malformed-bindings) + expansion nil nil rev-malformed-bindings)) expansion))) (unless advised (advice-remove 'macroexpand #'cl--sm-macroexpand))))) +;;;###autoload +(defmacro cl-with-gensyms (names &rest body) + "Bind each of NAMES to an uninterned symbol and evaluate BODY." + (declare (debug (sexp body)) (indent 1)) + `(let ,(cl-loop for name in names collect + `(,name (gensym (symbol-name ',name)))) + ,@body)) + +;;;###autoload +(defmacro cl-once-only (names &rest body) + "Generate code to evaluate each of NAMES just once in BODY. + +This macro helps with writing other macros. Each of names is +either (NAME FORM) or NAME, which latter means (NAME NAME). +During macroexpansion, each NAME is bound to an uninterned +symbol. The expansion evaluates each FORM and binds it to the +corresponding uninterned symbol. + +For example, consider this macro: + + (defmacro my-cons (x) + (cl-once-only (x) + \\=`(cons ,x ,x))) + +The call (my-cons (pop y)) will expand to something like this: + + (let ((g1 (pop y))) + (cons g1 g1)) + +The use of `cl-once-only' ensures that the pop is performed only +once, as intended. + +See also `macroexp-let2'." + (declare (debug (sexp body)) (indent 1)) + (setq names (mapcar #'ensure-list names)) + (let ((our-gensyms (cl-loop for _ in names collect (gensym)))) + ;; During macroexpansion, obtain a gensym for each NAME. + `(let ,(cl-loop for sym in our-gensyms collect `(,sym (gensym))) + ;; Evaluate each FORM and bind to the corresponding gensym. + ;; + ;; We require this explicit call to `list' rather than using + ;; (,,@(cl-loop ...)) due to a limitation of Elisp's backquote. + `(let ,(list + ,@(cl-loop for name in names for gensym in our-gensyms + for to-eval = (or (cadr name) (car name)) + collect ``(,,gensym ,,to-eval))) + ;; During macroexpansion, bind each NAME to its gensym. + ,(let ,(cl-loop for name in names for gensym in our-gensyms + collect `(,(car name) ,gensym)) + ,@body))))) + ;;; Multiple values. ;;;###autoload @@ -2504,7 +2560,7 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C). (push x defun-declarations-alist))) (defun cl--optimize (f _args &rest qualities) - "Serve 'cl-optimize' in function declarations. + "Serve `cl-optimize' in function declarations. Example: (defun foo (x) (declare (cl-optimize (speed 3) (safety 0))) @@ -2896,18 +2952,10 @@ To see the documentation for a defined struct type, use (debug (&define ;Makes top-level form not be wrapped. [&or symbolp - (gate + (gate ;; FIXME: Why? symbolp &rest - [&or symbolp - (&or [":conc-name" symbolp] - [":constructor" symbolp &optional cl-lambda-list] - [":copier" symbolp] - [":predicate" symbolp] - [":include" symbolp &rest sexp] ;; Not finished. - [":print-function" sexp] - [":type" symbolp] - [":named"] - [":initial-offset" natnump])])] + [&or (":constructor" &define name &optional cl-lambda-list) + sexp])] [&optional stringp] ;; All the above is for the following def-form. &rest &or symbolp (symbolp &optional def-form &rest sexp)))) @@ -3050,7 +3098,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))) @@ -3106,7 +3154,7 @@ To see the documentation for a defined struct type, use (macroexp-warn-and-return (format "Missing value for option `%S' of slot `%s' in struct %s!" (car (last desc)) slot name) - 'nil) + nil nil nil (car (last desc))) forms) (when (and (keywordp (car defaults)) (not (keywordp (car desc)))) @@ -3115,7 +3163,7 @@ To see the documentation for a defined struct type, use (macroexp-warn-and-return (format " I'll take `%s' to be an option rather than a default value." kw) - 'nil) + nil nil nil kw) forms) (push kw desc) (setcar defaults nil)))) @@ -3282,8 +3330,9 @@ the form NAME which is a shorthand for (NAME NAME)." (funcall orig pred1 (cl--defstruct-predicate t2)))) (funcall orig pred1 pred2)))) -(advice-add 'pcase--mutually-exclusive-p - :around #'cl--pcase-mutually-exclusive-p) +(when (fboundp 'advice-add) ;Not available during bootstrap. + (advice-add 'pcase--mutually-exclusive-p + :around #'cl--pcase-mutually-exclusive-p)) (defun cl-struct-sequence-type (struct-type) @@ -3354,9 +3403,11 @@ Of course, we really can't know that for sure, so it's just a heuristic." (boolean . booleanp) (bool-vector . bool-vector-p) (buffer . bufferp) + (byte-code-function . byte-code-function-p) (character . natnump) (char-table . char-table-p) (command . commandp) + (compiled-function . byte-code-function-p) (hash-table . hash-table-p) (cons . consp) (fixnum . fixnump) @@ -3365,10 +3416,12 @@ 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) (sequence . sequencep) + (subr . subrp) (string . stringp) (symbol . symbolp) (vector . vectorp) @@ -3487,7 +3540,10 @@ compiler macros are expanded repeatedly until no further expansions are possible. Unlike regular macros, BODY can decide to \"punt\" and leave the original function call alone by declaring an initial `&whole foo' parameter and then returning foo." - (declare (debug cl-defmacro) (indent 2)) + ;; Like `cl-defmacro', but with the `&whole' special case. + (declare (debug (&define name cl-macro-list + cl-declarations-or-string def-body)) + (indent 2)) (let ((p args) (res nil)) (while (consp p) (push (pop p) res)) (setq args (nconc (nreverse res) (and p (list '&rest p))))) @@ -3623,7 +3679,7 @@ The type name can then be used in `cl-typecase', `cl-check-type', etc." (define-inline cl-struct-slot-value (struct-type slot-name inst) "Return the value of slot SLOT-NAME in INST of STRUCT-TYPE. -STRUCT and SLOT-NAME are symbols. INST is a structure instance." +STRUCT-TYPE and SLOT-NAME are symbols. INST is a structure instance." (declare (side-effect-free t)) (inline-letevals (struct-type slot-name inst) (inline-quote diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index ef60b266f9e..2b32bc4844a 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -1,6 +1,6 @@ ;;; cl-preloaded.el --- Preloaded part of the CL library -*- lexical-binding: t; -*- -;; Copyright (C) 2015-2021 Free Software Foundation, Inc +;; Copyright (C) 2015-2022 Free Software Foundation, Inc ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Package: emacs @@ -53,13 +53,23 @@ (defconst cl--typeof-types ;; Hand made from the source code of `type-of'. '((integer number number-or-marker atom) - (symbol atom) (string array sequence atom) + (symbol-with-pos symbol atom) (symbol atom) (string array sequence atom) (cons list sequence) ;; Markers aren't `numberp', yet they are accepted wherever integers are ;; accepted, pretty much. (marker number-or-marker atom) (overlay atom) (float number atom) (window-configuration atom) - (process atom) (window atom) (subr atom) (compiled-function function atom) + (process atom) (window atom) + ;; FIXME: We'd want to put `function' here, but that's only true + ;; for those `subr's which aren't special forms! + (subr atom) + ;; FIXME: We should probably reverse the order between + ;; `compiled-function' and `byte-code-function' since arguably + ;; `subr' and also "compiled functions" but not "byte code functions", + ;; but it would require changing the value returned by `type-of' for + ;; byte code objects, which risks breaking existing code, which doesn't + ;; seem worth the trouble. + (compiled-function byte-code-function function atom) (module-function function atom) (buffer atom) (char-table array sequence atom) (bool-vector array sequence atom) @@ -305,6 +315,17 @@ supertypes from the most specific to least specific.") (cl-assert (cl--class-p (cl--find-class 'cl-structure-class))) (cl-assert (cl--class-p (cl--find-class 'cl-structure-object))) +(defun cl--class-allparents (class) + (let ((parents ()) + (classes (list class))) + ;; BFS precedence. FIXME: Use a topological sort. + (while (let ((class (pop classes))) + (cl-pushnew (cl--class-name class) parents) + (setq classes + (append classes + (cl--class-parents class))))) + (nreverse parents))) + ;; Make sure functions defined with cl-defsubst can be inlined even in ;; packages which do not require CL. We don't put an autoload cookie ;; directly on that function, since those cookies only go to cl-loaddefs. diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el index 2aade140e25..30d7e6525a4 100644 --- a/lisp/emacs-lisp/cl-print.el +++ b/lisp/emacs-lisp/cl-print.el @@ -221,26 +221,11 @@ into a button whose action shows the function's disassembly.") 'byte-code-function object))))) (princ ")" stream)) -;; This belongs in nadvice.el, of course, but some load-ordering issues make it -;; complicated: cl-generic uses macros from cl-macs and cl-macs uses advice-add -;; from nadvice, so nadvice needs to be loaded before cl-generic and hence -;; can't use cl-defmethod. -(cl-defmethod cl-print-object :extra "nadvice" - ((object compiled-function) stream) - (if (not (advice--p object)) - (cl-call-next-method) - (princ "#f(advice-wrapper " stream) - (when (fboundp 'advice--where) - (princ (advice--where object) stream) - (princ " " stream)) - (cl-print-object (advice--cdr object) stream) - (princ " " stream) - (cl-print-object (advice--car object) stream) - (let ((props (advice--props object))) - (when props - (princ " " stream) - (cl-print-object props stream))) - (princ ")" stream))) +;; This belongs in oclosure.el, of course, but some load-ordering issues make it +;; complicated. +(cl-defmethod cl-print-object ((object accessor) stream) + ;; FIXME: η-reduce! + (oclosure--accessor-cl-print object stream)) (cl-defmethod cl-print-object ((object cl-structure-object) stream) (if (and cl-print--depth (natnump print-level) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 65710b58c10..6451e34c42f 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2020-2022 Free Software Foundation, Inc. -;; Author: Andrea Corallo <akrl@sdf.com> +;; Author: Andrea Corallo <akrl@sdf.org> ;; Keywords: lisp ;; Package: emacs @@ -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' @@ -583,10 +588,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 @@ -633,15 +636,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) @@ -665,10 +662,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) @@ -755,10 +749,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)) @@ -802,10 +794,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)))) @@ -885,7 +875,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) '((- . +)))) @@ -1010,10 +1000,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) @@ -1069,10 +1056,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 a363bed3642..53803b38184 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2019-2022 Free Software Foundation, Inc. -;; Author: Andrea Corallo <akrl@sdf.com> +;; Author: Andrea Corallo <akrl@sdf.org> ;; Keywords: lisp ;; Package: emacs @@ -238,7 +238,7 @@ native compilation runs.") (defvar comp-curr-allocation-class 'd-default "Current allocation class. -Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") +Can be one of: `d-default', `d-impure' or `d-ephemeral'. See `comp-ctxt'.") (defconst comp-passes '(comp-spill-lap comp-limplify @@ -483,7 +483,7 @@ Useful to hook into pass checkers.") (point-min (function () integer)) (preceding-char (function () fixnum)) (previous-window (function (&optional window t t) window)) - (prin1-to-string (function (t &optional t) string)) + (prin1-to-string (function (t &optional t t) string)) (processp (function (t) boolean)) (proper-list-p (function (t) integer)) (propertize (function (string &rest t) string)) @@ -898,6 +898,8 @@ non local exit (ends with an `unreachable' insn).")) :documentation "Doc string.") (int-spec nil :type list :documentation "Interactive form.") + (command-modes nil :type list + :documentation "Command modes.") (lap () :type list :documentation "LAP assembly representation.") (ssa-status nil :type symbol @@ -942,7 +944,7 @@ CFG is mutated by a pass.") :documentation "Unique id when in SSA form.") (slot nil :type (or fixnum symbol) :documentation "Slot number in the array if a number or - 'scratch' for scratch slot.")) + `scratch' for scratch slot.")) (defun comp-mvar-type-hint-match-p (mvar type-hint) "Match MVAR against TYPE-HINT. @@ -1021,7 +1023,7 @@ To be used by all entry points." (defun comp-alloc-class-to-container (alloc-class) "Given ALLOC-CLASS, return the data container for the current context. -Assume allocation class 'd-default as default." +Assume allocation class `d-default' as default." (cl-struct-slot-value 'comp-ctxt (or alloc-class 'd-default) comp-ctxt)) (defsubst comp-add-const-to-relocs (obj) @@ -1243,6 +1245,7 @@ clashes." :c-name c-name :doc (documentation f t) :int-spec (interactive-form f) + :command-modes (command-modes f) :speed (comp-spill-speed function-name) :pure (comp-spill-decl-spec function-name 'pure)))) @@ -1282,10 +1285,12 @@ clashes." (make-comp-func-l :c-name c-name :doc (documentation form t) :int-spec (interactive-form form) + :command-modes (command-modes form) :speed (comp-ctxt-speed comp-ctxt)) (make-comp-func-d :c-name c-name :doc (documentation form t) :int-spec (interactive-form form) + :command-modes (command-modes form) :speed (comp-ctxt-speed comp-ctxt))))) (let ((lap (byte-to-native-lambda-lap (gethash (aref byte-code 1) @@ -1327,6 +1332,7 @@ clashes." (comp-func-byte-func func) byte-func (comp-func-doc func) (documentation byte-func t) (comp-func-int-spec func) (interactive-form byte-func) + (comp-func-command-modes func) (command-modes byte-func) (comp-func-c-name func) c-name (comp-func-lap func) lap (comp-func-frame-size func) (comp-byte-frame-size byte-func) @@ -1767,6 +1773,7 @@ This is responsible for generating the proper stack adjustment, when known, and the annotation emission." (declare (debug (body)) (indent defun)) + (declare-function comp-body-eff nil (body op-name sp-delta)) `(pcase op ,@(cl-loop for (op . body) in cases for sp-delta = (gethash op comp-op-stack-info) @@ -1945,7 +1952,6 @@ and the annotation emission." (byte-condition-case) ;; Obsolete (byte-temp-output-buffer-setup-OBSOLETE) (byte-temp-output-buffer-show-OBSOLETE) - (byte-unbind-all) ;; Obsolete (byte-set-marker auto) (byte-match-beginning auto) (byte-match-end auto) @@ -2079,7 +2085,8 @@ and the annotation emission." (i (hash-table-count h))) (puthash i (comp-func-doc f) h) i) - (comp-func-int-spec f))) + (comp-func-int-spec f) + (comp-func-command-modes f))) ;; This is the compilation unit it-self passed as ;; parameter. (make-comp-mvar :slot 0)))))) @@ -2122,7 +2129,8 @@ These are stored in the reloc data array." (i (hash-table-count h))) (puthash i (comp-func-doc func) h) i) - (comp-func-int-spec func))) + (comp-func-int-spec func) + (comp-func-command-modes func))) ;; This is the compilation unit it-self passed as ;; parameter. (make-comp-mvar :slot 0))))) @@ -2625,8 +2633,8 @@ TARGET-BB-SYM is the symbol name of the target block." do (comp-emit-call-cstr target insn-cell cstr))))))) (defun comp-add-cstrs (_) - "Rewrite conditional branches adding appropriate 'assume' insns. -This is introducing and placing 'assume' insns in use by fwprop + "Rewrite conditional branches adding appropriate `assume' insns. +This is introducing and placing `assume' insns in use by fwprop to propagate conditional branch test information on target basic blocks." (maphash (lambda (_ f) @@ -3088,13 +3096,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) @@ -3144,10 +3145,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)) @@ -3165,9 +3163,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 @@ -3484,7 +3482,7 @@ Return the list of m-var ids nuked." (defun comp-remove-type-hints-func () "Remove type hints from the current function. -These are substituted with a normal 'set' op." +These are substituted with a normal `set' op." (cl-loop for b being each hash-value of (comp-func-blocks comp-func) do (comp-loop-insn-in-block b @@ -3580,7 +3578,7 @@ Update all insn accordingly." ;; Symbols imported by C inlined functions. We do this here because ;; is better to add all objs to the relocation containers before we ;; compacting them. - (mapc #'comp-add-const-to-relocs '(nil t consp listp)) + (mapc #'comp-add-const-to-relocs '(nil t consp listp symbol-with-pos-p)) (let* ((d-default (comp-ctxt-d-default comp-ctxt)) (d-default-idx (comp-data-container-idx d-default)) @@ -3928,22 +3926,36 @@ display a message." (file-newer-than-file-p source-file (comp-el-to-eln-filename source-file))) do (let* ((expr `((require 'comp) - ,(when (boundp 'backtrace-line-length) - `(setf backtrace-line-length ,backtrace-line-length)) - (setf comp-file-preloaded-p ,comp-file-preloaded-p - native-compile-target-directory ,native-compile-target-directory - native-comp-speed ,native-comp-speed - native-comp-debug ,native-comp-debug - native-comp-verbose ,native-comp-verbose - comp-libgccjit-reproducer ,comp-libgccjit-reproducer - comp-async-compilation t - native-comp-eln-load-path ',native-comp-eln-load-path - native-comp-compiler-options - ',native-comp-compiler-options - native-comp-driver-options - ',native-comp-driver-options - load-path ',load-path - warning-fill-column most-positive-fixnum) + (setq comp-async-compilation t) + (setq warning-fill-column most-positive-fixnum) + ,(let ((set (list 'setq))) + (dolist (var '(comp-file-preloaded-p + native-compile-target-directory + native-comp-speed + native-comp-debug + native-comp-verbose + comp-libgccjit-reproducer + native-comp-eln-load-path + native-comp-compiler-options + native-comp-driver-options + load-path + backtrace-line-length + ;; package-load-list + ;; package-user-dir + ;; package-directory-list + )) + (when (boundp var) + (push var set) + (push `',(symbol-value var) set))) + (nreverse set)) + ;; FIXME: Activating all packages would align the + ;; functionality offered with what is usually done + ;; for ELPA packages (and thus fix some compilation + ;; issues with some ELPA packages), but it's too + ;; blunt an instrument (e.g. we don't even know if + ;; we're compiling such an ELPA package at + ;; this point). + ;;(package-activate-all) ,native-comp-async-env-modifier-form (message "Compiling %s..." ,source-file) (comp--native-compile ,source-file ,(and load t)))) @@ -3996,7 +4008,7 @@ display a message." (run-hooks 'native-comp-async-all-done-hook) (with-current-buffer (get-buffer-create comp-async-buffer-name) (save-excursion - (let ((buffer-read-only nil)) + (let ((inhibit-read-only t)) (goto-char (point-max)) (insert "Compilation finished.\n")))) ;; `comp-deferred-pending-h' should be empty at this stage. @@ -4016,56 +4028,71 @@ the deferred compilation mechanism." (signal 'native-compiler-error (list "Not a function symbol or file" function-or-file))) (catch 'no-native-compile - (let* ((data function-or-file) + (let* ((print-symbols-bare t) + (max-specpdl-size (max max-specpdl-size 5000)) + (data function-or-file) (comp-native-compiling t) (byte-native-qualities nil) + (symbols-with-pos-enabled t) ;; Have byte compiler signal an error when compilation fails. (byte-compile-debug t) (comp-ctxt (make-comp-ctxt :output output :with-late-load with-late-load))) (comp-log "\n\n" 1) - (condition-case err - (cl-loop - with report = nil - for t0 = (current-time) - for pass in comp-passes - unless (memq pass comp-disabled-passes) - do - (comp-log (format "(%s) Running pass %s:\n" - function-or-file pass) - 2) - (setf data (funcall pass data)) - (push (cons pass (float-time (time-since t0))) report) - (cl-loop for f in (alist-get pass comp-post-pass-hooks) - do (funcall f data)) - finally - (when comp-log-time-report - (comp-log (format "Done compiling %s" data) 0) - (cl-loop for (pass . time) in (reverse report) - do (comp-log (format "Pass %s took: %fs." pass time) 0)))) - (native-compiler-skip) - (t - (let ((err-val (cdr err))) - ;; If we are doing an async native compilation print the - ;; error in the correct format so is parsable and abort. - (if (and comp-async-compilation - (not (eq (car err) 'native-compiler-error))) - (progn - (message (if err-val - "%s: Error: %s %s" - "%s: Error %s") - function-or-file - (get (car err) 'error-message) - (car-safe err-val)) - (kill-emacs -1)) - ;; Otherwise re-signal it adding the compilation input. - (signal (car err) (if (consp err-val) - (cons function-or-file err-val) - (list function-or-file err-val))))))) - (if (stringp function-or-file) - data - ;; So we return the compiled function. - (native-elisp-load data))))) + (unwind-protect + (progn + (condition-case err + (cl-loop + with report = nil + for t0 = (current-time) + for pass in comp-passes + unless (memq pass comp-disabled-passes) + do + (comp-log (format "(%s) Running pass %s:\n" + function-or-file pass) + 2) + (setf data (funcall pass data)) + (push (cons pass (float-time (time-since t0))) report) + (cl-loop for f in (alist-get pass comp-post-pass-hooks) + do (funcall f data)) + finally + (when comp-log-time-report + (comp-log (format "Done compiling %s" data) 0) + (cl-loop for (pass . time) in (reverse report) + do (comp-log (format "Pass %s took: %fs." + pass time) 0)))) + (native-compiler-skip) + (t + (let ((err-val (cdr err))) + ;; If we are doing an async native compilation print the + ;; error in the correct format so is parsable and abort. + (if (and comp-async-compilation + (not (eq (car err) 'native-compiler-error))) + (progn + (message (if err-val + "%s: Error: %s %s" + "%s: Error %s") + function-or-file + (get (car err) 'error-message) + (car-safe err-val)) + (kill-emacs -1)) + ;; Otherwise re-signal it adding the compilation input. + (signal (car err) (if (consp err-val) + (cons function-or-file err-val) + (list function-or-file err-val))))))) + (if (stringp function-or-file) + data + ;; So we return the compiled function. + (native-elisp-load data))) + ;; We may have created a temporary file when we're being + ;; called with something other than a file as the argument. + ;; Delete it. + (when (and (not (stringp function-or-file)) + (not output) + comp-ctxt + (comp-ctxt-output comp-ctxt) + (file-exists-p (comp-ctxt-output comp-ctxt))) + (delete-file (comp-ctxt-output comp-ctxt))))))) (defun native-compile-async-skip-p (file load selector) "Return non-nil if FILE's compilation should be skipped. @@ -4087,6 +4114,7 @@ LOAD and SELECTOR work as described in `native--compile-async'." native-comp-deferred-compilation-deny-list)))) (defun native--compile-async (files &optional recursively load selector) + ;; BEWARE, this function is also called directly from C. "Compile FILES asynchronously. FILES is one filename or a list of filenames or directories. @@ -4120,16 +4148,17 @@ bytecode definition was not changed in the meantime)." (unless (listp files) (setf files (list files))) (let (file-list) - (dolist (path files) - (cond ((file-directory-p path) + (dolist (file-or-dir files) + (cond ((file-directory-p file-or-dir) (dolist (file (if recursively (directory-files-recursively - path comp-valid-source-re) - (directory-files path t comp-valid-source-re))) + file-or-dir comp-valid-source-re) + (directory-files file-or-dir + t comp-valid-source-re))) (push file file-list))) - ((file-exists-p path) (push path file-list)) + ((file-exists-p file-or-dir) (push file-or-dir file-list)) (t (signal 'native-compiler-error - (list "Path not a file nor directory" path))))) + (list "Not a file nor directory" file-or-dir))))) (dolist (file file-list) (if-let ((entry (cl-find file comp-files-queue :key #'car :test #'string=))) ;; Most likely the byte-compiler has requested a deferred @@ -4205,9 +4234,9 @@ last directory in `native-comp-eln-load-path')." if (or (null byte+native-compile) (cl-notany (lambda (re) (string-match re file)) native-comp-bootstrap-deny-list)) - do (comp--native-compile file) + collect (comp--native-compile file) else - do (byte-compile-file file)))) + collect (byte-compile-file file)))) ;;;###autoload (defun batch-byte+native-compile () @@ -4216,17 +4245,25 @@ Generate .elc files in addition to the .eln files. Force the produced .eln to be outputted in the eln system directory (the last entry in `native-comp-eln-load-path') unless `native-compile-target-directory' is non-nil. If the environment -variable 'NATIVE_DISABLED' is set, only byte compile." +variable \"NATIVE_DISABLED\" is set, only byte compile." (comp-ensure-native-compiler) (if (equal (getenv "NATIVE_DISABLED") "1") (batch-byte-compile) (cl-assert (length= command-line-args-left 1)) - (let ((byte+native-compile t) - (byte-to-native-output-file nil)) - (batch-native-compile) - (pcase byte-to-native-output-file - (`(,tempfile . ,target-file) - (rename-file tempfile target-file t)))))) + (let* ((byte+native-compile t) + (byte-to-native-output-buffer-file nil) + (eln-file (car (batch-native-compile)))) + (pcase byte-to-native-output-buffer-file + (`(,temp-buffer . ,target-file) + (unwind-protect + (progn + (byte-write-target-file temp-buffer target-file) + ;; Touch the .eln in order to have it older than the + ;; corresponding .elc. + (when (stringp eln-file) + (set-file-times eln-file))) + (kill-buffer temp-buffer)))) + (setq command-line-args-left (cdr command-line-args-left))))) ;;;###autoload (defun native-compile-async (files &optional recursively load selector) diff --git a/lisp/emacs-lisp/copyright.el b/lisp/emacs-lisp/copyright.el index 6b600977823..e5087672ae7 100644 --- a/lisp/emacs-lisp/copyright.el +++ b/lisp/emacs-lisp/copyright.el @@ -313,7 +313,7 @@ independently replaces consecutive years with a range." (> prev-year first-year)) (goto-char range-end) (delete-region range-start range-end) - (insert (format "%c%d" sep prev-year)) + (insert (format "-%d" prev-year)) (goto-char p)) (setq first-year year range-start (point))))) diff --git a/lisp/emacs-lisp/crm.el b/lisp/emacs-lisp/crm.el index 6bc6d217cef..8a5c3d3730c 100644 --- a/lisp/emacs-lisp/crm.el +++ b/lisp/emacs-lisp/crm.el @@ -244,30 +244,46 @@ 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) + (setq-local completion-list-insert-choice-function + (lambda (start end choice) + (if (and (stringp start) (stringp end)) + (let* ((beg (save-excursion + (goto-char (minibuffer-prompt-end)) + (or (search-forward start nil t) + (search-forward-regexp crm-separator nil t) + (minibuffer-prompt-end)))) + (end (save-excursion + (goto-char (point-max)) + (or (search-backward end nil t) + (progn + (goto-char beg) + (search-forward-regexp crm-separator nil t)) + (point-max))))) + (completion--replace beg end choice)) + (completion--replace start end choice)))) + ;; 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-early.el b/lisp/emacs-lisp/debug-early.el new file mode 100644 index 00000000000..4f1f4b81557 --- /dev/null +++ b/lisp/emacs-lisp/debug-early.el @@ -0,0 +1,91 @@ +;;; debug-early.el --- Dump a Lisp backtrace without frills -*- lexical-binding: t; -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; Author: Alan Mackenzie <acm@muc.de> +;; Maintainer: emacs-devel@gnu.org +;; Keywords: internal, backtrace, bootstrap. +;; Package: emacs + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This file dumps a backtrace on stderr when an error is thrown. It +;; has no dependencies on any Lisp libraries and is thus used for +;; generating backtraces for bugs in the early parts of bootstrapping. +;; It is also always used in batch model. It was introduced in Emacs +;; 29, before which there was no backtrace available during early +;; bootstrap. + +;;; Code: + +(defalias 'debug-early-backtrace + #'(lambda () + "Print a trace of Lisp function calls currently active. +The output stream used is the value of `standard-output'. + +This is a simplified version of the standard `backtrace' +function, intended for use in debugging the early parts +of the build process." + (princ "\n") + (let ((print-escape-newlines t) + (print-escape-control-characters t) + (print-escape-nonascii t) + (prin1 (if (fboundp 'cl-prin1) #'cl-prin1 #'prin1))) + (mapbacktrace + #'(lambda (evald func args _flags) + (let ((args args)) + (if evald + (progn + (princ " ") + (funcall prin1 func) + (princ "(")) + (progn + (princ " (") + (setq args (cons func args)))) + (if args + (while (progn + (funcall prin1 (car args)) + (setq args (cdr args))) + (princ " "))) + (princ ")\n"))))))) + +(defalias 'debug-early + #'(lambda (&rest args) + "Print an error message with a backtrace of active Lisp function calls. +The output stream used is the value of `standard-output'. + +The Emacs core calls this function after an error has been +signaled, and supplies two ARGS. These are the symbol +`error' (which is ignored) and a cons of the error symbol and the +error data. + +`debug-early' is a simplified version of `debug', and is +available during the early parts of the build process. It is +superseded by `debug' after enough Lisp has been loaded to +support the latter, except in batch mode which always uses +`debug-early'. + +\(In versions of Emacs prior to Emacs 29, no backtrace was +available before `debug' was usable.)" + (princ "\nError: ") + (prin1 (car (car (cdr args)))) ; The error symbol. + (princ " ") + (prin1 (cdr (car (cdr args)))) ; The error data. + (debug-early-backtrace))) + +;;; debug-early.el ends here. diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index 2d2da41c0d3..6c172d6c31d 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -90,6 +90,11 @@ The value used here is passed to `quit-restore-window'." :group 'debugger :version "24.3") +(defcustom debug-allow-recursive-debug nil + "If non-nil, erroring in debug and edebug won't recursively debug." + :type 'boolean + :version "29.1") + (defvar debugger-step-after-exit nil "Non-nil means \"single-step\" after the debugger exits.") @@ -534,11 +539,23 @@ The environment used is the one when entering the activation frame at point." (error 0)))) ;; If on first line. (base (debugger--backtrace-base))) (debugger-env-macro - (let ((val (backtrace-eval exp nframe base))) - (prog1 - (debugger--print val t) - (let ((str (eval-expression-print-format val))) - (if str (princ str t)))))))) + (let* ((errored nil) + (val (if debug-allow-recursive-debug + (backtrace-eval exp nframe base) + (condition-case err + (backtrace-eval exp nframe base) + (error (setq errored + (format "%s: %s" + (get (car err) 'error-message) + (car (cdr err))))))))) + (if errored + (progn + (message "Error: %s" errored) + nil) + (prog1 + (debugger--print val t) + (let ((str (eval-expression-print-format val))) + (if str (princ str t))))))))) (define-obsolete-function-alias 'debugger-toggle-locals 'backtrace-toggle-locals "28.1") @@ -701,7 +718,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 +822,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 72f49bf3baf..8912eb10cc5 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 1d93fe48014..54cac116168 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -82,11 +82,9 @@ replacing its case-insensitive matches with the literal string in LIGHTER." (replace-regexp-in-string (regexp-quote lighter) lighter name t t)))) (defconst easy-mmode--arg-docstring - " - -This is a minor mode. If called interactively, toggle the `%s' -mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. + "This is a %sminor mode. If called interactively, toggle the +`%s' 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. @@ -99,28 +97,50 @@ The mode's hook is called both when the mode is enabled and when it is disabled.") (defun easy-mmode--mode-docstring (doc mode-pretty-name keymap-sym - getter) - (let ((doc (or doc (format "Toggle %s on or off. - -\\{%s}" mode-pretty-name keymap-sym)))) - (if (string-match-p "\\bARG\\b" doc) - doc - (let* ((fill-prefix nil) - (docs-fc (bound-and-true-p emacs-lisp-docstring-fill-column)) - (fill-column (if (integerp docs-fc) docs-fc 65)) - (argdoc (format easy-mmode--arg-docstring mode-pretty-name - ;; Avoid having quotes turn into pretty quotes. - (string-replace "'" "\\\\='" - (format "%S" getter)))) - (filled (if (fboundp 'fill-region) - (with-temp-buffer - (insert argdoc) - (fill-region (point-min) (point-max) 'left t) - (buffer-string)) - argdoc))) - (replace-regexp-in-string "\\(\n\n\\|\\'\\)\\(.\\|\n\\)*\\'" - (concat filled "\\1") - doc nil nil 1))))) + getter global) + ;; If we have a doc string, and it's already complete (which we + ;; guess at with the simple heuristic below), then just return that + ;; as is. + (if (and doc (string-match-p "\\bARG\\b" doc)) + doc + ;; Compose a new doc string. + (with-temp-buffer + (let ((lines (if doc + (string-lines doc) + (list (format "Toggle %s on or off." mode-pretty-name))))) + ;; Insert the first line from the doc string. + (insert (pop lines)) + ;; Ensure that we have (only) one blank line after the first + ;; line. + (ensure-empty-lines) + (while (and lines + (equal (car lines) "")) + (pop lines)) + ;; Insert the doc string. + (dolist (line lines) + (insert line "\n")) + (ensure-empty-lines) + ;; Insert the boilerplate. + (let* ((fill-prefix nil) + (docs-fc (bound-and-true-p emacs-lisp-docstring-fill-column)) + (fill-column (if (integerp docs-fc) docs-fc 65)) + (argdoc (format + easy-mmode--arg-docstring + (if global "global " "") + mode-pretty-name + ;; Avoid having quotes turn into pretty quotes. + (string-replace "'" "\\='" (format "%S" getter))))) + (let ((start (point))) + (insert argdoc) + (when (fboundp 'fill-region) + (fill-region start (point) 'left t)))) + ;; Finally, insert the keymap. + (when (and (boundp keymap-sym) + (or (not doc) + (not (string-search "\\{" doc)))) + (ensure-empty-lines) + (insert (format "\\{%s}" keymap-sym))) + (buffer-string))))) ;;;###autoload (defalias 'easy-mmode-define-minor-mode #'define-minor-mode) @@ -198,6 +218,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 @@ -316,7 +337,7 @@ or call the function `%s'.")))) warnwrap `(defun ,modefun (&optional arg ,@extra-args) ,(easy-mmode--mode-docstring doc pretty-name keymap-sym - getter) + getter globalp) ,(when interactive ;; Use `toggle' rather than (if ,mode 0 1) so that using ;; repeat-command still does the toggling correctly. @@ -450,7 +471,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)) @@ -695,8 +716,12 @@ Valid keywords and arguments are: (defmacro easy-mmode-defmap (m bs doc &rest args) "Define a constant M whose value is the result of `easy-mmode-define-keymap'. The M, BS, and ARGS arguments are as per that function. DOC is -the constant's documentation." - (declare (indent 1)) +the constant's documentation. + +This macro is deprecated; use `defvar-keymap' instead." + ;; FIXME: Declare obsolete in favor of `defvar-keymap'. It is still + ;; used for `gud-menu-map' and `gud-minor-mode-map', so fix that first. + (declare (doc-string 3) (indent 1)) `(defconst ,m (easy-mmode-define-keymap ,bs nil (if (boundp ',m) ,m) ,(cons 'list args)) ,doc)) @@ -723,7 +748,7 @@ the constant's documentation." (defmacro easy-mmode-defsyntax (st css doc &rest args) "Define variable ST as a syntax-table. CSS contains a list of syntax specifications of the form (CHAR . SYNTAX)." - (declare (indent 1)) + (declare (doc-string 3) (indent 1)) `(progn (autoload 'easy-mmode-define-syntax "easy-mmode") (defconst ,st (easy-mmode-define-syntax ,css ,(cons 'list args)) ,doc))) @@ -800,7 +825,6 @@ Interactively, COUNT is the prefix numeric argument, and defaults to 1." ,@body)) (put ',prev-sym 'definition-name ',base)))) - (provide 'easy-mmode) ;;; easy-mmode.el ends here diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 32dc600a1ab..9dc5a1315e5 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -41,7 +41,7 @@ ;; See the Emacs Lisp Reference Manual for more details. ;; If you wish to change the default edebug global command prefix, change: -;; (setq global-edebug-prefix "\C-xX") +;; (setq edebug-global-prefix "\C-xX") ;; Edebug was written by ;; Daniel LaLiberte @@ -57,6 +57,7 @@ (require 'cl-lib) (require 'seq) (eval-when-compile (require 'pcase)) +(require 'debug) ;;; Options @@ -98,7 +99,11 @@ This applies to `eval-defun', `eval-region', `eval-buffer', and You can use the command `edebug-all-defs' to toggle the value of this variable. You may wish to make it local to each buffer with \(make-local-variable \\='edebug-all-defs) in your -`emacs-lisp-mode-hook'." +`emacs-lisp-mode-hook'. + +Note that this user option has no effect unless the edebug +package has been loaded." + :require 'edebug :type 'boolean) ;;;###autoload @@ -2573,6 +2578,13 @@ See `edebug-behavior-alist' for implementations.") ;; Let's at least show a backtrace so the user can figure out ;; which function we're talking about. (debug)) + ;; If we're in a `track-mouse' setting, then any previous mouse + ;; movements will make `input-pending-p' later return true. So + ;; discard the inputs in that case. (And `discard-input' doesn't + ;; work here.) + (when track-mouse + (while (input-pending-p) + (read-event))) ;; Setup windows for edebug, determine mode, maybe enter recursive-edit. ;; Uses local variables of edebug-enter, edebug-before, edebug-after ;; and edebug-debugger. @@ -3519,7 +3531,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'")) @@ -3699,12 +3712,25 @@ Return the result of the last expression." If interactive, prompt for the expression. Print result in minibuffer." (interactive (list (read--expression "Eval: "))) - (princ - (edebug-outside-excursion - (let ((result (edebug-eval expr))) - (values--store-value result) - (concat (edebug-safe-prin1-to-string result) - (eval-expression-print-format result)))))) + (let* ((errored nil) + (result + (edebug-outside-excursion + (let ((result (if debug-allow-recursive-debug + (edebug-eval expr) + (condition-case err + (edebug-eval expr) + (error + (setq errored + (format "%s: %s" + (get (car err) 'error-message) + (car (cdr err))))))))) + (unless errored + (values--store-value result) + (concat (edebug-safe-prin1-to-string result) + (eval-expression-print-format result))))))) + (if errored + (message "Error: %s" errored) + (princ result)))) (defun edebug-eval-last-sexp (&optional no-truncate) "Evaluate sexp before point in the outside environment. @@ -3839,7 +3865,10 @@ be installed in `emacs-lisp-mode-map'.") (define-obsolete-variable-alias 'global-edebug-prefix 'edebug-global-prefix "28.1") -(defvar edebug-global-prefix "\^XX" +(defvar edebug-global-prefix + (when-let ((binding + (car (where-is-internal 'Control-X-prefix (list global-map))))) + (concat binding [?X])) "Prefix key for global edebug commands, available from any buffer.") (define-obsolete-variable-alias 'global-edebug-map @@ -4548,7 +4577,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-core.el b/lisp/emacs-lisp/eieio-core.el index 196747d71a7..d687289b22f 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -92,7 +92,7 @@ Currently under control of this var: (:copier nil)) children initarg-tuples ;; initarg tuples list - (class-slots nil :type eieio--slot) + (class-slots nil :type (vector-of eieio--slot)) class-allocation-values ;; class allocated value vector default-object-cache ;; what a newly created object would look like. ; This will speed up instantiation time as @@ -130,10 +130,7 @@ Currently under control of this var: class)) (defsubst eieio--object-class (obj) - (let ((tag (eieio--object-class-tag obj))) - (if eieio-backward-compatibility - (eieio--class-object tag) - tag))) + (eieio--class-object (eieio--object-class-tag obj))) (defun class-p (x) "Return non-nil if X is a valid class vector. @@ -215,7 +212,7 @@ It creates an autoload function for CNAME's constructor." (when eieio-backward-compatibility (set cname cname) (make-obsolete-variable cname (format "\ -use \\='%s or turn off `eieio-backward-compatibility' instead" cname) +use '%s or turn off `eieio-backward-compatibility' instead" cname) "25.1")) (setf (cl--find-class cname) newc) @@ -265,6 +262,10 @@ use \\='%s or turn off `eieio-backward-compatibility' instead" cname) (defvar eieio--known-slot-names nil) (defvar eieio--known-class-slot-names nil) +(defun eieio--known-slot-name-p (name) + (or (memq name eieio--known-slot-names) + (get name 'slot-name))) + (defun eieio-defclass-internal (cname superclasses slots options) "Define CNAME as a new subclass of SUPERCLASSES. SLOTS are the slots residing in that class definition, and OPTIONS @@ -340,7 +341,7 @@ See `defclass' for more information." ;; turn this into a usable self-pointing symbol; FIXME: Why? (when eieio-backward-compatibility (set cname cname) - (make-obsolete-variable cname (format "use \\='%s instead" cname) + (make-obsolete-variable cname (format "use '%s instead" cname) "25.1")) ;; Create a handy list of the class test too @@ -362,7 +363,7 @@ See `defclass' for more information." (setq obj (cdr obj))) ans)))) (make-obsolete csym (format - "use (cl-typep ... \\='(list-of %s)) instead" + "use (cl-typep ... '(list-of %s)) instead" cname) "25.1"))) @@ -420,7 +421,7 @@ See `defclass' for more information." (progn (set initarg initarg) (make-obsolete-variable - initarg (format "use \\='%s instead" initarg) "25.1")))) + initarg (format "use '%s instead" initarg) "25.1")))) ;; The customgroup should be a list of symbols. (cond ((and (null customg) custom) @@ -450,7 +451,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 +479,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 +510,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 +705,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 (cl--class-name class) slot st value))) + ((alist-get :read-only (cl--slot-descriptor-props sd)) + (signal 'eieio-read-only (list (cl--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. @@ -719,7 +726,7 @@ an error." slot-idx)))) (if (not (eieio--perform-slot-validation st value)) (signal 'invalid-slot-type - (list (eieio--class-name class) slot st value)))))) + (list (cl--class-name class) slot st value)))))) (defun eieio-barf-if-slot-unbound (value instance slotname fn) "Throw a signal if VALUE is a representation of an UNBOUND slot. @@ -740,31 +747,35 @@ Argument FN is the function calling this verifier." (ignore obj) (pcase slot ((and (or `',name (and name (pred keywordp))) - (guard (not (memq name eieio--known-slot-names)))) + (guard (not (eieio--known-slot-name-p name)))) (macroexp-warn-and-return (format-message "Unknown slot `%S'" name) - exp nil 'compile-only)) + exp nil 'compile-only name)) (_ exp)))) + ;; FIXME: Make it a gv-expander such that the hash-table lookup is + ;; only performed once when used in `push' and friends? (gv-setter eieio-oset)) (cl-check-type slot symbol) - (cl-check-type obj (or eieio-object class)) - (let* ((class (cond ((symbolp obj) - (error "eieio-oref called on a class: %s" obj) - (eieio--full-class-object obj)) - (t (eieio--object-class obj)))) - (c (eieio--slot-name-index class slot))) - (if (not c) - ;; It might be missing because it is a :class allocated slot. - ;; Let's check that info out. - (if (setq c (eieio--class-slot-name-index class slot)) - ;; Oref that slot. - (aref (eieio--class-class-allocation-values class) c) - ;; The slot-missing method is a cool way of allowing an object author - ;; 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) - (eieio-barf-if-slot-unbound (aref obj c) obj slot 'oref)))) + (cond + ((cl-typep obj '(or eieio-object cl-structure-object)) + (let* ((class (eieio--object-class obj)) + (c (eieio--slot-name-index class slot))) + (if (not c) + ;; It might be missing because it is a :class allocated slot. + ;; Let's check that info out. + (if (setq c (eieio--class-slot-name-index class slot)) + ;; Oref that slot. + (aref (eieio--class-class-allocation-values class) c) + ;; The slot-missing method is a cool way of allowing an object author + ;; 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)) + (eieio-barf-if-slot-unbound (aref obj c) obj slot 'oref)))) + ((cl-typep obj 'oclosure) (oclosure--slot-value obj slot)) + (t + (signal 'wrong-type-argument + (list '(or eieio-object cl-structure-object oclosure) obj))))) + (defun eieio-oref-default (class slot) @@ -776,15 +787,15 @@ Fills in CLASS's SLOT with its default value." (ignore class) (pcase slot ((and (or `',name (and name (pred keywordp))) - (guard (not (memq name eieio--known-slot-names)))) + (guard (not (eieio--known-slot-name-p name)))) (macroexp-warn-and-return (format-message "Unknown slot `%S'" name) - exp nil 'compile-only)) + exp nil 'compile-only name)) ((and (or `',name (and name (pred keywordp))) (guard (not (memq name eieio--known-class-slot-names)))) (macroexp-warn-and-return (format-message "Slot `%S' is not class-allocated" name) - exp nil 'compile-only)) + exp nil 'compile-only name)) (_ exp))))) (cl-check-type class (or eieio-object class)) (cl-check-type slot symbol) @@ -811,24 +822,29 @@ 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 slot symbol) - (let* ((class (eieio--object-class obj)) - (c (eieio--slot-name-index class slot))) - (if (not c) - ;; It might be missing because it is a :class allocated slot. - ;; Let's check that info out. - (if (setq c - (eieio--class-slot-name-index class slot)) - ;; Oset that slot. - (progn - (eieio--validate-class-slot-value class c value slot) - (aset (eieio--class-class-allocation-values class) - c value)) - ;; See oref for comment on `slot-missing' - (slot-missing obj slot 'oset value)) - (eieio--validate-slot-value class c value slot) - (aset obj c value)))) + (cond + ((cl-typep obj '(or eieio-object cl-structure-object)) + (let* ((class (eieio--object-class obj)) + (c (eieio--slot-name-index class slot))) + (if (not c) + ;; It might be missing because it is a :class allocated slot. + ;; Let's check that info out. + (if (setq c + (eieio--class-slot-name-index class slot)) + ;; Oset that slot. + (progn + (eieio--validate-class-slot-value class c value slot) + (aset (eieio--class-class-allocation-values class) + c value)) + ;; See oref for comment on `slot-missing' + (slot-missing obj slot 'oset value)) + (eieio--validate-slot-value class c value slot) + (aset obj c value)))) + ((cl-typep obj 'oclosure) (oclosure--set-slot-value obj slot value)) + (t + (signal 'wrong-type-argument + (list '(or eieio-object cl-structure-object oclosure) obj))))) (defun eieio-oset-default (class slot value) "Do the work for the macro `oset-default'. @@ -838,15 +854,15 @@ Fills in the default value in CLASS' in SLOT with VALUE." (ignore class value) (pcase slot ((and (or `',name (and name (pred keywordp))) - (guard (not (memq name eieio--known-slot-names)))) + (guard (not (eieio--known-slot-name-p name)))) (macroexp-warn-and-return (format-message "Unknown slot `%S'" name) - exp nil 'compile-only)) + exp nil 'compile-only name)) ((and (or `',name (and name (pred keywordp))) (guard (not (memq name eieio--known-class-slot-names)))) (macroexp-warn-and-return (format-message "Slot `%S' is not class-allocated" name) - exp nil 'compile-only)) + exp nil 'compile-only name)) (_ exp))))) (setq class (eieio--class-object class)) (cl-check-type class eieio--class) @@ -861,7 +877,7 @@ Fills in the default value in CLASS' in SLOT with VALUE." (eieio--validate-class-slot-value class c value slot) (aset (eieio--class-class-allocation-values class) c value)) - (signal 'invalid-slot-name (list (eieio--class-name class) slot))) + (signal 'invalid-slot-name (list (cl--class-name class) slot))) ;; `oset-default' on an instance-allocated slot is allowed by EIEIO but ;; not by CLOS and is mildly inconsistent with the :initform thingy, so ;; it'd be nice to get rid of it. @@ -890,9 +906,9 @@ The slot is a symbol which is installed in CLASS by the `defclass' call. If SLOT is the value created with :initarg instead, 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)))) + (let* ((fsi (gethash slot (cl--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 +1077,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 c7e7384144c..72108f807f9 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 3b633e4fa36..1315ca0c627 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)) @@ -181,9 +181,11 @@ and reference them using the function `class-option'." ;; Is there an initarg, but allocation of class? (when (and initarg (eq alloc :class)) - (push (format "Meaningless :initarg for class allocated slot '%S'" - sname) - warnings)) + (push + (cons sname + (format "Meaningless :initarg for class allocated slot '%S'" + sname)) + warnings)) (let ((init (plist-get soptions :initform))) (unless (or (macroexp-const-p init) @@ -194,8 +196,9 @@ and reference them using the function `class-option'." ;; heuristic says and if it disagrees with normal evaluation ;; then tweak the initform to make it fit and emit ;; a warning accordingly. - (push (format "Ambiguous initform needs quoting: %S" init) - warnings))) + (push + (cons init (format "Ambiguous initform needs quoting: %S" init)) + warnings))) ;; Anyone can have an accessor function. This creates a function ;; of the specified name, and also performs a `defsetf' if applicable @@ -242,7 +245,8 @@ This method is obsolete." `(progn ,@(mapcar (lambda (w) - (macroexp-warn-and-return w `(progn ',w) nil 'compile-only)) + (macroexp-warn-and-return + (cdr w) `(progn ',(cdr w)) nil 'compile-only (car w))) warnings) ;; This test must be created right away so we can have self- ;; referencing classes. ei, a class whose slot can contain only @@ -256,7 +260,7 @@ This method is obsolete." (let ((f (intern (format "%s-child-p" name)))) `((defalias ',f #',testsym2) (make-obsolete - ',f ,(format "use (cl-typep ... \\='%s) instead" name) + ',f ,(format "use (cl-typep ... '%s) instead" name) "25.1")))) ;; When using typep, (typep OBJ 'myclass) returns t for objects which @@ -297,7 +301,8 @@ This method is obsolete." ;; Keep the name arg, for backward compatibility, ;; but hide it so we don't trigger indefinitely. `(,(car whole) (identity ,(car slots)) - ,@(cdr slots))))))) + ,@(cdr slots)) + nil nil (car slots)))))) (apply #'make-instance ',name slots)))))) @@ -359,9 +364,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 +997,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 5300b0594d2..0b8078579cc 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -5,7 +5,7 @@ ;; Author: Noah Friedman <friedman@splode.com> ;; Keywords: extensions ;; Created: 1995-10-06 -;; Version: 1.11.0 +;; Version: 1.12.0 ;; Package-Requires: ((emacs "26.3")) ;; This is a GNU ELPA :core package. Avoid functionality that is not @@ -102,7 +102,7 @@ put in the echo area. If a positive integer, the number is used directly, while a float specifies the number of lines as a proportion of the echo area frame's height. -If value is the symbol `truncate-sym-name-if-fit' t, the part of +If value is the symbol `truncate-sym-name-if-fit', the part of the doc string that represents a symbol's name may be truncated if it will enable the rest of the doc string to fit on a single line, without resizing the echo area. @@ -380,7 +380,19 @@ 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 + ;; There's no conflict with the child-frame and + ;; overlay versions. + (not (memq show-paren-context-when-offscreen + '(child-frame overlay))) + (not (pos-visible-in-window-p + (overlay-end show-paren--overlay))))))) (defvar eldoc-documentation-functions nil @@ -452,19 +464,22 @@ directly from the user or from ElDoc's automatic mechanisms'.") (defvar eldoc--doc-buffer-docs nil "Documentation items in `eldoc--doc-buffer'.") -(defun eldoc-doc-buffer () - "Display ElDoc documentation buffer. +(defun eldoc-doc-buffer (&optional interactive) + "Get or display ElDoc documentation buffer. -This holds the results of the last documentation request." - (interactive) +The buffer holds the results of the last documentation request. +If INTERACTIVE, display it. Else, return said buffer." + (interactive (list t)) (unless (buffer-live-p eldoc--doc-buffer) (user-error (format "ElDoc buffer doesn't exist, maybe `%s' to produce one." (substitute-command-keys "\\[eldoc]")))) (with-current-buffer eldoc--doc-buffer - (rename-buffer (replace-regexp-in-string "^ *" "" - (buffer-name))) - (display-buffer (current-buffer)))) + (cond (interactive + (rename-buffer (replace-regexp-in-string "^ *" "" + (buffer-name))) + (display-buffer (current-buffer))) + (t (current-buffer))))) (defun eldoc--format-doc-buffer (docs) "Ensure DOCS are displayed in an *eldoc* buffer." @@ -513,7 +528,8 @@ Helper for `eldoc-display-in-echo-area'." (goto-char (point-min)) (skip-chars-forward " \t\n") (point)) - (goto-char (line-end-position available)) + (forward-visible-line (1- available)) + (end-of-visible-line) (skip-chars-backward " \t\n"))) (truncated (save-excursion (skip-chars-forward " \t\n") @@ -523,7 +539,8 @@ Helper for `eldoc-display-in-echo-area'." ((and truncated (> available 1) eldoc-echo-area-display-truncation-message) - (goto-char (line-end-position 0)) + (forward-visible-line -1) + (end-of-visible-line) (concat (buffer-substring start (point)) (format "\n(Documentation truncated. Use `%s' to see rest)" @@ -598,7 +615,8 @@ Honor `eldoc-echo-area-use-multiline-p' and (let ((string (with-current-buffer (eldoc--format-doc-buffer docs) (buffer-substring (goto-char (point-min)) - (line-end-position 1))))) + (progn (end-of-visible-line) + (point)))))) (if (> (length string) width) ; truncation to happen (unless (eldoc--echo-area-prefer-doc-buffer-p t) (truncate-string-to-width string width)) diff --git a/lisp/emacs-lisp/elp.el b/lisp/emacs-lisp/elp.el index 4b20e8f756c..385ddb3f414 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.") @@ -288,7 +287,12 @@ type \"nil\" to use `elp-function-list'." "Instrument for profiling, all functions which start with PREFIX. For example, to instrument all ELP functions, do the following: - \\[elp-instrument-package] RET elp- RET" + \\[elp-instrument-package] RET elp- RET + +Note that only functions that are currently loaded will be +instrumented. If you run this function, and then later load +further functions that start with PREFIX, they will not be +instrumented automatically." (interactive (list (completing-read "Prefix of package to instrument: " obarray 'elp-profilable-p))) @@ -299,10 +303,18 @@ For example, to instrument all ELP functions, do the following: 'intern (all-completions prefix obarray 'elp-profilable-p)))) +(defun elp-restore-package (prefix) + "Remove instrumentation from functions with names starting with PREFIX." + (interactive "SPrefix: ") + (elp-restore-list + (mapcar #'intern + (all-completions (symbol-name prefix) + obarray 'elp-profilable-p)))) + (defun elp-restore-list (&optional list) "Restore the original definitions for all functions in `elp-function-list'. Use optional LIST if provided instead." - (interactive "PList of functions to restore: ") ;FIXME: Doesn't work!? + (interactive) (mapcar #'elp-restore-function (or list elp-function-list))) (defun elp-restore-all () @@ -324,7 +336,7 @@ Use optional LIST if provided instead." (defun elp-reset-list (&optional list) "Reset the profiling information for all functions in `elp-function-list'. Use optional LIST if provided instead." - (interactive "PList of functions to reset: ") ;FIXME: Doesn't work!? + (interactive) (let ((list (or list elp-function-list))) (mapcar 'elp-reset-function list))) diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el index 12534c7c4ce..0180e9e53cc 100644 --- a/lisp/emacs-lisp/ert-x.el +++ b/lisp/emacs-lisp/ert-x.el @@ -338,7 +338,8 @@ unless the output is going to the echo area (when PRINTCHARFUN is t or PRINTCHARFUN is nil and `standard-output' is t). If the output is destined for the echo area, the advice function will convert it to a string and pass it to COLLECTOR first." - (lambda (func object &optional printcharfun) + ;;; FIXME: Pass on OVERRIDES. + (lambda (func object &optional printcharfun _overrides) (if (not (eq t (or printcharfun standard-output))) (funcall func object printcharfun) (funcall collector (with-output-to-string @@ -352,7 +353,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 +368,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 +386,111 @@ 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. + +:coding CODING If non-nil, bind `coding-system-for-write' to CODING + when executing BODY. This is handy when STRING includes + non-ASCII characters or the temporary file must have a + specific encoding or end-of-line format. + +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 coding) + (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))) + (:coding (setq coding (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* ((coding-system-for-write ,(or coding coding-system-for-write)) + (,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)) + +(defun ert-gcc-is-clang-p () + "Return non-nil if the `gcc' command actually runs the Clang compiler." + ;; Some macOS machines run llvm when you type gcc. (!) + ;; We can't even check if it's a symlink; it's a binary placed in + ;; "/usr/bin/gcc". So we need to check the output. + (string-match "Apple \\(LLVM\\|[Cc]lang\\)\\|Xcode\\.app" + (shell-command-to-string "gcc --version"))) + (provide 'ert-x) ;;; ert-x.el ends here diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 41180f9914a..82722add42a 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -39,7 +39,7 @@ ;; but signals a different error when its condition is violated that ;; is caught and processed by ERT. In addition, it analyzes its ;; argument form and records information that helps debugging -;; (`assert' tries to do something similar when its second argument +;; (`cl-assert' tries to do something similar when its second argument ;; SHOW-ARGS is true, but `should' is more sophisticated). For ;; information on `should-not' and `should-error', see their ;; docstrings. `skip-unless' skips the test immediately without @@ -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. @@ -114,7 +129,8 @@ Emacs bug 6581 at URL `https://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'." (body (cl-assert nil)) (most-recent-result nil) (expected-result-type ':passed) - (tags '())) + (tags '()) + (file-name nil)) (defun ert-test-boundp (symbol) "Return non-nil if SYMBOL names a test." @@ -136,6 +152,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 +211,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 +241,8 @@ 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) + :file-name ,(or (macroexp-file-name) buffer-file-name))) ',name)))) (defvar ert--find-test-regexp @@ -231,7 +251,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") @@ -318,15 +337,20 @@ It should only be stopped when ran from inside `ert--run-test-internal'." (unless (eql ,value ',default-value) (list :value ,value)) (unless (eql ,value ',default-value) - (let ((-explainer- - (and (symbolp ',fn-name) - (get ',fn-name 'ert-explainer)))) - (when -explainer- - (list :explanation - (apply -explainer- ,args)))))) + (when-let ((-explainer- + (ert--get-explainer ',fn-name))) + (list :explanation + (apply -explainer- ,args))))) value) ,value)))))))) +(defun ert--get-explainer (fn-name) + (when (symbolp fn-name) + (cl-loop for fn in (cons fn-name (function-alias-p fn-name)) + for explainer = (get fn 'ert-explainer) + when explainer + return explainer))) + (defun ert--expand-should (whole form inner-expander) "Helper function for the `should' macro and its variants. @@ -469,7 +493,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 +626,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 +650,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 +685,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 +799,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) @@ -936,7 +957,8 @@ t -- Selects UNIVERSE. :expected, :unexpected -- Select tests according to their most recent result. a string -- A regular expression selecting all tests with matching names. a test -- (i.e., an object of the ert-test data-type) Selects that test. -a symbol -- Selects the test that the symbol names, errors if none. +a symbol -- Selects the test that the symbol names, signals an + `ert-test-unbound' error if none. \(member TESTS...) -- Selects the elements of TESTS, a list of tests or symbols naming tests. \(eql TEST) -- Selects TEST, a test or a symbol naming a test. @@ -998,52 +1020,47 @@ contained in UNIVERSE." universe)))) ((pred ert-test-p) (list selector)) ((pred symbolp) - (cl-assert (ert-test-boundp selector)) + (unless (ert-test-boundp selector) + (signal 'ert-test-unbound (list selector))) (list (ert-get-test selector))) - (`(,operator . ,operands) - (cl-ecase operator - (member - (mapcar (lambda (purported-test) - (pcase-exhaustive purported-test - ((pred symbolp) - (cl-assert (ert-test-boundp purported-test)) - (ert-get-test purported-test)) - ((pred ert-test-p) purported-test))) - operands)) - (eql - (cl-assert (eql (length operands) 1)) - (ert-select-tests `(member ,@operands) universe)) - (and - ;; Do these definitions of AND, NOT and OR satisfy de - ;; Morgan's laws? Should they? - (cl-case (length operands) - (0 (ert-select-tests 't universe)) - (t (ert-select-tests `(and ,@(cdr operands)) - (ert-select-tests (car operands) - universe))))) - (not - (cl-assert (eql (length operands) 1)) - (let ((all-tests (ert-select-tests 't universe))) - (cl-set-difference all-tests - (ert-select-tests (car operands) - all-tests)))) - (or - (cl-case (length operands) - (0 (ert-select-tests 'nil universe)) - (t (cl-union (ert-select-tests (car operands) universe) - (ert-select-tests `(or ,@(cdr operands)) - universe))))) - (tag - (cl-assert (eql (length operands) 1)) - (let ((tag (car operands))) - (ert-select-tests `(satisfies - ,(lambda (test) - (member tag (ert-test-tags test)))) - universe))) - (satisfies - (cl-assert (eql (length operands) 1)) - (cl-remove-if-not (car operands) - (ert-select-tests 't universe))))))) + (`(member . ,operands) + (mapcar (lambda (purported-test) + (pcase-exhaustive purported-test + ((pred symbolp) + (unless (ert-test-boundp purported-test) + (signal 'ert-test-unbound + (list purported-test))) + (ert-get-test purported-test)) + ((pred ert-test-p) purported-test))) + operands)) + (`(eql ,operand) + (ert-select-tests `(member ,operand) universe)) + ;; Do these definitions of AND, NOT and OR satisfy de Morgan's + ;; laws? Should they? + (`(and) + (ert-select-tests 't universe)) + (`(and ,first . ,rest) + (ert-select-tests `(and ,@rest) + (ert-select-tests first universe))) + (`(not ,operand) + (let ((all-tests (ert-select-tests 't universe))) + (cl-set-difference all-tests + (ert-select-tests operand all-tests)))) + (`(or) + (ert-select-tests 'nil universe)) + (`(or ,first . ,rest) + (cl-union (ert-select-tests first universe) + (ert-select-tests `(or ,@rest) universe))) + (`(tag ,tag) + (ert-select-tests `(satisfies + ,(lambda (test) + (member tag (ert-test-tags test)))) + universe)) + (`(satisfies ,predicate) + (cl-remove-if-not predicate + (ert-select-tests 't universe))))) + +(define-error 'ert-test-unbound "ERT test is unbound") (defun ert--insert-human-readable-selector (selector) "Insert a human-readable presentation of SELECTOR into the current buffer." @@ -1355,6 +1372,22 @@ RESULT must be an `ert-test-result-with-condition'." (defvar ert-quiet nil "Non-nil makes ERT only print important information in batch mode.") +(defun ert-test-location (test) + "Return a string description the source location of TEST." + (when-let ((loc + (ignore-errors + (find-function-search-for-symbol + (ert-test-name test) 'ert-deftest (ert-test-file-name test))))) + (let* ((buffer (car loc)) + (point (cdr loc)) + (file (file-relative-name (buffer-file-name buffer))) + (line (with-current-buffer buffer + (line-number-at-pos point)))) + (format "at %s:%s" file line)))) + +(defvar ert-batch-backtrace-right-margin 70 + "The maximum line length for printing backtraces in `ert-run-tests-batch'.") + ;;;###autoload (defun ert-run-tests-batch (&optional selector) "Run the tests specified by SELECTOR, printing results to the terminal. @@ -1408,7 +1441,8 @@ Returns the stats object." (message "%9s %S%s" (ert-string-for-test-result result nil) (ert-test-name test) - (if (getenv "EMACS_TEST_VERBOSE") + (if (cl-plusp + (length (getenv "EMACS_TEST_VERBOSE"))) (ert-reason-for-test-result result) "")))) (message "%s" "")) @@ -1420,12 +1454,14 @@ Returns the stats object." (message "%9s %S%s" (ert-string-for-test-result result nil) (ert-test-name test) - (if (getenv "EMACS_TEST_VERBOSE") + (if (cl-plusp + (length (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 +1471,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 +1497,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))) @@ -1473,14 +1515,17 @@ Returns the stats object." (let* ((max (prin1-to-string (length (ert--stats-tests stats)))) (format-string (concat "%9s %" (prin1-to-string (length max)) - "s/" max " %S (%f sec)"))) + "s/" max " %S (%f sec)%s"))) (message format-string (ert-string-for-test-result result (ert-test-result-expected-p test result)) (1+ (ert--stats-test-pos stats test)) (ert-test-name test) - (ert-test-result-duration result)))))))) + (ert-test-result-duration result) + (if (ert-test-result-expected-p test result) + "" + (concat " " (ert-test-location test)))))))))) nil)) ;;;###autoload @@ -1493,19 +1538,206 @@ of the tests (e.g. invalid SELECTOR or bug in the code that runs the tests)." (or noninteractive (user-error "This function is only for use in batch mode")) - ;; Better crash loudly than attempting to recover from undefined - ;; behavior. - (setq attempt-stack-overflow-recovery nil - attempt-orderly-shutdown-on-fatal-signal nil) - (unwind-protect - (let ((stats (ert-run-tests-batch selector))) - (kill-emacs (if (zerop (ert-stats-completed-unexpected stats)) 0 1))) + (let ((eln-dir (and (featurep 'native-compile) + (make-temp-file "test-nativecomp-cache-" t)))) + (when eln-dir + (startup-redirect-eln-cache eln-dir)) + ;; Better crash loudly than attempting to recover from undefined + ;; behavior. + (setq attempt-stack-overflow-recovery nil + attempt-orderly-shutdown-on-fatal-signal nil) (unwind-protect - (progn - (message "Error running tests") - (backtrace)) - (kill-emacs 2)))) - + (let ((stats (ert-run-tests-batch selector))) + (when eln-dir + (ignore-errors + (delete-directory eln-dir t))) + (kill-emacs (if (zerop (ert-stats-completed-unexpected stats)) 0 1))) + (unwind-protect + (progn + (message "Error running tests") + (backtrace)) + (when eln-dir + (ignore-errors + (delete-directory eln-dir t))) + (kill-emacs 2))))) + +(defvar ert-load-file-name nil + "The name of the loaded ERT test file, a string. +Usually, it is not needed to be defined, but if different ERT +test packages depend on each other, it might be helpful.") + +(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/ + (when-let ((symbol (car (apropos-internal "" #'ert-test-boundp))) + (test-file (symbol-file symbol 'ert--test)) + (test-report + (file-name-with-extension + (or ert-load-file-name 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)))) + ;; If the test has aborted, `ert--stats-selector' might return + ;; huge junk. Skip this. + (when (< (length (format "%s" (ert--stats-selector stats))) 1024) + (insert " <properties>\n" + (format " <property name=\"selector\" value=\"%s\"/>\n" + (xml-escape-string + (format "%s" (ert--stats-selector stats)) 'noerror)) + " </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)) 'noerror) + (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)) + 'noerror) + (ert-string-for-test-result + result + (ert-test-result-expected-p + test result))) + (xml-escape-string + (string-trim + (ert-reason-for-test-result result)) + 'noerror) + "\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)) 'noerror)) + " </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)) + 'noerror) + (ert-string-for-test-result + result + (ert-test-result-expected-p + test result))) + (xml-escape-string + (string-trim + (ert-reason-for-test-result result)) + 'noerror) + "\n" + " </failure>\n"))) + (unless (zerop (length (ert-test-result-messages result))) + (insert " <system-out>\n" + (xml-escape-string + (ert-test-result-messages result) 'noerror) + " </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")) + (logfile-contents + (when (file-readable-p logfile) + (with-temp-buffer + (insert-file-contents-literally logfile) + (buffer-string))))) + (unless + ;; No defined tests, perhaps a helper file. + (and logfile-contents + (string-match-p "^Running 0 tests" logfile-contents)) + (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 logfile-contents + (insert (xml-escape-string logfile-contents 'noerror))) + (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 +1753,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 +2070,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 +2217,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 +2251,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 +2269,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 +2634,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 +2883,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/faceup.el b/lisp/emacs-lisp/faceup.el index 77689f434c2..b44132dcead 100644 --- a/lisp/emacs-lisp/faceup.el +++ b/lisp/emacs-lisp/faceup.el @@ -1006,7 +1006,7 @@ which could be defined as: (defun my-test-explain (args...) (let ((faceup-test-explain t)) (the-test args...))) - (put 'my-test 'ert-explainer 'my-test-explain) + (put \\='my-test \\='ert-explainer \\='my-test-explain) Alternative, you can use the macro `faceup-defexplainer' as follows: diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index c4f48b8a79e..96eaf1ab642 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -61,6 +61,7 @@ "^\\s-*(\\(def\\(ine-skeleton\\|ine-generic-mode\\|ine-derived-mode\\|\ ine\\(?:-global\\)?-minor-mode\\|ine-compilation-mode\\|un-cvs-mode\\|\ foo\\|\\(?:[^icfgv]\\|g[^r]\\)\\(\\w\\|\\s_\\)+\\*?\\)\\|easy-mmode-define-[a-z-]+\\|easy-menu-define\\|\ +cl-\\(?:defun\\|defmethod\\|defgeneric\\)\\|\ menu-bar-make-toggle\\|menu-bar-make-toggle-command\\)" find-function-space-re "\\('\\|(quote \\)?%s\\(\\s-\\|$\\|[()]\\)") @@ -123,6 +124,15 @@ should insert the feature name." :group 'xref :version "25.1") +(defcustom find-ert-deftest-regexp + "(ert-deftest +'%s" + "The regexp used to search for an ert-deftest definition. +Note it must contain a `%s' at the place where `format' +should insert the feature name." + :type 'regexp + :group 'xref + :version "29.1") + (defun find-function--defface (symbol) (catch 'found (while (re-search-forward (format find-face-regexp symbol) nil t) @@ -136,7 +146,8 @@ should insert the feature name." (defvar . find-variable-regexp) (defface . find-function--defface) (feature . find-feature-regexp) - (defalias . find-alias-regexp)) + (defalias . find-alias-regexp) + (ert-deftest . find-ert-deftest-regexp)) "Alist mapping definition types into regexp variables. Each regexp variable's value should actually be a format string to be used to substitute the desired symbol name into the regexp. @@ -173,6 +184,16 @@ See the functions `find-function' and `find-variable'." :group 'find-function :version "20.3") +(defcustom find-library-include-other-files t + "If non-nil, `read-library-name' will also include non-library files. +This affects commands like `read-library'. + +If nil, only library files (i.e., \".el\" files) will be offered +for completion." + :type 'boolean + :version "29.1" + :group 'find-function) + ;;; Functions: (defun find-library-suffixes () @@ -292,7 +313,10 @@ TYPE should be nil to find a function, or `defvar' to find a variable." Interactively, prompt for LIBRARY using the one at or near point. This function searches `find-library-source-path' if non-nil, and -`load-path' otherwise." +`load-path' otherwise. + +See the `find-library-include-other-files' user option for +customizing the candidate completions." (interactive (list (read-library-name))) (prog1 (switch-to-buffer (find-file-noselect (find-library-name library))) @@ -307,8 +331,6 @@ in a directory under `load-path' (or `find-library-source-path', if non-nil)." (let* ((dirs (or find-library-source-path load-path)) (suffixes (find-library-suffixes)) - (table (apply-partially 'locate-file-completion-table - dirs suffixes)) (def (if (eq (function-called-at-point) 'require) ;; `function-called-at-point' may return 'require ;; with `point' anywhere on this line. So wrap the @@ -322,10 +344,28 @@ if non-nil)." (thing-at-point 'symbol)) (error nil)) (thing-at-point 'symbol)))) - (when (and def (not (test-completion def table))) - (setq def nil)) - (completing-read (format-prompt "Library name" def) - table nil nil nil nil def))) + (if find-library-include-other-files + (let ((table (apply-partially #'locate-file-completion-table + dirs suffixes))) + (when (and def (not (test-completion def table))) + (setq def nil)) + (completing-read (format-prompt "Library name" def) + table nil nil nil nil def)) + (let ((files (read-library-name--find-files dirs suffixes))) + (when (and def (not (member def files))) + (setq def nil)) + (completing-read (format-prompt "Library name" def) + files nil t nil nil def))))) + +(defun read-library-name--find-files (dirs suffixes) + "Return a list of all files in DIRS that match SUFFIXES." + (let ((files nil) + (regexp (concat (regexp-opt suffixes) "\\'"))) + (dolist (dir dirs) + (dolist (file (ignore-errors (directory-files dir nil regexp t))) + (and (string-match regexp file) + (push (substring file 0 (match-beginning 0)) files)))) + files)) ;;;###autoload (defun find-library-other-window (library) diff --git a/lisp/emacs-lisp/generator.el b/lisp/emacs-lisp/generator.el index be48699a278..8fbc3b03648 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) @@ -689,8 +690,10 @@ of values. Callers can retrieve each value using `iter-next'." (declare (indent defun) (debug (&define lambda-list lambda-doc &rest sexp))) (cl-assert lexical-binding) - `(lambda ,arglist - ,(cps-generate-evaluator body))) + (pcase-let* ((`(,declarations . ,exps) (macroexp-parse-body body))) + `(lambda ,arglist + ,@declarations + ,(cps-generate-evaluator exps)))) (defmacro iter-make (&rest body) "Return a new iterator." diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index 33e85e49c7b..7cfa1f2dadc 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) @@ -594,7 +594,7 @@ binding mode." code (macroexp-warn-and-return "Use of gv-ref probably requires lexical-binding" - code)))) + code nil nil place)))) (defsubst gv-deref (ref) "Dereference REF, returning the referenced value. diff --git a/lisp/emacs-lisp/lisp-mnt.el b/lisp/emacs-lisp/lisp-mnt.el index b871a832466..7c6f89deb11 100644 --- a/lisp/emacs-lisp/lisp-mnt.el +++ b/lisp/emacs-lisp/lisp-mnt.el @@ -111,8 +111,6 @@ ;;; Code: -(require 'mail-parse) - ;;; Variables: (defgroup lisp-mnt nil @@ -361,6 +359,8 @@ Return argument is of the form (\"HOLDER\" \"YEAR1\" ... \"YEARN\")" (defun lm-crack-address (x) "Split up email address(es) X into full name and real email address. The value is a list of elements of the form (FULLNAME . ADDRESS)." + (require 'mail-parse) + (declare-function mail-header-parse-addresses-lax "mail-parse" (string)) (mapcar (lambda (elem) (cons (cdr elem) (car elem))) (mail-header-parse-addresses-lax x))) @@ -505,7 +505,7 @@ absent, return nil." (if (and page (string-match (rx bol "<" (+ nonl) ">" eol) page)) (substring page 1 -1) page))) -(defalias 'lm-homepage 'lm-website) ; for backwards-compatibility +(defalias 'lm-homepage #'lm-website) ; for backwards-compatibility ;;; Verification and synopses diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index c6fcc06e38d..aaec13d1afc 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) @@ -118,6 +119,15 @@ t)) "\\s-+\\(" lisp-mode-symbol-regexp "\\)")) 2) + ;; Like the previous, but uses a quoted symbol as the name. + (list nil + (purecopy (concat "^\\s-*(" + (eval-when-compile + (regexp-opt + '("defalias" "define-obsolete-function-alias") + t)) + "\\s-+'\\(" lisp-mode-symbol-regexp "\\)")) + 2) (list (purecopy "Variables") (purecopy (concat "^\\s-*(" (eval-when-compile @@ -155,6 +165,12 @@ "Imenu generic expression for Lisp mode. See `imenu-generic-expression'.") +(defconst lisp-mode-autoload-regexp + "^;;;###\\(\\([-[:alnum:]]+?\\)-\\)?\\(autoload\\)" + "Regexp to match autoload cookies. +The second group matches package names used to redirect autoloads +to a package-local <package>-loaddefs.el file.") + ;; This was originally in autoload.el and is still used there. (put 'autoload 'doc-string-elt 3) (put 'defmethod 'doc-string-elt 3) @@ -234,6 +250,9 @@ ('let (forward-sexp 1) (>= pos (point))) + ((or 'defun 'defmacro 'cl-defmethod 'cl-defun) + (forward-sexp 2) + (>= pos (point))) ('condition-case ;; If (cdr paren-posns), then we're in the BODY ;; of HANDLERS. @@ -417,7 +436,8 @@ This will generate compile-time constants from BINDINGS." nil t)) ;; Emacs Lisp autoload cookies. Supports the slightly different ;; forms used by mh-e, calendar, etc. - ("^;;;###\\([-a-z]*autoload\\)" 1 font-lock-warning-face prepend)) + (,lisp-mode-autoload-regexp (3 font-lock-warning-face prepend) + (2 font-lock-function-name-face prepend t))) "Subdued level highlighting for Emacs Lisp mode.") (defconst lisp-cl-font-lock-keywords-1 @@ -465,6 +485,9 @@ This will generate compile-time constants from BINDINGS." ;; Words inside ‘’, '' and `' tend to be symbol names. (,(concat "[`‘']\\(" lisp-mode-symbol-regexp "\\)['’]") (1 font-lock-constant-face prepend)) + ;; \\= tends to be an escape in doc strings. + ("\\\\\\\\=" + (0 font-lock-builtin-face prepend)) ;; Constant values. (,(concat "\\_<:" lisp-mode-symbol-regexp "\\_>") (0 font-lock-builtin-face)) @@ -590,6 +613,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 +622,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. @@ -645,7 +670,9 @@ font-lock keywords will not be case sensitive." (setq-local indent-line-function 'lisp-indent-line) (setq-local indent-region-function 'lisp-indent-region) (setq-local comment-indent-function #'lisp-comment-indent) - (setq-local outline-regexp ";;;\\(;* [^ \t\n]\\|###autoload\\)\\|(") + (setq-local outline-regexp (concat ";;;;* [^ \t\n]\\|(\\|\\(" + lisp-mode-autoload-regexp + "\\)")) (setq-local outline-level 'lisp-outline-level) (setq-local add-log-current-defun-function #'lisp-current-defun-name) (setq-local comment-start ";") @@ -685,7 +712,8 @@ font-lock keywords will not be case sensitive." ;; Expects outline-regexp is ";;;\\(;* [^ \t\n]\\|###autoload\\)\\|(" ;; and point is at the beginning of a matching line. (let ((len (- (match-end 0) (match-beginning 0)))) - (cond ((looking-at "(\\|;;;###autoload") + (cond ((or (looking-at-p "(") + (looking-at-p lisp-mode-autoload-regexp)) 1000) ((looking-at ";;\\(;+\\) ") (- (match-end 1) (match-beginning 1))) @@ -1106,6 +1134,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 +1214,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 +1237,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 +1312,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 +1333,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. @@ -1376,29 +1461,49 @@ and initial semicolons." (derived-mode-p 'emacs-lisp-mode)) emacs-lisp-docstring-fill-column fill-column))) - (save-restriction + (let ((ppss (syntax-ppss)) + (start (point))) (save-excursion - (let ((ppss (syntax-ppss)) - (start (point))) - ;; If we're in a string, then narrow (roughly) to that - ;; string before filling. This avoids filling Lisp - ;; statements that follow the string. - (when (ppss-string-terminator ppss) - (goto-char (ppss-comment-or-string-start ppss)) - (beginning-of-line) - ;; The string may be unterminated -- in that case, don't - ;; narrow. - (when (ignore-errors - (progn - (forward-sexp 1) - t)) - (narrow-to-region (ppss-comment-or-string-start ppss) - (point)))) - ;; Move back to where we were. + (save-restriction + ;; If we're not inside a string, then do very basic + ;; filling. This avoids corrupting embedded strings in + ;; code. + (if (not (ppss-comment-or-string-start ppss)) + (lisp--fill-line-simple) + ;; If we're in a string, then narrow (roughly) to that + ;; string before filling. This avoids filling Lisp + ;; statements that follow the string. + (when (ppss-string-terminator ppss) + (goto-char (ppss-comment-or-string-start ppss)) + ;; The string may be unterminated -- in that case, don't + ;; narrow. + (when (ignore-errors + (progn + (forward-sexp 1) + t)) + (narrow-to-region (ppss-comment-or-string-start ppss) + (point)))) + ;; Move back to where we were. + (goto-char start) + (fill-paragraph justify))))))) + ;; Never return nil. + t) + +(defun lisp--fill-line-simple () + (narrow-to-region (line-beginning-position) (line-end-position)) + (goto-char (point-min)) + (while (and (not (eobp)) + (re-search-forward "\\_>" nil t)) + (when (> (current-column) fill-column) + (let ((start (point))) + (backward-sexp) + (if (looking-back "[[(]" (point-min)) (goto-char start) - (fill-paragraph justify))))) - ;; Never return nil. - t)) + (skip-chars-backward " \t") + (insert "\n") + (forward-sexp)))) + (unless (eobp) + (forward-char 1)))) (defun indent-code-rigidly (start end arg &optional nochange-regexp) "Indent all lines of code, starting in the region, sideways by ARG columns. diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el index 4aeca9c6b00..d6086abe59e 100644 --- a/lisp/emacs-lisp/lisp.el +++ b/lisp/emacs-lisp/lisp.el @@ -171,6 +171,8 @@ This command assumes point is not in a string or comment. If INTERACTIVE is non-nil, as it is interactively, report errors as appropriate for this kind of usage." (interactive "^p\nd") + (when (ppss-comment-or-string-start (syntax-ppss)) + (user-error "This command doesn't work in strings or comments")) (if interactive (condition-case _ (down-list arg nil) @@ -856,7 +858,22 @@ The option `delete-pair-blink-delay' can disable blinking." (delete-char 1)))) (defun raise-sexp (&optional arg) - "Raise ARG sexps higher up the tree." + "Raise ARG sexps higher up the tree. +This means that the ARGth enclosing form will be deleted and +replaced with the form that follows point. + +For instance, if you have: + + (let ((foo 2)) + (progn + (setq foo 3) + (zot) + (+ foo 2))) + +and point is before (zot), \\[raise-sexp] will give you + + (let ((foo 2)) + (zot))" (interactive "p") (let ((s (if (and transient-mark-mode mark-active) (buffer-substring (region-beginning) (region-end)) diff --git a/lisp/emacs-lisp/loaddefs-gen.el b/lisp/emacs-lisp/loaddefs-gen.el new file mode 100644 index 00000000000..dce5466be2d --- /dev/null +++ b/lisp/emacs-lisp/loaddefs-gen.el @@ -0,0 +1,677 @@ +;;; loaddefs-gen.el --- generate loaddefs.el files -*- lexical-binding: t -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; Keywords: maint +;; Package: emacs + +;; 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 package generates the main lisp/loaddefs.el file, as well as +;; all the other loaddefs files, like calendar/diary-loaddefs.el, etc. + +;; The main entry point is `loaddefs-generate' (normally called +;; from loaddefs-generate-batch via lisp/Makefile). +;; +;; The "other" loaddefs files are specified either via a file-local +;; setting of `generated-autoload-file', or by specifying +;; +;; ;;;###foo-autoload +;; +;; This makes the autoload go to foo-loaddefs.el in the current directory. +;; Normal ;;;###autoload specs go to the main loaddefs file. + +;;; Code: + +(require 'radix-tree) +(require 'lisp-mnt) + +(defvar autoload-compute-prefixes t + "If non-nil, autoload will add code to register the prefixes used in a file. +Standard prefixes won't be registered anyway. I.e. if a file +\"foo.el\" defines variables or functions that use \"foo-\" as +prefix, that will not be registered. But all other prefixes will +be included.") +(put 'autoload-compute-prefixes 'safe-local-variable #'booleanp) + +(defvar autoload-ignored-definitions + '("define-obsolete-function-alias" + "define-obsolete-variable-alias" + "define-category" "define-key" + "defgroup" "defface" "defadvice" + "def-edebug-spec" + ;; Hmm... this is getting ugly: + "define-widget" + "define-erc-module" + "define-erc-response-handler" + "defun-rcirc-command") + "List of strings naming definitions to ignore for prefixes. +More specifically those definitions will not be considered for the +`register-definition-prefixes' call.") + +(defun loaddefs-generate--file-load-name (file outfile) + "Compute the name that will be used to load FILE. +OUTFILE should be the name of the global loaddefs.el file, which +is expected to be at the root directory of the files we are +scanning for autoloads and will be in the `load-path'." + (let* ((name (file-relative-name file (file-name-directory outfile))) + (names '()) + (dir (file-name-directory outfile))) + ;; If `name' has directory components, only keep the + ;; last few that are really needed. + (while name + (setq name (directory-file-name name)) + (push (file-name-nondirectory name) names) + (setq name (file-name-directory name))) + (while (not name) + (cond + ((null (cdr names)) (setq name (car names))) + ((file-exists-p (expand-file-name "subdirs.el" dir)) + ;; FIXME: here we only check the existence of subdirs.el, + ;; without checking its content. This makes it generate wrong load + ;; names for cases like lisp/term which is not added to load-path. + (setq dir (expand-file-name (pop names) dir))) + (t (setq name (mapconcat #'identity names "/"))))) + (if (string-match "\\.elc?\\(\\.\\|\\'\\)" name) + (substring name 0 (match-beginning 0)) + name))) + +(defun loaddefs-generate--make-autoload (form file &optional expansion) + "Turn FORM into an autoload or defvar for source file FILE. +Returns nil if FORM is not a special autoload form (i.e. a function definition +or macro definition or a defcustom). +If EXPANSION is non-nil, we're processing the macro expansion of an +expression, in which case we want to handle forms differently." + (let ((car (car-safe form)) expand) + (cond + ((and expansion (eq car 'defalias)) + (pcase-let* + ((`(,_ ,_ ,arg . ,rest) form) + ;; `type' is non-nil if it defines a macro. + ;; `fun' is the function part of `arg' (defaults to `arg'). + ((or (and (or `(cons 'macro ,fun) `'(macro . ,fun)) (let type t)) + (and (let fun arg) (let type nil))) + arg) + ;; `lam' is the lambda expression in `fun' (or nil if not + ;; recognized). + (lam (if (memq (car-safe fun) '(quote function)) (cadr fun))) + ;; `args' is the list of arguments (or t if not recognized). + ;; `body' is the body of `lam' (or t if not recognized). + ((or `(lambda ,args . ,body) + (and (let args t) (let body t))) + lam) + ;; Get the `doc' from `body' or `rest'. + (doc (cond ((stringp (car-safe body)) (car body)) + ((stringp (car-safe rest)) (car rest)))) + ;; Look for an interactive spec. + (interactive (pcase body + ((or `((interactive . ,iargs) . ,_) + `(,_ (interactive . ,iargs) . ,_)) + ;; List of modes or just t. + (if (nthcdr 1 iargs) + (list 'quote (nthcdr 1 iargs)) + t))))) + ;; Add the usage form at the end where describe-function-1 + ;; can recover it. + (when (consp args) (setq doc (help-add-fundoc-usage doc args))) + ;; (message "autoload of %S" (nth 1 form)) + `(autoload ,(nth 1 form) ,file ,doc ,interactive ,type))) + + ((and expansion (memq car '(progn prog1))) + (let ((end (memq :autoload-end form))) + (when end ;Cut-off anything after the :autoload-end marker. + (setq form (copy-sequence form)) + (setcdr (memq :autoload-end form) nil)) + (let ((exps (delq nil (mapcar (lambda (form) + (loaddefs-generate--make-autoload + form file expansion)) + (cdr form))))) + (when exps (cons 'progn exps))))) + + ;; For complex cases, try again on the macro-expansion. + ((and (memq car '(easy-mmode-define-global-mode define-global-minor-mode + define-globalized-minor-mode defun defmacro + easy-mmode-define-minor-mode define-minor-mode + define-inline cl-defun cl-defmacro cl-defgeneric + cl-defstruct pcase-defmacro)) + (macrop car) + (setq expand (let ((load-true-file-name file) + (load-file-name file)) + (macroexpand form))) + (memq (car expand) '(progn prog1 defalias))) + ;; Recurse on the expansion. + (loaddefs-generate--make-autoload expand file 'expansion)) + + ;; For special function-like operators, use the `autoload' function. + ((memq car '(define-skeleton define-derived-mode + define-compilation-mode define-generic-mode + easy-mmode-define-global-mode define-global-minor-mode + define-globalized-minor-mode + easy-mmode-define-minor-mode define-minor-mode + cl-defun defun* cl-defmacro defmacro* + define-overloadable-function)) + (let* ((macrop (memq car '(defmacro cl-defmacro defmacro*))) + (name (nth 1 form)) + (args (pcase car + ((or 'defun 'defmacro + 'defun* 'defmacro* 'cl-defun 'cl-defmacro + 'define-overloadable-function) + (nth 2 form)) + ('define-skeleton '(&optional str arg)) + ((or 'define-generic-mode 'define-derived-mode + 'define-compilation-mode) + nil) + (_ t))) + (body (nthcdr (or (function-get car 'doc-string-elt) 3) form)) + (doc (if (stringp (car body)) (pop body)))) + ;; Add the usage form at the end where describe-function-1 + ;; can recover it. + (when (listp args) (setq doc (help-add-fundoc-usage doc args))) + ;; `define-generic-mode' quotes the name, so take care of that + `(autoload ,(if (listp name) name (list 'quote name)) + ,file ,doc + ,(or (and (memq car '(define-skeleton define-derived-mode + define-generic-mode + easy-mmode-define-global-mode + define-global-minor-mode + define-globalized-minor-mode + easy-mmode-define-minor-mode + define-minor-mode)) + t) + (and (eq (car-safe (car body)) 'interactive) + ;; List of modes or just t. + (or (if (nthcdr 1 (car body)) + (list 'quote (nthcdr 1 (car body))) + t)))) + ,(if macrop ''macro nil)))) + + ;; For defclass forms, use `eieio-defclass-autoload'. + ((eq car 'defclass) + (let ((name (nth 1 form)) + (superclasses (nth 2 form)) + (doc (nth 4 form))) + (list 'eieio-defclass-autoload (list 'quote name) + (list 'quote superclasses) file doc))) + + ;; Convert defcustom to less space-consuming data. + ((eq car 'defcustom) + (let* ((varname (car-safe (cdr-safe form))) + (props (nthcdr 4 form)) + (initializer (plist-get props :initialize)) + (init (car-safe (cdr-safe (cdr-safe form)))) + (doc (car-safe (cdr-safe (cdr-safe (cdr-safe form))))) + ;; (rest (cdr-safe (cdr-safe (cdr-safe (cdr-safe form))))) + ) + `(progn + ,(if (not (member initializer '(nil 'custom-initialize-default + #'custom-initialize-default + 'custom-initialize-reset + #'custom-initialize-reset))) + form + `(defvar ,varname ,init ,doc)) + ;; When we include the complete `form', this `custom-autoload' + ;; is not indispensable, but it still helps in case the `defcustom' + ;; doesn't specify its group explicitly, and probably in a few other + ;; corner cases. + (custom-autoload ',varname ,file + ,(condition-case nil + (null (plist-get props :set)) + (error nil))) + ;; Propagate the :safe property to the loaddefs file. + ,@(when-let ((safe (plist-get props :safe))) + `((put ',varname 'safe-local-variable ,safe)))))) + + ((eq car 'defgroup) + ;; In Emacs this is normally handled separately by cus-dep.el, but for + ;; third party packages, it can be convenient to explicitly autoload + ;; a group. + (let ((groupname (nth 1 form))) + `(let ((loads (get ',groupname 'custom-loads))) + (if (member ',file loads) nil + (put ',groupname 'custom-loads (cons ',file loads)))))) + + ;; When processing a macro expansion, any expression + ;; before a :autoload-end should be included. These are typically (put + ;; 'fun 'prop val) and things like that. + ((and expansion (consp form)) form) + + ;; nil here indicates that this is not a special autoload form. + (t nil)))) + +(defun loaddefs-generate--make-prefixes (defs file) + ;; Remove the defs that obey the rule that file foo.el (or + ;; foo-mode.el) uses "foo-" as prefix. Then compute a small set of + ;; prefixes that cover all the remaining definitions. + (let* ((tree (let ((tree radix-tree-empty)) + (dolist (def defs) + (setq tree (radix-tree-insert tree def t))) + tree)) + (prefixes nil)) + ;; Get the root prefixes, that we should include in any case. + (radix-tree-iter-subtrees + tree (lambda (prefix subtree) + (push (cons prefix subtree) prefixes))) + ;; In some cases, the root prefixes are too short, e.g. if you define + ;; "cc-helper" and "c-mode", you'll get "c" in the root prefixes. + (dolist (pair (prog1 prefixes (setq prefixes nil))) + (let ((s (car pair))) + (if (or (and (> (length s) 2) ; Long enough! + ;; But don't use "def" from deffoo-pkg-thing. + (not (string= "def" s))) + (string-match ".[[:punct:]]\\'" s) ;A real (tho short) prefix? + (radix-tree-lookup (cdr pair) "")) ;Nothing to expand! + (push pair prefixes) ;Keep it as is. + (radix-tree-iter-subtrees + (cdr pair) (lambda (prefix subtree) + (push (cons (concat s prefix) subtree) prefixes)))))) + (when prefixes + (let ((strings + (mapcar + (lambda (x) + (let ((prefix (car x))) + (if (or (> (length prefix) 2) ;Long enough! + (and (eq (length prefix) 2) + (string-match "[[:punct:]]" prefix))) + prefix + ;; Some packages really don't follow the rules. + ;; Drop the most egregious cases such as the + ;; one-letter prefixes. + (let ((dropped ())) + (radix-tree-iter-mappings + (cdr x) (lambda (s _) + (push (concat prefix s) dropped))) + (message "%s:0: Warning: Not registering prefix \"%s\". Affects: %S" + file prefix dropped) + nil)))) + prefixes))) + `(register-definition-prefixes ,file ',(sort (delq nil strings) + 'string<)))))) + +(defun loaddefs-generate--parse-file (file main-outfile &optional package-data) + "Examing FILE for ;;;###autoload statements. +MAIN-OUTFILE is the main loaddefs file these statements are +destined for, but this can be overriden by the buffer-local +setting of `generated-autoload-file' in FILE, and +by ;;;###foo-autoload statements. + +If PACKAGE-DATA is `only', return only the package data. If t, +include the package data with the rest of the data. Otherwise, +don't include." + (let ((defs nil) + (load-name (loaddefs-generate--file-load-name file main-outfile)) + (compute-prefixes t) + local-outfile inhibit-autoloads) + (with-temp-buffer + (insert-file-contents file) + (goto-char (point-max)) + ;; We "open-code" this version of `hack-local-variables', + ;; because it's really slow in bootstrap-emacs. + (when (search-backward ";; Local Variables:" (- (point-max) 1000) t) + (save-excursion + (when (re-search-forward "generated-autoload-file: *" nil t) + ;; Buffer-local file that should be interpreted relative to + ;; the .el file. + (setq local-outfile (expand-file-name (read (current-buffer)) + (file-name-directory file))))) + (save-excursion + (when (re-search-forward "generated-autoload-load-name: *" nil t) + (setq load-name (read (current-buffer))))) + (save-excursion + (when (re-search-forward "no-update-autoloads: *" nil t) + (setq inhibit-autoloads (read (current-buffer))))) + (save-excursion + (when (re-search-forward "autoload-compute-prefixes: *" nil t) + (setq compute-prefixes (read (current-buffer)))))) + + ;; We always return the package version (even for pre-dumped + ;; files). + (when package-data + (let ((version (lm-header "version")) + package) + (when (and version + (setq version (ignore-errors (version-to-list version))) + (setq package (or (lm-header "package") + (file-name-sans-extension + (file-name-nondirectory file))))) + (push (list (or local-outfile main-outfile) file + `(push (purecopy ',(cons (intern package) version)) + package--builtin-versions)) + defs)))) + + ;; Obey the `no-update-autoloads' file local variable. + (when (and (not inhibit-autoloads) + (not (eq package-data 'only))) + (goto-char (point-min)) + ;; The cookie might be like ;;;###tramp-autoload... + (while (re-search-forward lisp-mode-autoload-regexp nil t) + (when (or package-data + ;; Outside of the main Emacs build (`package-data' + ;; is set in the Emacs build), check that we don't + ;; have an autoload cookie on the first column of a + ;; doc string or the like. (The Emacs tree + ;; shouldn't contain any such instances.) + (not (ppss-string-terminator (syntax-ppss)))) + ;; ... and if we have one of these names, then alter outfile. + (let* ((aname (match-string 2)) + (to-file (if aname + (expand-file-name + (concat aname "-loaddefs.el") + (file-name-directory file)) + (or local-outfile main-outfile)))) + (if (eolp) + ;; We have a form following. + (let* ((form (prog1 + (read (current-buffer)) + (unless (bolp) + (forward-line 1)))) + (autoload (or (loaddefs-generate--make-autoload + form load-name) + form))) + ;; We get back either an autoload form, or a tree + ;; structure of `(progn ...)' things, so unravel that. + (let ((forms (if (eq (car autoload) 'progn) + (cdr autoload) + (list autoload)))) + (while forms + (let ((elem (pop forms))) + (if (eq (car elem) 'progn) + ;; More recursion; add it to the start. + (setq forms (nconc (cdr elem) forms)) + ;; We have something to add to the defs; do it. + (push (list to-file file elem) defs)))))) + ;; Just put the rest of the line into the loaddefs. + ;; FIXME: We skip the first space if there's more + ;; whitespace after. + (when (looking-at-p " [\t ]") + (forward-char 1)) + (push (list to-file file + (buffer-substring (point) (line-end-position))) + defs))))) + + (when (and autoload-compute-prefixes + compute-prefixes) + (when-let ((form (loaddefs-generate--compute-prefixes load-name))) + ;; This output needs to always go in the main loaddefs.el, + ;; regardless of `generated-autoload-file'. + (push (list main-outfile file form) defs))))) + defs)) + +(defun loaddefs-generate--compute-prefixes (load-name) + (goto-char (point-min)) + (let ((prefs nil)) + ;; Avoid (defvar <foo>) by requiring a trailing space. + (while (re-search-forward + "^(\\(def[^ ]+\\) ['(]*\\([^' ()\"\n]+\\)[\n \t]" nil t) + (unless (member (match-string 1) autoload-ignored-definitions) + (let ((name (match-string-no-properties 2))) + (when (save-excursion + (goto-char (match-beginning 0)) + (or (bobp) + (progn + (forward-line -1) + (not (looking-at ";;;###autoload"))))) + (push name prefs))))) + (loaddefs-generate--make-prefixes prefs load-name))) + +(defun loaddefs-generate--rubric (file &optional type feature) + "Return a string giving the appropriate autoload rubric for FILE. +TYPE (default \"autoloads\") is a string stating the type of +information contained in FILE. TYPE \"package\" acts like the default, +but adds an extra line to the output to modify `load-path'. + +If FEATURE is non-nil, FILE will provide a feature. FEATURE may +be a string naming the feature, otherwise it will be based on +FILE's name." + (let ((basename (file-name-nondirectory file)) + (lp (if (equal type "package") (setq type "autoloads")))) + (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 + "(add-to-list 'load-path (directory-file-name + (or (file-name-directory #$) (car load-path))))\n\n") + "\n;;; End of scraped data\n\n" + ;; This is used outside of autoload.el, eg cus-dep, finder. + (if feature + (format "(provide '%s)\n" + (if (stringp feature) feature + (file-name-sans-extension basename)))) + ";; Local Variables:\n" + ";; version-control: never\n" + ";; no-byte-compile: t\n" ;; #$ is byte-compiled into nil. + ";; no-update-autoloads: t\n" + ";; coding: utf-8-emacs-unix\n" + ";; End:\n" + ";;; " basename + " ends here\n"))) + +(defun loaddefs-generate--insert-section-header (outbuf autoloads + load-name file time) + "Insert into buffer OUTBUF the section-header line for FILE. +The header line lists the file name, its \"load name\", its autoloads, +and the time the FILE was last updated (the time is inserted only +if `autoload-timestamps' is non-nil, otherwise a fixed fake time is inserted)." + (insert "\f\n;;;### ") + (prin1 `(autoloads ,autoloads ,load-name ,file ,time) + outbuf) + (terpri outbuf) + ;; Break that line at spaces, to avoid very long lines. + ;; Make each sub-line into a comment. + (with-current-buffer outbuf + (save-excursion + (forward-line -1) + (while (not (eolp)) + (move-to-column 64) + (skip-chars-forward "^ \n") + (or (eolp) + (insert "\n" ";;;;;; ")))))) + +;;;###autoload +(defun loaddefs-generate (dir output-file &optional excluded-files + extra-data include-package-version + generate-full) + "Generate loaddefs files for Lisp files in the directories DIRS. +DIR can be either a single directory or a list of directories. + +The autoloads will be written to OUTPUT-FILE. If any Lisp file +binds `generated-autoload-file' as a file-local variable, write +its autoloads into the specified file instead. + +The function does NOT recursively descend into subdirectories of the +directory or directories specified. + +If EXTRA-DATA, include this string at the start of the generated file. + +If INCLUDE-PACKAGE-VERSION, include package version data. + +If GENERATE-FULL, don't update, but regenerate all the loaddefs files." + (let* ((files-re (let ((tmp nil)) + (dolist (suf (get-load-suffixes)) + ;; We don't use module-file-suffix below because + ;; we don't want to depend on whether Emacs was + ;; built with or without modules support, nor + ;; what is the suffix for the underlying OS. + (unless (string-match "\\.\\(elc\\|so\\|dll\\)" suf) + (push suf tmp))) + (concat "\\`[^=.].*" (regexp-opt tmp t) "\\'"))) + (files (apply #'nconc + (mapcar (lambda (d) + (directory-files (expand-file-name d) + t files-re)) + (if (consp dir) dir (list dir))))) + (updating (and (file-exists-p output-file) (not generate-full))) + (defs nil)) + + ;; Collect all the autoload data. + (let ((progress (make-progress-reporter + (byte-compile-info + (concat "Scraping files for loaddefs")) + 0 (length files) nil 10)) + (output-time + (file-attribute-modification-time (file-attributes output-file))) + (file-count 0)) + (dolist (file files) + (progress-reporter-update progress (setq file-count (1+ file-count))) + (when (or (not updating) + (time-less-p output-time + (file-attribute-modification-time + (file-attributes file)))) + (setq defs (nconc + (loaddefs-generate--parse-file + file output-file + ;; We only want the package name from the + ;; excluded files. + (and include-package-version + (if (member (expand-file-name file) excluded-files) + 'only + t))) + defs)))) + (progress-reporter-done progress)) + + ;; Generate the loaddef files. First group per output file. + (dolist (fdefs (seq-group-by #'car defs)) + (let ((loaddefs-file (car fdefs))) + (with-temp-buffer + (if (and updating (file-exists-p loaddefs-file)) + (insert-file-contents loaddefs-file) + (insert (loaddefs-generate--rubric loaddefs-file nil t)) + (search-backward "\f") + (when extra-data + (insert extra-data) + (ensure-empty-lines 1))) + ;; Then group by source file (and sort alphabetically). + (dolist (section (sort (seq-group-by #'cadr (cdr fdefs)) + (lambda (e1 e2) + (string< + (file-name-sans-extension + (file-name-nondirectory (car e1))) + (file-name-sans-extension + (file-name-nondirectory (car e2))))))) + (pop section) + (let* ((relfile (file-relative-name + (cadar section) + (file-name-directory loaddefs-file))) + (head (concat "\n\f\n;;; Generated autoloads from " + relfile "\n\n"))) + (when (file-exists-p loaddefs-file) + ;; If we're updating an old loaddefs file, then see if + ;; there's a section here for this file already. + (goto-char (point-min)) + (if (not (search-forward head nil t)) + ;; It's a new file; put the data at the end. + (progn + (goto-char (point-max)) + (search-backward "\f\n")) + ;; Delete the old version of the section. + (delete-region (match-beginning 0) + (and (search-forward "\n\f\n;;;") + (match-beginning 0))) + (forward-line -2))) + (insert head) + (dolist (def (reverse section)) + (setq def (caddr def)) + (if (stringp def) + (princ def (current-buffer)) + (loaddefs-generate--print-form def)) + (unless (bolp) + (insert "\n"))))) + (write-region (point-min) (point-max) loaddefs-file nil 'silent) + (byte-compile-info (file-relative-name loaddefs-file lisp-directory) + t "GEN")))))) + +(defun loaddefs-generate--print-form (def) + "Print DEF in the way make-docfile.c expects it." + (if (or (not (consp def)) + (not (symbolp (car def))) + (not (stringp (nth 3 def)))) + (prin1 def (current-buffer) t) + ;; The salient point here is that we have to have the doc string + ;; that starts with a backslash and a newline, and there mustn't + ;; be any newlines before that. So -- typically + ;; (defvar foo 'value "\ + ;; Doc string" ...). + (insert "(") + (dotimes (_ 3) + (prin1 (pop def) (current-buffer) + '(t (escape-newlines . t) + (escape-control-characters . t))) + (insert " ")) + (let ((start (point))) + (prin1 (pop def) (current-buffer) t) + (save-excursion + (goto-char (1+ start)) + (insert "\\\n"))) + (while def + (insert " ") + (prin1 (pop def) (current-buffer) t)) + (insert ")"))) + +(defun loaddefs-generate--excluded-files () + ;; Exclude those files that are preloaded on ALL platforms. + ;; These are the ones in loadup.el where "(load" is at the start + ;; of the line (crude, but it works). + (let ((default-directory (file-name-directory lisp-directory)) + (excludes nil) + file) + (with-temp-buffer + (insert-file-contents "loadup.el") + (while (re-search-forward "^(load \"\\([^\"]+\\)\"" nil t) + (setq file (match-string 1)) + (or (string-match "\\.el\\'" file) + (setq file (format "%s.el" file))) + (or (string-match "\\`site-" file) + (push (expand-file-name file) excludes)))) + ;; Don't scan ldefs-boot.el, either. + (cons (expand-file-name "ldefs-boot.el") excludes))) + +;;;###autoload +(defun loaddefs-generate-batch () + "Generate loaddefs.el files in batch mode. +This scans for ;;;###autoload forms and related things. + +The first element on the command line should be the (main) +loaddefs.el output file, and the rest are the directories to +use." + (let ((args command-line-args-left)) + (setq command-line-args-left nil) + (loaddefs-generate (cdr args) (expand-file-name (car args))))) + +(defun loaddefs-generate--emacs-batch () + "Generate the loaddefs for the Emacs build. +This is like `loaddefs-generate-batch', but has some specific +rules for built-in packages and excluded files." + (let ((args command-line-args-left) + (output-file (expand-file-name "loaddefs.el" lisp-directory))) + (setq command-line-args-left nil) + (loaddefs-generate + args output-file + (loaddefs-generate--excluded-files) + nil t + ;; Always do a complete update if loaddefs-gen.el has been + ;; updated. + (file-newer-than-file-p + (expand-file-name "emacs-lisp/loaddefs-gen.el" lisp-directory) + output-file)))) + +(provide 'loaddefs-gen) + +;;; loaddefs-gen.el ends here diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index f1bb2c1cf37..51c6e8e0ca2 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -28,6 +28,17 @@ ;;; Code: +(defvar byte-compile-form-stack nil + "Dynamic list of successive enclosing forms. +This is used by the warning message routines to determine a +source code position. The most accessible element is the current +most deeply nested form. + +Normally a form is manually pushed onto the list at the beginning +of `byte-compile-form', etc., and manually popped off at its end. +This is to preserve the data in it in the event of a +condition-case handling a signaled error.") + ;; Bound by the top-level `macroexpand-all', and modified to include any ;; macros defined by `defmacro'. (defvar macroexpand-all-environment nil) @@ -96,10 +107,11 @@ each clause." (defun macroexp--compiler-macro (handler form) (condition-case-unless-debug err - (apply handler form (cdr form)) + (let ((symbols-with-pos-enabled t)) + (apply handler form (cdr form))) (error - (message "Compiler-macro error for %S: %S" (car form) err) - form))) + (message "Compiler-macro error for %S: Handler: %S\n%S" (car form) handler err) + form))) (defun macroexp--funcall-if-compiled (_form) "Pseudo function used internally by macroexp to delay warnings. @@ -135,22 +147,27 @@ 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))))) +(defun macroexp--warn-wrap (arg msg form category) + (let ((when-compiled + (lambda () + (when (if (consp category) + (apply #'byte-compile-warning-enabled-p category) + (byte-compile-warning-enabled-p category)) + (byte-compile-warn-x arg "%s" msg))))) `(progn (macroexp--funcall-if-compiled ',when-compiled) ,form))) (define-obsolete-function-alias 'macroexp--warn-and-return #'macroexp-warn-and-return "28.1") -(defun macroexp-warn-and-return (msg form &optional category compile-only) +(defun macroexp-warn-and-return (msg form &optional category compile-only arg) "Return code equivalent to FORM labeled with warning MSG. CATEGORY is the category of the warning, like the categories that can appear in `byte-compile-warnings'. COMPILE-ONLY non-nil means no warning should be emitted if the code -is executed without being compiled first." +is executed without being compiled first. +ARG is a symbol (or a form) giving the source code position for the message. +It should normally be a symbol with position and it defaults to FORM." (cond ((null msg) form) ((macroexp-compiling-p) @@ -160,7 +177,7 @@ is executed without being compiled first." ;; macroexpand-all gets right back to macroexpanding `form'. form (puthash form form macroexp--warned) - (macroexp--warn-wrap msg form category))) + (macroexp--warn-wrap (or arg form) msg form category))) (t (unless compile-only (message "%sWarning: %s" @@ -220,7 +237,7 @@ is executed without being compiled first." fun obsolete (if (symbolp (symbol-function fun)) "alias" "macro")) - new-form 'obsolete)) + new-form (list 'obsolete fun) nil fun)) new-form))) (defun macroexp--unfold-lambda (form &optional name) @@ -275,7 +292,7 @@ is executed without being compiled first." "attempt to open-code `%s' with too few arguments" "attempt to open-code `%s' with too many arguments") name) - form) + form nil nil arglist) ;; The following leads to infinite recursion when loading a ;; file containing `(defsubst f () (f))', and then trying to @@ -286,118 +303,137 @@ is executed without being compiled first." `(let ,(nreverse bindings) . ,body) (macroexp-progn body))))) +(defun macroexp--dynamic-variable-p (var) + "Whether the variable VAR is dynamically scoped. +Only valid during macro-expansion." + (defvar byte-compile-bound-variables) + (or (not lexical-binding) + (special-variable-p var) + (memq var macroexp--dynvars) + (and (boundp 'byte-compile-bound-variables) + (memq var byte-compile-bound-variables)))) + (defun macroexp--expand-all (form) "Expand all macros in FORM. This is an internal version of `macroexpand-all'. Assumes the caller has bound `macroexpand-all-environment'." - (if (eq (car-safe form) 'backquote-list*) - ;; Special-case `backquote-list*', as it is normally a macro that - ;; generates exceedingly deep expansions from relatively shallow input - ;; forms. We just process it `in reverse' -- first we expand all the - ;; arguments, _then_ we expand the top-level definition. - (macroexpand (macroexp--all-forms form 1) - macroexpand-all-environment) - ;; Normal form; get its expansion, and then expand arguments. - (setq form (macroexp-macroexpand form macroexpand-all-environment)) - ;; FIXME: It'd be nice to use `byte-optimize--pcase' here, but when - ;; I tried it, it broke the bootstrap :-( - (pcase form - (`(cond . ,clauses) - (macroexp--cons 'cond (macroexp--all-clauses clauses) form)) - (`(condition-case . ,(or `(,err ,body . ,handlers) pcase--dontcare)) - (macroexp--cons - 'condition-case - (macroexp--cons err - (macroexp--cons (macroexp--expand-all body) - (macroexp--all-clauses handlers 1) - (cddr form)) - (cdr form)) - form)) - (`(,(or 'defvar 'defconst) . ,_) (macroexp--all-forms form 2)) - (`(function ,(and f `(lambda . ,_))) - (macroexp--cons 'function - (macroexp--cons (macroexp--all-forms f 2) - nil - (cdr form)) - form)) - (`(,(or 'function 'quote) . ,_) form) - (`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body) - pcase--dontcare)) - (macroexp--cons - fun - (macroexp--cons - (macroexp--all-clauses bindings 1) - (if (null body) - (macroexp-unprogn - (macroexp-warn-and-return - (format "Empty %s body" fun) - nil nil 'compile-only)) - (macroexp--all-forms body)) - (cdr form)) - form)) - (`(,(and fun `(lambda . ,_)) . ,args) - ;; Embedded lambda in function position. - ;; If the byte-optimizer is loaded, try to unfold this, - ;; i.e. rewrite it to (let (<args>) <body>). We'd do it in the optimizer - ;; anyway, but doing it here (i.e. earlier) can sometimes avoid the - ;; creation of a closure, thus resulting in much better code. - (let ((newform (macroexp--unfold-lambda form))) - (if (eq newform form) - ;; Unfolding failed for some reason, avoid infinite recursion. - (macroexp--cons (macroexp--all-forms fun 2) - (macroexp--all-forms args) - form) - (macroexp--expand-all newform)))) - - (`(funcall . ,(or `(,exp . ,args) pcase--dontcare)) - (let ((eexp (macroexp--expand-all exp)) - (eargs (macroexp--all-forms args))) - ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo' - ;; has a compiler-macro, or to unfold it. - (pcase eexp - (`#',f (macroexp--expand-all `(,f . ,eargs))) - (_ `(funcall ,eexp . ,eargs))))) - (`(,func . ,_) - (let ((handler (function-get func 'compiler-macro)) - (funargs (function-get func 'funarg-positions))) - ;; Check functions quoted with ' rather than with #' - (dolist (funarg funargs) - (let ((arg (nth funarg form))) - (when (and (eq 'quote (car-safe arg)) - (eq 'lambda (car-safe (cadr arg)))) - (setcar (nthcdr funarg form) - (macroexp-warn-and-return - (format "%S quoted with ' rather than with #'" - (let ((f (cadr arg))) - (if (symbolp f) f `(lambda ,(nth 1 f) ...)))) - arg))))) - ;; Macro expand compiler macros. This cannot be delayed to - ;; byte-optimize-form because the output of the compiler-macro can - ;; use macros. - (if (null handler) - ;; No compiler macro. We just expand each argument (for - ;; setq/setq-default this works alright because the variable names - ;; are symbols). - (macroexp--all-forms form 1) - ;; If the handler is not loaded yet, try (auto)loading the - ;; function itself, which may in turn load the handler. - (unless (functionp handler) - (with-demoted-errors "macroexp--expand-all: %S" - (autoload-do-load (indirect-function func) func))) - (let ((newform (macroexp--compiler-macro handler form))) - (if (eq form newform) - ;; The compiler macro did not find anything to do. - (if (equal form (setq newform (macroexp--all-forms form 1))) - form - ;; Maybe after processing the args, some new opportunities - ;; appeared, so let's try the compiler macro again. - (setq form (macroexp--compiler-macro handler newform)) - (if (eq newform form) - newform - (macroexp--expand-all newform))) - (macroexp--expand-all newform)))))) - - (_ form)))) + (push form byte-compile-form-stack) + (prog1 + (if (eq (car-safe form) 'backquote-list*) + ;; Special-case `backquote-list*', as it is normally a macro that + ;; generates exceedingly deep expansions from relatively shallow input + ;; forms. We just process it `in reverse' -- first we expand all the + ;; arguments, _then_ we expand the top-level definition. + (macroexpand (macroexp--all-forms form 1) + macroexpand-all-environment) + ;; Normal form; get its expansion, and then expand arguments. + (setq form (macroexp-macroexpand form macroexpand-all-environment)) + ;; FIXME: It'd be nice to use `byte-optimize--pcase' here, but when + ;; I tried it, it broke the bootstrap :-( + (let ((fn (car-safe form))) + (pcase form + (`(cond . ,clauses) + (macroexp--cons fn (macroexp--all-clauses clauses) form)) + (`(condition-case . ,(or `(,err ,body . ,handlers) pcase--dontcare)) + (macroexp--cons + fn + (macroexp--cons err + (macroexp--cons (macroexp--expand-all body) + (macroexp--all-clauses handlers 1) + (cddr form)) + (cdr form)) + form)) + (`(,(or 'defvar 'defconst) ,(and name (pred symbolp)) . ,_) + (push name macroexp--dynvars) + (macroexp--all-forms form 2)) + (`(function ,(and f `(lambda . ,_))) + (let ((macroexp--dynvars macroexp--dynvars)) + (macroexp--cons fn + (macroexp--cons (macroexp--all-forms f 2) + nil + (cdr form)) + form))) + (`(,(or 'function 'quote) . ,_) form) + (`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body) + pcase--dontcare)) + (let ((macroexp--dynvars macroexp--dynvars)) + (macroexp--cons + fun + (macroexp--cons + (macroexp--all-clauses bindings 1) + (if (null body) + (macroexp-unprogn + (macroexp-warn-and-return + (format "Empty %s body" fun) + nil nil 'compile-only fun)) + (macroexp--all-forms body)) + (cdr form)) + form))) + (`(,(and fun `(lambda . ,_)) . ,args) + ;; Embedded lambda in function position. + ;; If the byte-optimizer is loaded, try to unfold this, + ;; i.e. rewrite it to (let (<args>) <body>). We'd do it in the optimizer + ;; anyway, but doing it here (i.e. earlier) can sometimes avoid the + ;; creation of a closure, thus resulting in much better code. + (let ((newform (macroexp--unfold-lambda form))) + (if (eq newform form) + ;; Unfolding failed for some reason, avoid infinite recursion. + (macroexp--cons (macroexp--all-forms fun 2) + (macroexp--all-forms args) + form) + (macroexp--expand-all newform)))) + (`(funcall ,exp . ,args) + (let ((eexp (macroexp--expand-all exp)) + (eargs (macroexp--all-forms args))) + ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo' + ;; has a compiler-macro, or to unfold it. + (pcase eexp + ((and `#',f + (guard (not (or (special-form-p f) (macrop f))))) ;; bug#46636 + (macroexp--expand-all `(,f . ,eargs))) + (_ `(funcall ,eexp . ,eargs))))) + (`(funcall . ,_) form) ;bug#53227 + (`(,func . ,_) + (let ((handler (function-get func 'compiler-macro)) + (funargs (function-get func 'funarg-positions))) + ;; Check functions quoted with ' rather than with #' + (dolist (funarg funargs) + (let ((arg (nth funarg form))) + (when (and (eq 'quote (car-safe arg)) + (eq 'lambda (car-safe (cadr arg)))) + (setcar (nthcdr funarg form) + (macroexp-warn-and-return + (format "%S quoted with ' rather than with #'" + (let ((f (cadr arg))) + (if (symbolp f) f `(lambda ,(nth 1 f) ...)))) + arg nil nil (cadr arg)))))) + ;; Macro expand compiler macros. This cannot be delayed to + ;; byte-optimize-form because the output of the compiler-macro can + ;; use macros. + (if (null handler) + ;; No compiler macro. We just expand each argument (for + ;; setq/setq-default this works alright because the variable names + ;; are symbols). + (macroexp--all-forms form 1) + ;; If the handler is not loaded yet, try (auto)loading the + ;; function itself, which may in turn load the handler. + (unless (functionp handler) + (with-demoted-errors "macroexp--expand-all: %S" + (autoload-do-load (indirect-function func) func))) + (let ((newform (macroexp--compiler-macro handler form))) + (if (eq form newform) + ;; The compiler macro did not find anything to do. + (if (equal form (setq newform (macroexp--all-forms form 1))) + form + ;; Maybe after processing the args, some new opportunities + ;; appeared, so let's try the compiler macro again. + (setq form (macroexp--compiler-macro handler newform)) + (if (eq newform form) + newform + (macroexp--expand-all newform))) + (macroexp--expand-all newform)))))) + (_ form)))) + (pop byte-compile-form-stack))) ;; Record which arguments expect functions, so we can warn when those ;; are accidentally quoted with ' rather than with #' @@ -418,6 +454,14 @@ Assumes the caller has bound `macroexpand-all-environment'." If no macros are expanded, FORM is returned unchanged. The second optional arg ENVIRONMENT specifies an environment of macro definitions to shadow the loaded ones for use in file byte-compilation." + (let ((macroexpand-all-environment environment) + (macroexp--dynvars macroexp--dynvars)) + (macroexp--expand-all form))) + +;; This function is like `macroexpand-all' but for use with top-level +;; forms. It does not dynbind `macroexp--dynvars' because we want +;; top-level `defvar' declarations to be recorded in that variable. +(defun macroexpand--all-toplevel (form &optional environment) (let ((macroexpand-all-environment environment)) (macroexp--expand-all form))) @@ -524,12 +568,20 @@ cases where EXP is a constant." (defmacro macroexp-let2* (test bindings &rest body) "Multiple binding version of `macroexp-let2'. -BINDINGS is a list of elements of the form (SYM EXP). Each EXP -can refer to symbols specified earlier in the binding list." +BINDINGS is a list of elements of the form (SYM EXP) or just SYM, +which then stands for (SYM SYM). +Each EXP can refer to symbols specified earlier in the binding list. + +TEST has to be a symbol, and if it is nil it can be omitted." (declare (indent 2) (debug (sexp (&rest (sexp form)) body))) + (when (consp test) ;; `test' was omitted. + (push bindings body) + (setq bindings test) + (setq test nil)) (pcase-exhaustive bindings ('nil (macroexp-progn body)) - (`((,var ,exp) . ,tl) + (`(,(or `(,var ,exp) (and (pred symbolp) var (let exp var))) + . ,tl) `(macroexp-let2 ,test ,var ,exp (macroexp-let2* ,test ,tl ,@body))))) @@ -679,38 +731,40 @@ test of free variables in the following ways: (defun internal-macroexpand-for-load (form full-p) ;; Called from the eager-macroexpansion in readevalloop. - (cond - ;; Don't repeat the same warning for every top-level element. - ((eq 'skip (car macroexp--pending-eager-loads)) form) - ;; If we detect a cycle, skip macro-expansion for now, and output a warning - ;; with a trimmed backtrace. - ((and load-file-name (member load-file-name macroexp--pending-eager-loads)) - (let* ((bt (delq nil - (mapcar #'macroexp--trim-backtrace-frame - (macroexp--backtrace)))) - (elem `(load ,(file-name-nondirectory load-file-name))) - (tail (member elem (cdr (member elem bt))))) - (if tail (setcdr tail (list '…))) - (if (eq (car-safe (car bt)) 'macroexpand-all) (setq bt (cdr bt))) - (if macroexp--debug-eager - (debug 'eager-macroexp-cycle) - (message "Warning: Eager macro-expansion skipped due to cycle:\n %s" - (mapconcat #'prin1-to-string (nreverse bt) " => "))) - (push 'skip macroexp--pending-eager-loads) - form)) - (t - (condition-case err - (let ((macroexp--pending-eager-loads - (cons load-file-name macroexp--pending-eager-loads))) - (if full-p - (macroexpand-all form) - (macroexpand form))) - (error - ;; Hopefully this shouldn't happen thanks to the cycle detection, - ;; but in case it does happen, let's catch the error and give the - ;; code a chance to macro-expand later. - (message "Eager macro-expansion failure: %S" err) - form))))) + (let ((symbols-with-pos-enabled t) + (print-symbols-bare t)) + (cond + ;; Don't repeat the same warning for every top-level element. + ((eq 'skip (car macroexp--pending-eager-loads)) form) + ;; If we detect a cycle, skip macro-expansion for now, and output a warning + ;; with a trimmed backtrace. + ((and load-file-name (member load-file-name macroexp--pending-eager-loads)) + (let* ((bt (delq nil + (mapcar #'macroexp--trim-backtrace-frame + (macroexp--backtrace)))) + (elem `(load ,(file-name-nondirectory load-file-name))) + (tail (member elem (cdr (member elem bt))))) + (if tail (setcdr tail (list '…))) + (if (eq (car-safe (car bt)) 'macroexpand-all) (setq bt (cdr bt))) + (if macroexp--debug-eager + (debug 'eager-macroexp-cycle) + (message "Warning: Eager macro-expansion skipped due to cycle:\n %s" + (mapconcat #'prin1-to-string (nreverse bt) " => "))) + (push 'skip macroexp--pending-eager-loads) + form)) + (t + (condition-case err + (let ((macroexp--pending-eager-loads + (cons load-file-name macroexp--pending-eager-loads))) + (if full-p + (macroexpand--all-toplevel form) + (macroexpand form))) + (error + ;; Hopefully this shouldn't happen thanks to the cycle detection, + ;; but in case it does happen, let's catch the error and give the + ;; code a chance to macro-expand later. + (message "Eager macro-expansion failure: %S" err) + form)))))) ;; ¡¡¡ Big Ugly Hack !!! ;; src/bootstrap-emacs is mostly used to compile .el files, so it needs diff --git a/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el index f6848008249..c47025f8846 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" @@ -278,11 +278,17 @@ C-g to quit (cancel the whole command); ;; For backward compatibility check if short y/n answers are preferred. (defcustom read-answer-short 'auto - "If non-nil, `read-answer' accepts single-character answers. + "If non-nil, the `read-answer' function accepts single-character answers. If t, accept short (single key-press) answers to the question. If nil, require long answers. If `auto', accept short answers if `use-short-answers' is non-nil, or the function cell of `yes-or-no-p' -is set to `y-or-n-p'." +is set to `y-or-n-p'. + +Note that this variable does not affect calls to the more +commonly-used `yes-or-no-p' function; it only affects calls to +the `read-answer' function. To control whether `yes-or-no-p' +requires a long or a short answer, see the `use-short-answers' +variable." :type '(choice (const :tag "Accept short answers" t) (const :tag "Require long answer" nil) (const :tag "Guess preference" auto)) diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el index dea5b34991a..8c67d7c7a25 100644 --- a/lisp/emacs-lisp/map.el +++ b/lisp/emacs-lisp/map.el @@ -175,7 +175,17 @@ MAP can be an alist, plist, hash-table, or array." (cl-defgeneric map-delete (map key) "Delete KEY in-place from MAP and return MAP. -Keys not present in MAP are ignored.") +Keys not present in MAP are ignored. + +Note that if MAP is a list (either alist or plist), and you're +deleting the final element in the list, the list isn't actually +destructively modified (but the return value will reflect the +deletion). So if you're using this method on a list, you have to +say + + (setq map (map-delete map key)) + +for this to work reliably.") (cl-defmethod map-delete ((map list) key) ;; FIXME: Signal map-not-inplace i.s.o returning a different list? @@ -540,7 +550,7 @@ TYPE is a list whose car is `hash-table' and cdr a list of keyword-args forwarded to `make-hash-table'. Example: - (map-into '((1 . 3)) '(hash-table :test eql))" + (map-into \\='((1 . 3)) \\='(hash-table :test eql))" (map--into-hash map (cdr type))) (defun map--make-pcase-bindings (args) diff --git a/lisp/emacs-lisp/memory-report.el b/lisp/emacs-lisp/memory-report.el index d9c0f02820e..56b1ea6ed48 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 () @@ -75,7 +75,7 @@ by counted more than once." (defun memory-report-object-size (object) "Return the size of OBJECT in bytes." - (when (zerop (hash-table-count memory-report--type-size)) + (unless memory-report--type-size (memory-report--garbage-collect)) (memory-report--object-size (make-hash-table :test #'eq) object)) @@ -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) @@ -182,6 +183,10 @@ by counted more than once." (cl-defgeneric memory-report--object-size-1 (_counted _value) 0) +;; This shouldn't happen, but there's some leakage. +(cl-defmethod memory-report--object-size-1 (_ (_value symbol-with-pos)) + (memory-report--size 'symbol)) + (cl-defmethod memory-report--object-size-1 (_ (value symbol)) ;; Don't count global symbols -- makes sizes of lists of symbols too ;; heavy. @@ -282,7 +287,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/multisession.el b/lisp/emacs-lisp/multisession.el new file mode 100644 index 00000000000..d6f1ab98faa --- /dev/null +++ b/lisp/emacs-lisp/multisession.el @@ -0,0 +1,454 @@ +;;; multisession.el --- Multisession storage for variables -*- lexical-binding: t; -*- + +;; Copyright (C) 2021-2022 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) +(require 'eieio) +(require 'sqlite) +(require 'tabulated-list) + +(defcustom multisession-storage 'files + "Storage method for multisession variables. +Valid methods are `sqlite' and `files'." + :type '(choice (const :tag "SQLite" sqlite) + (const :tag "Files" files)) + :version "29.1" + :group 'files) + +(defcustom multisession-directory (expand-file-name "multisession/" + user-emacs-directory) + "Directory to store multisession variables." + :type 'file + :version "29.1" + :group 'files) + +;;;###autoload +(defmacro define-multisession-variable (name initial-value &optional doc + &rest args) + "Make NAME into a multisession variable initialized from INITIAL-VALUE. +DOC should be a doc string, and ARGS are keywords as applicable to +`make-multisession'." + (declare (indent defun)) + (unless (plist-get args :package) + (setq args (nconc (list :package + (replace-regexp-in-string "-.*" "" + (symbol-name name))) + args))) + `(defvar ,name + (make-multisession :key ,(symbol-name name) + :initial-value ,initial-value + ,@args) + ,@(list doc))) + +(defconst multisession--unbound (make-symbol "unbound")) + +(cl-defstruct (multisession + (:constructor nil) + (:constructor multisession--create) + (:conc-name multisession--)) + "A persistent variable that will live across Emacs invocations." + key + (initial-value nil) + package + (storage multisession-storage) + (synchronized nil) + (cached-value multisession--unbound) + (cached-sequence 0)) + +(cl-defun make-multisession (&key key initial-value package synchronized + storage) + "Create a multisession object." + (unless package + (error "No package for the multisession object")) + (unless key + (error "No key for the multisession object")) + (unless (stringp package) + (error "The package has to be a string")) + (unless (stringp key) + (error "The key has to be a string")) + (multisession--create + :key key + :synchronized synchronized + :initial-value initial-value + :package package + :storage (or storage multisession-storage))) + +(defun multisession-value (object) + "Return the value of the multisession OBJECT." + (if (null user-init-file) + ;; If we don't have storage, then just return the value from the + ;; object. + (if (eq (multisession--cached-value object) multisession--unbound) + (multisession--initial-value object) + (multisession--cached-value object)) + ;; We have storage, so we update from storage. + (multisession-backend-value (multisession--storage object) object))) + +(defun multisession--set-value (object value) + "Set the stored value of OBJECT to VALUE." + (if (null user-init-file) + ;; We have no backend, so just store the value. + (setf (multisession--cached-value object) value) + ;; We have a backend. + (multisession--backend-set-value (multisession--storage object) + object value))) + +(defun multisession-delete (object) + "Delete OBJECT from the backend storage." + (multisession--backend-delete (multisession--storage object) object)) + +(gv-define-simple-setter multisession-value multisession--set-value) + +;; SQLite Backend + +(declare-function sqlite-execute "sqlite.c") +(declare-function sqlite-select "sqlite.c") +(declare-function sqlite-open "sqlite.c") +(declare-function sqlite-pragma "sqlite.c") +(declare-function sqlite-transaction "sqlite.c") +(declare-function sqlite-commit "sqlite.c") + +(defvar multisession--db nil) + +(defun multisession--ensure-db () + (unless multisession--db + (let* ((file (expand-file-name "sqlite/multisession.sqlite" + multisession-directory)) + (dir (file-name-directory file))) + (unless (file-exists-p dir) + (make-directory dir t)) + (setq multisession--db (sqlite-open file))) + (with-sqlite-transaction multisession--db + ;; Use a write-ahead-log (available since 2010), which makes + ;; writes a lot faster. + (sqlite-pragma multisession--db "journal_mode = WAL") + (sqlite-pragma multisession--db "synchronous = NORMAL") + (unless (sqlite-select + multisession--db + "select name from sqlite_master where type = 'table' and name = 'multisession'") + ;; Tidy up the database automatically. + (sqlite-pragma multisession--db "auto_vacuum = FULL") + ;; Create the table. + (sqlite-execute + multisession--db + "create table multisession (package text not null, key text not null, sequence number not null default 1, value text not null)") + (sqlite-execute + multisession--db + "create unique index multisession_idx on multisession (package, key)"))))) + +(cl-defmethod multisession-backend-value ((_type (eql 'sqlite)) object) + (multisession--ensure-db) + (let ((id (list (multisession--package object) + (multisession--key object)))) + (cond + ;; We have no value yet; check the database. + ((eq (multisession--cached-value object) multisession--unbound) + (let ((stored + (car + (sqlite-select + multisession--db + "select value, sequence from multisession where package = ? and key = ?" + id)))) + (if stored + (let ((value (car (read-from-string (car stored))))) + (setf (multisession--cached-value object) value + (multisession--cached-sequence object) (cadr stored)) + value) + ;; Nothing; return the initial value. + (multisession--initial-value object)))) + ;; We have a value, but we want to update in case some other + ;; Emacs instance has updated. + ((multisession--synchronized object) + (let ((stored + (car + (sqlite-select + multisession--db + "select value, sequence from multisession where sequence > ? and package = ? and key = ?" + (cons (multisession--cached-sequence object) id))))) + (if stored + (let ((value (car (read-from-string (car stored))))) + (setf (multisession--cached-value object) value + (multisession--cached-sequence object) (cadr stored)) + value) + ;; Nothing, return the cached value. + (multisession--cached-value object)))) + ;; Just return the cached value. + (t + (multisession--cached-value object))))) + +(cl-defmethod multisession--backend-set-value ((_type (eql 'sqlite)) + object value) + (catch 'done + (let ((i 0)) + (while (< i 10) + (condition-case nil + (throw 'done (multisession--set-value-sqlite object value)) + (sqlite-locked-error + (setq i (1+ i)) + (sleep-for (+ 0.1 (/ (float (random 10)) 10)))))) + (signal 'sqlite-locked-error "Database is locked")))) + +(defun multisession--set-value-sqlite (object value) + (multisession--ensure-db) + (with-sqlite-transaction multisession--db + (let ((id (list (multisession--package object) + (multisession--key object))) + (pvalue + (let ((print-length nil) + (print-circle t) + (print-level nil)) + (readablep value)))) + (when (and value (not pvalue)) + (error "Unable to store unreadable value: %s" value)) + (sqlite-execute + multisession--db + "insert into multisession(package, key, sequence, value) values(?, ?, 1, ?) on conflict(package, key) do update set sequence = sequence + 1, value = ?" + (append id (list pvalue pvalue))) + (setf (multisession--cached-sequence object) + (caar (sqlite-select + multisession--db + "select sequence from multisession where package = ? and key = ?" + id))) + (setf (multisession--cached-value object) value)))) + +(cl-defmethod multisession--backend-values ((_type (eql 'sqlite))) + (multisession--ensure-db) + (sqlite-select + multisession--db + "select package, key, value from multisession order by package, key")) + +(cl-defmethod multisession--backend-delete ((_type (eql 'sqlite)) object) + (sqlite-execute multisession--db + "delete from multisession where package = ? and key = ?" + (list (multisession--package object) + (multisession--key object)))) + +;; Files Backend + +(defun multisession--encode-file-name (name) + (url-hexify-string name)) + +(defun multisession--read-file-value (file object) + (catch 'done + (let ((i 0) + last-error) + (while (< i 10) + (condition-case err + (throw 'done + (with-temp-buffer + (let* ((time (file-attribute-modification-time + (file-attributes file))) + (coding-system-for-read 'utf-8-emacs-unix)) + (insert-file-contents file) + (let ((stored (read (current-buffer)))) + (setf (multisession--cached-value object) stored + (multisession--cached-sequence object) time) + stored)))) + ;; Windows uses OS-level file locking that may preclude + ;; reading the file in some circumstances. In addition, + ;; rename-file is not an atomic operation on MS-Windows, + ;; when the target file already exists, so there could be a + ;; small race window when the file to read doesn't yet + ;; exist. So when these problems happen, wait a bit and retry. + ((permission-denied file-missing) + (setq i (1+ i) + last-error err) + (sleep-for (+ 0.1 (/ (float (random 10)) 10)))))) + (signal (car last-error) (cdr last-error))))) + +(defun multisession--object-file-name (object) + (expand-file-name + (concat "files/" + (multisession--encode-file-name (multisession--package object)) + "/" + (multisession--encode-file-name (multisession--key object)) + ".value") + multisession-directory)) + +(cl-defmethod multisession-backend-value ((_type (eql 'files)) object) + (let ((file (multisession--object-file-name object))) + (cond + ;; We have no value yet; see whether it's stored. + ((eq (multisession--cached-value object) multisession--unbound) + (if (file-exists-p file) + (multisession--read-file-value file object) + ;; Nope; return the initial value. + (multisession--initial-value object))) + ;; We have a value, but we want to update in case some other + ;; Emacs instance has updated. + ((multisession--synchronized object) + (if (and (file-exists-p file) + (time-less-p (multisession--cached-sequence object) + (file-attribute-modification-time + (file-attributes file)))) + (multisession--read-file-value file object) + ;; Nothing, return the cached value. + (multisession--cached-value object))) + ;; Just return the cached value. + (t + (multisession--cached-value object))))) + +(cl-defmethod multisession--backend-set-value ((_type (eql 'files)) + object value) + (let ((file (multisession--object-file-name object)) + (time (current-time))) + ;; Ensure that the directory exists. + (let ((dir (file-name-directory file))) + (unless (file-exists-p dir) + (make-directory dir t))) + (with-temp-buffer + (let ((print-length nil) + (print-circle t) + (print-level nil)) + (prin1 value (current-buffer))) + (goto-char (point-min)) + (condition-case nil + (read (current-buffer)) + (error (error "Unable to store unreadable value: %s" (buffer-string)))) + ;; Write to a temp file in the same directory and rename to the + ;; file for somewhat better atomicity. + (let ((coding-system-for-write 'utf-8-emacs-unix) + (create-lockfiles nil) + (temp (make-temp-name file)) + (write-region-inhibit-fsync nil)) + (write-region (point-min) (point-max) temp nil 'silent) + (set-file-times temp time) + (rename-file temp file t))) + (setf (multisession--cached-sequence object) time + (multisession--cached-value object) value))) + +(cl-defmethod multisession--backend-values ((_type (eql 'files))) + (mapcar (lambda (file) + (let ((bits (file-name-split file))) + (list (url-unhex-string (car (last bits 2))) + (url-unhex-string + (file-name-sans-extension (car (last bits)))) + (with-temp-buffer + (let ((coding-system-for-read 'utf-8-emacs-unix)) + (insert-file-contents file) + (read (current-buffer))))))) + (directory-files-recursively + (expand-file-name "files" multisession-directory) + "\\.value\\'"))) + +(cl-defmethod multisession--backend-delete ((_type (eql 'files)) object) + (let ((file (multisession--object-file-name object))) + (when (file-exists-p file) + (delete-file file)))) + +;; Mode for editing. + +(defvar-keymap multisession-edit-mode-map + :parent tabulated-list-mode-map + "d" #'multisession-delete-value + "e" #'multisession-edit-value) + +(define-derived-mode multisession-edit-mode special-mode "Multisession" + "This mode lists all elements in the \"multisession\" database." + :interactive nil + (buffer-disable-undo) + (setq-local buffer-read-only t + truncate-lines t) + (setq tabulated-list-format + [("Package" 10) + ("Key" 30) + ("Value" 30)]) + (setq-local revert-buffer-function #'multisession-edit-mode--revert)) + +;;;###autoload +(defun list-multisession-values (&optional choose-storage) + "List all values in the \"multisession\" database. +If CHOOSE-STORAGE (interactively, the prefix), query for the +storage method to list." + (interactive "P") + (let ((storage + (if choose-storage + (intern (completing-read "Storage method: " '(sqlite files) nil t)) + multisession-storage))) + (pop-to-buffer (get-buffer-create (format "*Multisession %s*" storage))) + (multisession-edit-mode) + (setq-local multisession-storage storage) + (multisession-edit-mode--revert) + (goto-char (point-min)))) + +(defun multisession-edit-mode--revert (&rest _) + (let ((inhibit-read-only t) + (id (get-text-property (point) 'tabulated-list-id))) + (erase-buffer) + (tabulated-list-init-header) + (setq tabulated-list-entries + (mapcar (lambda (elem) + (list + (cons (car elem) (cadr elem)) + (vector (car elem) (cadr elem) + (string-replace "\n" "\\n" + (format "%s" (caddr elem)))))) + (multisession--backend-values multisession-storage))) + (tabulated-list-print t) + (goto-char (point-min)) + (when id + (when-let ((match + (text-property-search-forward 'tabulated-list-id id t))) + (goto-char (prop-match-beginning match)))))) + +(defun multisession-delete-value (id) + "Delete the value at point." + (interactive (list (get-text-property (point) 'tabulated-list-id)) + multisession-edit-mode) + (unless id + (error "No value on the current line")) + (unless (yes-or-no-p "Really delete this item? ") + (user-error "Not deleting")) + (multisession--backend-delete multisession-storage + (make-multisession :package (car id) + :key (cdr id))) + (let ((inhibit-read-only t)) + (beginning-of-line) + (delete-region (point) (progn (forward-line 1) (point))))) + +(defun multisession-edit-value (id) + "Edit the value at point." + (interactive (list (get-text-property (point) 'tabulated-list-id)) + multisession-edit-mode) + (unless id + (error "No value on the current line")) + (let* ((object (or + ;; If the multisession variable already exists, use + ;; it (so that we update it). + (and (intern-soft (cdr id)) + (bound-and-true-p (intern (cdr id)))) + ;; Create a new object. + (make-multisession + :package (car id) + :key (cdr id) + :storage multisession-storage))) + (value (multisession-value object))) + (setf (multisession-value object) + (car (read-from-string + (read-string "New value: " (prin1-to-string value)))))) + (multisession-edit-mode--revert)) + +(provide 'multisession) + +;;; multisession.el ends here diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 212499d10b0..00c9e5438b8 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -42,55 +42,61 @@ ;; as this one), so we have to do it by hand! (push (purecopy '(nadvice 1 0)) package--builtin-versions) +(oclosure-define (advice + (:predicate advice--p) + (:copier advice--cons (cdr)) + (:copier advice--copy (car cdr how props))) + car cdr how props) + +(eval-when-compile + (defmacro advice--make-how-alist (&rest args) + `(list + ,@(mapcar + (lambda (arg) + (pcase-let ((`(,how . ,body) arg)) + `(list ,how + (oclosure-lambda (advice (how ,how)) (&rest r) + ,@body) + ,(replace-regexp-in-string + "\\<car\\>" "FUNCTION" + (replace-regexp-in-string + "\\<cdr\\>" "OLDFUN" + (format "%S" `(lambda (&rest r) ,@body)) + t t) + t t)))) + args)))) + ;;;; Lightweight advice/hook -(defvar advice--where-alist - '((:around "\300\301\302\003#\207" 5) - (:before "\300\301\002\"\210\300\302\002\"\207" 4) - (:after "\300\302\002\"\300\301\003\"\210\207" 5) - (:override "\300\301\002\"\207" 4) - (:after-until "\300\302\002\"\206\013\000\300\301\002\"\207" 4) - (:after-while "\300\302\002\"\205\013\000\300\301\002\"\207" 4) - (:before-until "\300\301\002\"\206\013\000\300\302\002\"\207" 4) - (:before-while "\300\301\002\"\205\013\000\300\302\002\"\207" 4) - (:filter-args "\300\302\301\003!\"\207" 5) - (:filter-return "\301\300\302\003\"!\207" 5)) +(defvar advice--how-alist + (advice--make-how-alist + (:around (apply car cdr r)) + (:before (apply car r) (apply cdr r)) + (:after (prog1 (apply cdr r) (apply car r))) + (:override (apply car r)) + (:after-until (or (apply cdr r) (apply car r))) + (:after-while (and (apply cdr r) (apply car r))) + (:before-until (or (apply car r) (apply cdr r))) + (:before-while (and (apply car r) (apply cdr r))) + (:filter-args (apply cdr (funcall car r))) + (:filter-return (funcall car (apply cdr r)))) "List of descriptions of how to add a function. -Each element has the form (WHERE BYTECODE STACK) where: - WHERE is a keyword indicating where the function is added. - BYTECODE is the corresponding byte-code that will be used. - STACK is the amount of stack space needed by the byte-code.") - -(defvar advice--bytecodes (mapcar #'cadr advice--where-alist)) - -(defun advice--p (object) - (and (byte-code-function-p object) - (eq 128 (aref object 0)) - (memq (length object) '(5 6)) - (memq (aref object 1) advice--bytecodes) - (eq #'apply (aref (aref object 2) 0)))) - -(defsubst advice--car (f) (aref (aref f 2) 1)) -(defsubst advice--cdr (f) (aref (aref f 2) 2)) -(defsubst advice--props (f) (aref (aref f 2) 3)) +Each element has the form (HOW OCL DOC) where HOW is a keyword, +OCL is a \"prototype\" function of type `advice', and +DOC is a string where \"FUNCTION\" and \"OLDFUN\" are expected.") (defun advice--cd*r (f) (while (advice--p f) (setq f (advice--cdr f))) f) -(defun advice--where (f) - (let ((bytecode (aref f 1)) - (where nil)) - (dolist (elem advice--where-alist) - (if (eq bytecode (cadr elem)) (setq where (car elem)))) - where)) +(define-obsolete-function-alias 'advice--where #'advice--how "29.1") (defun advice--make-single-doc (flist function macrop) - (let ((where (advice--where flist))) + (let ((how (advice--how flist))) (concat (format "This %s has %s advice: " (if macrop "macro" "function") - where) + how) (let ((fun (advice--car flist))) (if (symbolp fun) (format-message "`%S'." fun) (let* ((name (cdr (assq 'name (advice--props flist)))) @@ -180,33 +186,41 @@ Each element has the form (WHERE BYTECODE STACK) where: `(funcall ',fspec ',(cadr ifm)) (cadr (or iff ifm))))) -(defun advice--make-1 (byte-code stack-depth function main props) - "Build a function value that adds FUNCTION to MAIN." - (let ((adv-sig (gethash main advertised-signature-table)) - (advice - (apply #'make-byte-code 128 byte-code - (vector #'apply function main props) stack-depth nil - (and (or (commandp function) (commandp main)) - (list (advice--make-interactive-form - function main)))))) - (when adv-sig (puthash advice adv-sig advertised-signature-table)) - advice)) - -(defun advice--make (where function main props) - "Build a function value that adds FUNCTION to MAIN at WHERE. -WHERE is a symbol to select an entry in `advice--where-alist'." + +(cl-defmethod oclosure-interactive-form ((ad advice) &optional _) + (let ((car (advice--car ad)) + (cdr (advice--cdr ad))) + (when (or (commandp car) (commandp cdr)) + `(interactive ,(advice--make-interactive-form car cdr))))) + +(cl-defmethod cl-print-object ((object advice) stream) + (cl-assert (advice--p object)) + (princ "#f(advice " stream) + (cl-print-object (advice--car object) stream) + (princ " " stream) + (princ (advice--how object) stream) + (princ " " stream) + (cl-print-object (advice--cdr object) stream) + (let ((props (advice--props object))) + (when props + (princ " " stream) + (cl-print-object props stream))) + (princ ")" stream)) + +(defun advice--make (how function main props) + "Build a function value that adds FUNCTION to MAIN at HOW. +HOW is a symbol to select an entry in `advice--how-alist'." (let ((fd (or (cdr (assq 'depth props)) 0)) (md (if (advice--p main) (or (cdr (assq 'depth (advice--props main))) 0)))) (if (and md (> fd md)) ;; `function' should go deeper. - (let ((rest (advice--make where function (advice--cdr main) props))) - (advice--make-1 (aref main 1) (aref main 3) - (advice--car main) rest (advice--props main))) - (let ((desc (assq where advice--where-alist))) - (unless desc (error "Unknown add-function location `%S'" where)) - (advice--make-1 (nth 1 desc) (nth 2 desc) - function main props))))) + (let ((rest (advice--make how function (advice--cdr main) props))) + (advice--cons main rest)) + (let ((proto (assq how advice--how-alist))) + (unless proto (error "Unknown add-function location `%S'" how)) + (advice--copy (cadr proto) + function main how props))))) (defun advice--member-p (function use-name definition) (let ((found nil)) @@ -232,8 +246,7 @@ WHERE is a symbol to select an entry in `advice--where-alist'." (if val (car val) (let ((nrest (advice--tweak rest tweaker))) (if (eq rest nrest) flist - (advice--make-1 (aref flist 1) (aref flist 3) - first nrest props)))))))) + (advice--cons flist nrest)))))))) ;;;###autoload (defun advice--remove-function (flist function) @@ -273,10 +286,33 @@ different, but `function-equal' will hopefully ignore those differences.") ((symbolp place) `(default-value ',place)) (t place)))) +(defun nadvice--make-docstring (sym) + (let* ((main (documentation (symbol-function sym) 'raw)) + (ud (help-split-fundoc main 'pcase)) + (doc (or (cdr ud) main)) + (col1width (apply #'max (mapcar (lambda (x) + (string-width (symbol-name (car x)))) + advice--how-alist))) + (table (mapconcat (lambda (x) + (format (format " %%-%ds %%s" col1width) + (car x) (nth 2 x))) + advice--how-alist "\n")) + (table (if global-prettify-symbols-mode + (replace-regexp-in-string "(lambda\\>" "(λ" table t t) + table)) + (combined-doc + (if (not (string-match "<<>>" doc)) + doc + (replace-match table t t doc)))) + (if ud (help-add-fundoc-usage combined-doc (car ud)) combined-doc))) + +(put 'add-function 'function-documentation + '(nadvice--make-docstring 'add-function)) + ;;;###autoload -(defmacro add-function (where place function &optional props) +(defmacro add-function (how place function &optional props) ;; TODO: - ;; - maybe let `where' specify some kind of predicate and use it + ;; - maybe let `how' specify some kind of predicate and use it ;; to implement things like mode-local or eieio-defmethod. ;; Of course, that only makes sense if the predicates of all advices can ;; be combined and made more efficient. @@ -285,20 +321,11 @@ different, but `function-equal' will hopefully ignore those differences.") ;; :before-until is like add-hook on run-hook-with-args-until-success. ;; Same with :after-* but for (add-hook ... 'append). "Add a piece of advice on the function stored at PLACE. -FUNCTION describes the code to add. WHERE describes where to add it. -WHERE can be explained by showing the resulting new function, as the +FUNCTION describes the code to add. HOW describes how to add it. +HOW can be explained by showing the resulting new function, as the result of combining FUNCTION and the previous value of PLACE, which we call OLDFUN here: -`:before' (lambda (&rest r) (apply FUNCTION r) (apply OLDFUN r)) -`:after' (lambda (&rest r) (prog1 (apply OLDFUN r) (apply FUNCTION r))) -`:around' (lambda (&rest r) (apply FUNCTION OLDFUN r)) -`:override' (lambda (&rest r) (apply FUNCTION r)) -`:before-while' (lambda (&rest r) (and (apply FUNCTION r) (apply OLDFUN r))) -`:before-until' (lambda (&rest r) (or (apply FUNCTION r) (apply OLDFUN r))) -`:after-while' (lambda (&rest r) (and (apply OLDFUN r) (apply FUNCTION r))) -`:after-until' (lambda (&rest r) (or (apply OLDFUN r) (apply FUNCTION r))) -`:filter-args' (lambda (&rest r) (apply OLDFUN (funcall FUNCTION r))) -`:filter-return'(lambda (&rest r) (funcall FUNCTION (apply OLDFUN r))) +<<>> If FUNCTION was already added, do nothing. PROPS is an alist of additional properties, among which the following have a special meaning: @@ -326,13 +353,13 @@ is also interactive. There are 3 cases: ;;(indent 2) (debug (form [&or symbolp ("local" form) ("var" sexp) gv-place] form &optional form))) - `(advice--add-function ,where (gv-ref ,(advice--normalize-place place)) + `(advice--add-function ,how (gv-ref ,(advice--normalize-place place)) ,function ,props)) (declare-function comp-subr-trampoline-install "comp") ;;;###autoload -(defun advice--add-function (where ref function props) +(defun advice--add-function (how ref function props) (when (and (featurep 'native-compile) (subr-primitive-p (gv-deref ref))) (let ((subr-name (intern (subr-name (gv-deref ref))))) @@ -357,7 +384,7 @@ is also interactive. There are 3 cases: (advice--remove-function (gv-deref ref) (or name (advice--car a))))) (setf (gv-deref ref) - (advice--make where function (gv-deref ref) props)))) + (advice--make how function (gv-deref ref) props)))) ;;;###autoload (defmacro remove-function (place function) @@ -455,11 +482,16 @@ of the piece of advice." (put symbol 'advice--pending (advice--subst-main oldadv nil))) (funcall fsetfun symbol newdef)))) +(put 'advice-add 'function-documentation + '(nadvice--make-docstring 'advice-add)) + ;;;###autoload -(defun advice-add (symbol where function &optional props) +(defun advice-add (symbol how function &optional props) "Like `add-function' but for the function named SYMBOL. Contrary to `add-function', this will properly handle the cases where SYMBOL -is defined as a macro, alias, command, ..." +is defined as a macro, alias, command, ... +HOW can be one of: +<<>>" ;; TODO: ;; - record the advice location, to display in describe-function. ;; - change all defadvice in lisp/**/*.el. @@ -467,19 +499,21 @@ is defined as a macro, alias, command, ..." (let* ((f (symbol-function symbol)) (nf (advice--normalize symbol f))) (unless (eq f nf) (fset symbol nf)) - (add-function where (cond - ((eq (car-safe nf) 'macro) (cdr nf)) - ;; Reasons to delay installation of the advice: - ;; - If the function is not yet defined, installing - ;; the advice would affect `fboundp'ness. - ;; - the symbol-function slot of an autoloaded - ;; function is not itself a function value. - ;; - `autoload' does nothing if the function is - ;; not an autoload or undefined. - ((or (not nf) (autoloadp nf)) - (get symbol 'advice--pending)) - (t (symbol-function symbol))) + (add-function how (cond + ((eq (car-safe nf) 'macro) (cdr nf)) + ;; Reasons to delay installation of the advice: + ;; - If the function is not yet defined, installing + ;; the advice would affect `fboundp'ness. + ;; - the symbol-function slot of an autoloaded + ;; function is not itself a function value. + ;; - `autoload' does nothing if the function is + ;; not an autoload or undefined. + ((or (not nf) (autoloadp nf)) + (get symbol 'advice--pending)) + (t (symbol-function symbol))) function props) + ;; FIXME: We could use a defmethod on `function-documentation' instead, + ;; except when (autoloadp nf)! (put symbol 'function-documentation `(advice--make-docstring ',symbol)) (add-function :around (get symbol 'defalias-fset-function) #'advice--defalias-fset)) @@ -515,12 +549,12 @@ See `advice-add' and `add-function' for explanation on the arguments. Note if NAME is nil the advice is anonymous; otherwise it is named `SYMBOL@NAME'. -\(fn SYMBOL (WHERE LAMBDA-LIST &optional NAME DEPTH) &rest BODY)" +\(fn SYMBOL (HOW LAMBDA-LIST &optional NAME DEPTH) &rest BODY)" (declare (indent 2) (doc-string 3) (debug (sexp sexp def-body))) (or (listp args) (signal 'wrong-type-argument (list 'listp args))) (or (<= 2 (length args) 4) (signal 'wrong-number-of-arguments (list 2 4 (length args)))) - (let* ((where (nth 0 args)) + (let* ((how (nth 0 args)) (lambda-list (nth 1 args)) (name (nth 2 args)) (depth (nth 3 args)) @@ -530,7 +564,7 @@ otherwise it is named `SYMBOL@NAME'. (intern (format "%s@%s" symbol name))) (t (error "Unrecognized name spec `%S'" name))))) `(prog1 ,@(and (symbolp advice) `((defun ,advice ,lambda-list ,@body))) - (advice-add ',symbol ,where #',advice ,@(and props `(',props)))))) + (advice-add ',symbol ,how #',advice ,@(and props `(',props)))))) (defun advice-mapc (fun symbol) "Apply FUN to every advice function in SYMBOL. diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el new file mode 100644 index 00000000000..9775e8cc656 --- /dev/null +++ b/lisp/emacs-lisp/oclosure.el @@ -0,0 +1,562 @@ +;;; oclosure.el --- Open Closures -*- lexical-binding: t; -*- + +;; Copyright (C) 2021-2022 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@iro.umontreal.ca> + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program 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 this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; An OClosure is an object that combines the properties of records +;; with those of a function. More specifically it is a function extended +;; with a notion of type (e.g. for defmethod dispatch) as well as the +;; ability to have some fields that are accessible from the outside. + +;; See "Open closures", ELS'2022 (https://zenodo.org/record/6228797). + +;; Here are some cases of "callable objects" where OClosures have found use: +;; - nadvice.el (the original motivation) +;; - kmacros (for cl-print and for `kmacro-extract-lambda') +;; - cl-generic: turn `cl--generic-isnot-nnm-p' into a mere type test +;; (by putting the no-next-methods into their own class). +;; - Slot accessor functions, where the type-dispatch can be used to +;; dynamically compute the docstring, and also to pretty print them. +;; - `save-some-buffers-function' +;; Here are other cases of "callable objects" where OClosures could be used: +;; - Use the type to distinguish macros from functions. +;; - Use a `name' and `depth' property from the function passed to +;; `add-function' (or `add-hook') instead of passing it via "props". +;; - iterators (generator.el), thunks (thunk.el), streams (stream.el). +;; - PEG rules: they're currently just functions, but they should carry +;; their original (macro-expanded) definition (and should be printed +;; differently from functions)! +;; - auto-generate docstrings for cl-defstruct slot accessors instead of +;; storing them in the accessor itself? +;; - SRFI-17's `setter'. +;; - coercion wrappers, as in "Threesomes, with and without blame" +;; https://dl.acm.org/doi/10.1145/1706299.1706342, or +;; "On the Runtime Complexity of Type-Directed Unboxing" +;; http://sv.c.titech.ac.jp/minamide/papers.html +;; - An efficient `negate' operation such that +;; (negate (negate f)) returns just `f' and (negate #'<) returns #'>=. +;; - Autoloads (tho currently our bytecode functions (and hence OClosures) +;; are too fat for that). + +;; Related constructs: +;; - `funcallable-standard-object' (FSO) in Common-Lisp. These are different +;; from OClosures in that they involve an additional indirection to get +;; to the actual code, and that they offer the possibility of +;; changing (via mutation) the code associated with +;; an FSO. Also the FSO's function can't directly access the FSO's +;; other fields, contrary to the case with OClosures where those are directly +;; available as local variables. +;; - Function objects in Javascript. +;; - Function objects in Python. +;; - Callable/Applicable classes in OO languages, i.e. classes with +;; a single method called `apply' or `call'. The most obvious +;; difference with OClosures (beside the fact that Callable can be +;; extended with additional methods) is that all instances of +;; a given Callable class have to use the same method, whereas every +;; OClosure object comes with its own code, so two OClosure objects of the +;; same type can have different code. Of course, you can get the +;; same result by turning every `oclosure-lambda' into its own class +;; declaration creating an ad-hoc subclass of the specified type. +;; In this sense, OClosures are just a generalization of `lambda' which brings +;; some of the extra feature of Callable objects. +;; - Apply hooks and "entities" in MIT Scheme +;; https://www.gnu.org/software/mit-scheme/documentation/stable/mit-scheme-ref/Application-Hooks.html +;; Apply hooks are basically the same as Common-Lisp's FSOs, and "entities" +;; are a variant of it where the inner function gets the FSO itself as +;; additional argument (a kind of "self" arg), thus making it easier +;; for the code to get data from the object's extra info, tho still +;; not as easy as with OClosures. +;; - "entities" in Lisp Machine Lisp (LML) +;; https://hanshuebner.github.io/lmman/fd-clo.xml +;; These are arguably identical to OClosures, modulo the fact that LML doesn't +;; have lexically-scoped closures and uses a form of closures based on +;; capturing (and reinstating) dynamically scoped bindings instead. + +;; Naming: OClosures were originally named FunCallableRecords (FCR), but +;; that name suggested these were fundamentally records that happened +;; to be called, whereas OClosures are really just closures that happen +;; to enjoy some characteristics of records. +;; The "O" comes from "Open" because OClosures aren't completely opaque +;; (for that same reason, an alternative name suggested at the time was +;; "disclosures"). +;; The "O" can also be understood to mean "Object" since you have notions +;; of inheritance, and the ability to associate methods with particular +;; OClosure types, just as is the case for OO classes. + +;;; Code: + +;; TODO: +;; - `oclosure-(cl-)defun', `oclosure-(cl-)defsubst', `oclosure-define-inline'? +;; - Use accessor in cl-defstruct. +;; - Add pcase patterns for OClosures. +;; - anonymous OClosure types. +;; - copiers for mixins +;; - class-allocated slots? +;; - code-allocated slots? +;; The `where' slot of `advice' would like to be code-allocated, and the +;; interactive-spec of commands is currently code-allocated but would like +;; to be instance-allocated. Their scoping rules are a bit odd, so maybe +;; it's best to avoid them. + +(eval-when-compile (require 'cl-lib)) +(eval-when-compile (require 'subr-x)) ;For `named-let'. + +(defun oclosure--index-table (slotdescs) + (let ((i -1) + (it (make-hash-table :test #'eq))) + (dolist (desc slotdescs) + (let* ((slot (cl--slot-descriptor-name desc))) + (cl-incf i) + (when (gethash slot it) + (error "Duplicate slot name: %S" slot)) + (setf (gethash slot it) i))) + it)) + +(cl-defstruct (oclosure--class + (:constructor nil) + (:constructor oclosure--class-make + ( name docstring slots parents allparents + &aux (index-table (oclosure--index-table slots)))) + (:include cl--class) + (:copier nil)) + "Metaclass for OClosure classes." + (allparents nil :read-only t :type (list-of symbol))) + +(setf (cl--find-class 'oclosure) + (oclosure--class-make 'oclosure + "The root parent of all OClosure classes" + nil nil '(oclosure))) +(defun oclosure--p (oclosure) + (not (not (oclosure-type oclosure)))) + +(cl-deftype oclosure () '(satisfies oclosure--p)) + +(defun oclosure--slot-mutable-p (slotdesc) + (not (alist-get :read-only (cl--slot-descriptor-props slotdesc)))) + +(defun oclosure--defstruct-make-copiers (copiers slotdescs name) + (require 'cl-macs) ;`cl--arglist-args' is not autoloaded. + (let* ((mutables '()) + (slots (mapcar + (lambda (desc) + (let ((name (cl--slot-descriptor-name desc))) + (when (oclosure--slot-mutable-p desc) + (push name mutables)) + name)) + slotdescs))) + (mapcar + (lambda (copier) + (pcase-let* + ((cname (pop copier)) + (args (or (pop copier) `(&key ,@slots))) + (inline (and (eq :inline (car copier)) (pop copier))) + (doc (or (pop copier) + (format "Copier for objects of type `%s'." name))) + (obj (make-symbol "obj")) + (absent (make-symbol "absent")) + (anames (cl--arglist-args args)) + (mnames + (let ((res '()) + (tmp args)) + (while (and tmp + (not (memq (car tmp) + cl--lambda-list-keywords))) + (push (pop tmp) res)) + res)) + (index -1) + (mutlist '()) + (argvals + (mapcar + (lambda (slot) + (setq index (1+ index)) + (let* ((mutable (memq slot mutables)) + (get `(oclosure--get ,obj ,index ,(not (not mutable))))) + (push mutable mutlist) + (cond + ((not (memq slot anames)) get) + ((memq slot mnames) slot) + (t + `(if (eq ',absent ,slot) + ,get + ,slot))))) + slots))) + `(,(if inline 'cl-defsubst 'cl-defun) ,cname + (&cl-defs (',absent) ,obj ,@args) + ,doc + (declare (side-effect-free t)) + (oclosure--copy ,obj ',(if (remq nil mutlist) (nreverse mutlist)) + ,@argvals)))) + copiers))) + + +(defmacro oclosure-define (name &optional docstring &rest slots) + "Define a new OClosure type. +NAME should be a symbol which is the name of the new type. +It can also be of the form (NAME . PROPS) in which case PROPS +is a list of additional properties among the following: + (:predicate PRED): asks to create a predicate function named PRED. + (:parent TYPE): make TYPE (another OClosure type) be a parent of NAME. + (:copier COPIER ARGS): asks to create a \"copier\" (i.e. functional update + function) named COPIER. It will take an object of type NAME as first + argument followed by ARGS. ARGS lists the names of the slots that will + be updated with the value of the corresponding argument. +SLOTS is a list if slot descriptions. Each slot can be a single symbol +which is the name of the slot, or it can be of the form (SLOT-NAME . SPROPS) +where SLOT-NAME is then the name of the slot and SPROPS is a property +list of slot properties. The currently known properties are the following: + `:mutable': A non-nil value mean the slot can be mutated. + `:type': Specifies the type of the values expected to appear in the slot." + (declare (doc-string 2) (indent 1)) + (unless (or (stringp docstring) (null docstring)) + (push docstring slots) + (setq docstring nil)) + (let* ((options (when (consp name) + (prog1 (copy-sequence (cdr name)) + (setq name (car name))))) + (get-opt (lambda (opt &optional all) + (let ((val (assq opt options)) + tmp) + (when val (setq options (delq val options))) + (if (not all) + (cdr val) + (when val + (setq val (list (cdr val))) + (while (setq tmp (assq opt options)) + (push (cdr tmp) val) + (setq options (delq tmp options))) + (nreverse val)))))) + (predicate (car (funcall get-opt :predicate))) + (parent-names (or (funcall get-opt :parent) + (funcall get-opt :include))) + (copiers (funcall get-opt :copier 'all))) + `(progn + ,(when options (macroexp-warn-and-return name + (format "Ignored options: %S" options) + nil)) + (eval-and-compile + (oclosure--define ',name ,docstring ',parent-names ',slots + ,@(when predicate `(:predicate ',predicate)))) + (oclosure--define-functions ,name ,copiers)))) + +(defun oclosure--build-class (name docstring parent-names slots) + (cl-assert (null (cdr parent-names))) + (let* ((parent-class (let ((name (or (car parent-names) 'oclosure))) + (or (cl--find-class name) + (error "Unknown class: %S" name)))) + (slotdescs + (append + (oclosure--class-slots parent-class) + (mapcar (lambda (field) + (if (not (consp field)) + (cl--make-slot-descriptor field nil nil + '((:read-only . t))) + (let ((name (pop field)) + (type nil) + (read-only t) + (props '())) + (while field + (pcase (pop field) + (:mutable (setq read-only (not (car field)))) + (:type (setq type (car field))) + (p (message "Unknown property: %S" p) + (push (cons p (car field)) props))) + (setq field (cdr field))) + (cl--make-slot-descriptor name nil type + `((:read-only . ,read-only) + ,@props))))) + slots)))) + (oclosure--class-make name docstring slotdescs + (if (cdr parent-names) + (oclosure--class-parents parent-class) + (list parent-class)) + (cons name (oclosure--class-allparents + parent-class))))) + +(defmacro oclosure--define-functions (name copiers) + (let* ((class (cl--find-class name)) + (slotdescs (oclosure--class-slots class))) + `(progn + ,@(let ((i -1)) + (mapcar (lambda (desc) + (let* ((slot (cl--slot-descriptor-name desc)) + (mutable (oclosure--slot-mutable-p desc)) + ;; Always use a double hyphen: if users wants to + ;; make it public, they can do so with an alias. + (aname (intern (format "%S--%S" name slot)))) + (cl-incf i) + (if (not mutable) + `(defalias ',aname + ;; We use `oclosure--copy' instead of + ;; `oclosure--accessor-copy' here to circumvent + ;; bootstrapping problems. + (oclosure--copy + oclosure--accessor-prototype + nil ',name ',slot ,i)) + (require 'gv) ;For `gv-setter'. + `(progn + (defalias ',aname + (oclosure--accessor-copy + oclosure--mut-getter-prototype + ',name ',slot ,i)) + (defalias ',(gv-setter aname) + (oclosure--accessor-copy + oclosure--mut-setter-prototype + ',name ',slot ,i)))))) + slotdescs)) + ,@(oclosure--defstruct-make-copiers + copiers slotdescs name)))) + +;;;###autoload +(defun oclosure--define (name docstring parent-names slots + &rest props) + (let* ((class (oclosure--build-class name docstring parent-names slots)) + (pred (lambda (oclosure) + (let ((type (oclosure-type oclosure))) + (when type + (memq name (oclosure--class-allparents + (cl--find-class type))))))) + (predname (or (plist-get props :predicate) + (intern (format "%s--internal-p" name))))) + (setf (cl--find-class name) class) + (dolist (slot (oclosure--class-slots class)) + (put (cl--slot-descriptor-name slot) 'slot-name t)) + (defalias predname pred) + (put name 'cl-deftype-satisfies predname))) + +(defmacro oclosure--lambda (type bindings mutables args &rest body) + "Low level construction of an OClosure object. +TYPE should be a form returning an OClosure type (a symbol) +BINDINGS should list all the slots expected by this type, in the proper order. +MUTABLE is a list of symbols indicating which of the BINDINGS +should be mutable. +No checking is performed," + (declare (indent 3) (debug (sexp (&rest (sexp form)) sexp def-body))) + ;; FIXME: Fundamentally `oclosure-lambda' should be a special form. + ;; We define it here as a macro which expands to something that + ;; looks like "normal code" in order to avoid backward compatibility + ;; issues with third party macros that do "code walks" and would + ;; likely mishandle such a new special form (e.g. `generator.el'). + ;; But don't be fooled: this macro is tightly bound to `cconv.el'. + (pcase-let* + ((`(,prebody . ,body) (macroexp-parse-body body)) + (rovars (mapcar #'car bindings))) + (dolist (mutable mutables) + (setq rovars (delq mutable rovars))) + `(let ,(mapcar (lambda (bind) + (if (cdr bind) bind + ;; Bind to something that doesn't look + ;; like a value to avoid the "Variable + ;; ‘foo’ left uninitialized" warning. + `(,(car bind) (progn nil)))) + (reverse bindings)) + ;; FIXME: Make sure the slotbinds whose value is duplicable aren't + ;; just value/variable-propagated by the optimizer (tho I think our + ;; optimizer is too naive to be a problem currently). + (oclosure--fix-type + ;; This `oclosure--fix-type' + `ignore' call is used by the compiler (in + ;; `cconv.el') to detect and signal an error in case of + ;; store-conversion (i.e. if a variable/slot is mutated). + (ignore ,@rovars) + (lambda ,args + (:documentation ,type) + ,@prebody + ;; Add dummy code which accesses the field's vars to make sure + ;; they're captured in the closure. + (if t nil ,@rovars ,@(mapcar (lambda (m) `(setq ,m ,m)) mutables)) + ,@body))))) + +(defmacro oclosure-lambda (type-and-slots args &rest body) + "Define anonymous OClosure function. +TYPE-AND-SLOTS should be of the form (TYPE . SLOTS) +where TYPE is an OClosure type name (defined by `oclosure-define') +and SLOTS is a let-style list of bindings for the various slots of TYPE. +ARGS and BODY are the same as for `lambda'." + (declare (indent 2) (debug ((sexp &rest (sexp form)) sexp def-body))) + ;; FIXME: Should `oclosure-define' distinguish "optional" from + ;; "mandatory" slots, and/or provide default values for slots missing + ;; from `fields'? + (pcase-let* + ((`(,type . ,fields) type-and-slots) + (class (or (cl--find-class type) + (error "Unknown class: %S" type))) + (slots (oclosure--class-slots class)) + (mutables '()) + (slotbinds (mapcar (lambda (slot) + (let ((name (cl--slot-descriptor-name slot))) + (when (oclosure--slot-mutable-p slot) + (push name mutables)) + (list name))) + slots)) + (tempbinds (mapcar + (lambda (field) + (let* ((name (car field)) + (bind (assq name slotbinds))) + (cond + ;; FIXME: Should we also warn about missing slots? + ((not bind) + (error "Unknown slot: %S" name)) + ((cdr bind) + (error "Duplicate slot: %S" name)) + (t + (let ((temp (gensym "temp"))) + (setcdr bind (list temp)) + (cons temp (cdr field))))))) + fields))) + ;; FIXME: Optimize temps away when they're provided in the right order? + `(let ,tempbinds + (oclosure--lambda ',type ,slotbinds ,mutables ,args ,@body)))) + +(defun oclosure--fix-type (_ignore oclosure) + "Helper function to implement `oclosure-lambda' via a macro. +This has 2 uses: +- For interpreted code, this converts the representation of type information + by moving it from the docstring to the environment. +- For compiled code, this is used as a marker which cconv uses to check that + immutable fields are indeed not mutated." + (if (byte-code-function-p oclosure) + ;; Actually, this should never happen since the `cconv.el' should have + ;; optimized away the call to this function. + oclosure + ;; For byte-coded functions, we store the type as a symbol in the docstring + ;; slot. For interpreted functions, there's no specific docstring slot + ;; so `Ffunction' turns the symbol into a string. + ;; We thus have convert it back into a symbol (via `intern') and then + ;; stuff it into the environment part of the closure with a special + ;; marker so we can distinguish this entry from actual variables. + (cl-assert (eq 'closure (car-safe oclosure))) + (let ((typename (nth 3 oclosure))) ;; The "docstring". + (cl-assert (stringp typename)) + (push (cons :type (intern typename)) + (cadr oclosure)) + oclosure))) + +(defun oclosure--copy (oclosure mutlist &rest args) + (if (byte-code-function-p oclosure) + (apply #'make-closure oclosure + (if (null mutlist) + args + (mapcar (lambda (arg) (if (pop mutlist) (list arg) arg)) args))) + (cl-assert (eq 'closure (car-safe oclosure)) + nil "oclosure not closure: %S" oclosure) + (cl-assert (eq :type (caar (cadr oclosure)))) + (let ((env (cadr oclosure))) + `(closure + (,(car env) + ,@(named-let loop ((env (cdr env)) (args args)) + (when args + (cons (cons (caar env) (car args)) + (loop (cdr env) (cdr args))))) + ,@(nthcdr (1+ (length args)) env)) + ,@(nthcdr 2 oclosure))))) + +(defun oclosure--get (oclosure index mutable) + (if (byte-code-function-p oclosure) + (let* ((csts (aref oclosure 2)) + (v (aref csts index))) + (if mutable (car v) v)) + (cl-assert (eq 'closure (car-safe oclosure))) + (cl-assert (eq :type (caar (cadr oclosure)))) + (cdr (nth (1+ index) (cadr oclosure))))) + +(defun oclosure--set (v oclosure index) + (if (byte-code-function-p oclosure) + (let* ((csts (aref oclosure 2)) + (cell (aref csts index))) + (setcar cell v)) + (cl-assert (eq 'closure (car-safe oclosure))) + (cl-assert (eq :type (caar (cadr oclosure)))) + (setcdr (nth (1+ index) (cadr oclosure)) v))) + +(defun oclosure-type (oclosure) + "Return the type of OCLOSURE, or nil if the arg is not a OClosure." + (if (byte-code-function-p oclosure) + (let ((type (and (> (length oclosure) 4) (aref oclosure 4)))) + (if (symbolp type) type)) + (and (eq 'closure (car-safe oclosure)) + (let* ((env (car-safe (cdr oclosure))) + (first-var (car-safe env))) + (and (eq :type (car-safe first-var)) + (cdr first-var)))))) + +(defconst oclosure--accessor-prototype + ;; Use `oclosure--lambda' to circumvent a bootstrapping problem: + ;; `oclosure-accessor' is not yet defined at this point but + ;; `oclosure--accessor-prototype' is needed when defining `oclosure-accessor'. + (oclosure--lambda 'oclosure-accessor ((type) (slot) (index)) nil + (oclosure) (oclosure--get oclosure index nil))) + +(oclosure-define accessor + "OClosure function to access a specific slot of an object." + type slot) + +(defun oclosure--accessor-cl-print (object stream) + (princ "#f(accessor " stream) + (prin1 (accessor--type object) stream) + (princ "." stream) + (prin1 (accessor--slot object) stream) + (princ ")" stream)) + +(defun oclosure--accessor-docstring (f) + ;; This would like to be a (cl-defmethod function-documentation ...) + ;; but for circularity reason the defmethod is in `simple.el'. + (format "Access slot \"%S\" of OBJ of type `%S'.\n\n(fn OBJ)" + (accessor--slot f) (accessor--type f))) + +(oclosure-define (oclosure-accessor + (:parent accessor) + (:copier oclosure--accessor-copy (type slot index))) + "OClosure function to access a specific slot of an OClosure function." + index) + +(defun oclosure--slot-index (oclosure slotname) + (gethash slotname + (oclosure--class-index-table + (cl--find-class (oclosure-type oclosure))))) + +(defun oclosure--slot-value (oclosure slotname) + (let ((class (cl--find-class (oclosure-type oclosure))) + (index (oclosure--slot-index oclosure slotname))) + (oclosure--get oclosure index + (oclosure--slot-mutable-p + (nth index (oclosure--class-slots class)))))) + +(defun oclosure--set-slot-value (oclosure slotname value) + (let ((class (cl--find-class (oclosure-type oclosure))) + (index (oclosure--slot-index oclosure slotname))) + (unless (oclosure--slot-mutable-p + (nth index (oclosure--class-slots class))) + (signal 'setting-constant (list oclosure slotname))) + (oclosure--set value oclosure index))) + +(defconst oclosure--mut-getter-prototype + (oclosure-lambda (oclosure-accessor (type) (slot) (index)) (oclosure) + (oclosure--get oclosure index t))) +(defconst oclosure--mut-setter-prototype + ;; FIXME: The generated docstring is wrong. + (oclosure-lambda (oclosure-accessor (type) (slot) (index)) (val oclosure) + (oclosure--set val oclosure index))) + +;; Ideally, this should be in `files.el', but that file is loaded +;; before `oclosure.el'. +(oclosure-define (save-some-buffers-function + (:predicate save-some-buffers-function--p))) + + +(provide 'oclosure) +;;; oclosure.el ends here diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 7679ba2fae5..48551f59b43 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -566,9 +566,9 @@ This is the name of the package with its version appended." "Return file-name extension of package-desc object PKG-DESC. Depending on the `package-desc-kind' of PKG-DESC, this is one of: - 'single - \".el\" - 'tar - \".tar\" - 'dir - \"\" + \\='single - \".el\" + \\='tar - \".tar\" + \\='dir - \"\" Signal an error if the kind is none of the above." (pcase (package-desc-kind pkg-desc) @@ -720,6 +720,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!")) @@ -763,47 +764,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. @@ -830,7 +831,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. @@ -841,48 +846,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) @@ -1001,7 +964,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) @@ -1040,9 +1003,11 @@ untar into a directory named DIR; otherwise, signal an error." (defun package-autoload-ensure-default-file (file) "Make sure that the autoload file FILE exists and if not create it." + (declare (obsolete nil "29.1")) (unless (file-exists-p file) (require 'autoload) - (write-region (autoload-rubric file "package" nil) nil file nil 'silent)) + (let ((coding-system-for-write 'utf-8-emacs-unix)) + (write-region (autoload-rubric file "package" nil) nil file nil 'silent))) file) (defvar autoload-timestamps) @@ -1057,8 +1022,11 @@ untar into a directory named DIR; otherwise, signal an error." (autoload-timestamps nil) (backup-inhibited t) (version-control 'never)) - (package-autoload-ensure-default-file output-file) - (make-directory-autoloads pkg-dir output-file) + (loaddefs-generate + pkg-dir output-file + nil + "(add-to-list 'load-path (directory-file-name + (or (file-name-directory #$) (car load-path))))") (let ((buf (find-buffer-visiting output-file))) (when buf (kill-buffer buf))) auto-name)) @@ -1224,13 +1192,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. @@ -1661,7 +1633,9 @@ The variable `package-load-list' controls which packages to load." (qs (if (file-readable-p elc) elc (if (file-readable-p package-quickstart-file) package-quickstart-file)))) - (if qs + ;; The quickstart file presumes that it has a blank slate, + ;; so don't use it if we already activated some packages. + (if (and qs (not (bound-and-true-p package-activated-list))) ;; Skip load-source-file-function which would slow us down by a factor ;; 2 when loading the .el file (this assumes we were careful to ;; save this file so it doesn't need any decoding). @@ -1886,8 +1860,12 @@ SEEN is used internally to detect infinite recursion." (error "Need package `%s-%s', but only %s is available" next-pkg (package-version-join next-version) found-something)) - (t (error "Package `%s-%s' is unavailable" - next-pkg (package-version-join next-version))))) + (t + (if (eq next-pkg 'emacs) + (error "This package requires Emacs version %s" + (package-version-join next-version)) + (error "Package `%s-%s' is unavailable" + next-pkg (package-version-join next-version)))))) (setq packages (package-compute-transaction (cons found packages) (package-desc-reqs found) @@ -2072,6 +2050,7 @@ if all the in-between dependencies are also in PACKAGE-LIST." package-alist)))) (setf (package-desc-signed (car pkg-descs)) t)))))))))) +;;;###autoload (defun package-installed-p (package &optional min-version) "Return non-nil if PACKAGE, of MIN-VERSION or newer, is installed. If PACKAGE is a symbol, it is the package name and MIN-VERSION @@ -2163,6 +2142,61 @@ to install it but still mark it as selected." (message "Package `%s' installed." name)) (message "`%s' is already installed" name)))) +;;;###autoload +(defun package-update (name) + "Update package NAME if a newer version exists." + (interactive + (list (completing-read + "Update package: " (package--updateable-packages) nil t))) + (let ((package (if (symbolp name) + name + (intern name)))) + (package-delete (cadr (assq package package-alist)) 'force) + (package-install package 'dont-select))) + +(defun package--updateable-packages () + ;; Initialize the package system to get the list of package + ;; symbols for completion. + (package--archives-initialize) + (mapcar + #'car + (seq-filter + (lambda (elt) + (let ((available + (assq (car elt) package-archive-contents))) + (and available + (version-list-< + (package-desc-priority-version (cadr elt)) + (package-desc-priority-version (cadr available)))))) + package-alist))) + +;;;###autoload +(defun package-update-all (&optional query) + "Refresh package list and upgrade all packages. +If QUERY, ask the user before updating packages. When called +interactively, QUERY is always true." + (interactive (list (not noninteractive))) + (package-refresh-contents) + (let ((updateable (package--updateable-packages))) + (if (not updateable) + (message "No packages to update") + (when (and query + (not (yes-or-no-p + (if (length= updateable 1) + "One package to update. Do it? " + (format "%s packages to update. Do it?" + (length updateable)))))) + (user-error "Updating aborted")) + (mapc #'package-update updateable)))) + +(defun package--dependencies (pkg) + "Return a list of all dependencies PKG has. +This is done recursively." + ;; Can we have circular dependencies? Assume "nope". + (when-let* ((desc (cadr (assq pkg package-archive-contents))) + (deps (mapcar #'car (package-desc-reqs desc)))) + (delete-dups (apply #'nconc deps (mapcar #'package--dependencies deps))))) + (defun package-strip-rcs-id (str) "Strip RCS version ID from the version string STR. If the result looks like a dotted numeric version, return it. @@ -2494,6 +2528,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'." @@ -2720,6 +2763,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)))) @@ -2765,6 +2811,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 @@ -2786,35 +2841,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'." @@ -2868,7 +2921,13 @@ either a full name or nil, and EMAIL is a valid email address." (define-derived-mode package-menu-mode tabulated-list-mode "Package Menu" "Major mode for browsing a list of packages. -Letters do not insert themselves; instead, they are commands. +The most useful commands here are: + + `x': Install the package under point if it isn't already installed, + and delete it if it's already installed, + `i': mark a package for installation, and + `d': mark a package for deletion. Use the `x' command to perform the + actions on the marked files. \\<package-menu-mode-map> \\{package-menu-mode-map}" :interactive nil @@ -3473,7 +3532,7 @@ corresponding to the newer version." ;; ENTRY is (PKG-DESC [NAME VERSION STATUS DOC]) (let ((pkg-desc (car entry)) (status (aref (cadr entry) 2))) - (cond ((member status '("installed" "dependency" "unsigned")) + (cond ((member status '("installed" "dependency" "unsigned" "external")) (push pkg-desc installed)) ((member status '("available" "new")) (setq available (package--append-to-alist pkg-desc available)))))) @@ -3530,17 +3589,34 @@ immediately." (setq package-menu--mark-upgrades-pending t) (message "Waiting for refresh to finish..."))) -(defun package-menu--list-to-prompt (packages) +(defun package-menu--list-to-prompt (packages &optional include-dependencies) "Return a string listing PACKAGES that's usable in a prompt. PACKAGES is a list of `package-desc' objects. Formats the returned string to be usable in a minibuffer -prompt (see `package-menu--prompt-transaction-p')." +prompt (see `package-menu--prompt-transaction-p'). + +If INCLUDE-DEPENDENCIES, also include the number of uninstalled +dependencies." ;; The case where `package' is empty is handled in ;; `package-menu--prompt-transaction-p' below. - (format "%d (%s)" + (format "%d (%s)%s" (length packages) - (mapconcat #'package-desc-full-name packages " "))) - + (mapconcat #'package-desc-full-name packages " ") + (let ((deps + (seq-remove + #'package-installed-p + (delete-dups + (apply + #'nconc + (mapcar (lambda (package) + (package--dependencies + (package-desc-name package))) + packages)))))) + (if (and include-dependencies deps) + (if (length= deps 1) + (format " plus 1 dependency") + (format " plus %d dependencies" (length deps))) + "")))) (defun package-menu--prompt-transaction-p (delete install upgrade) "Prompt the user about DELETE, INSTALL, and UPGRADE. @@ -3549,11 +3625,14 @@ Either may be nil, but not all." (y-or-n-p (concat (when delete - (format "Packages to delete: %s. " (package-menu--list-to-prompt delete))) + (format "Packages to delete: %s. " + (package-menu--list-to-prompt delete))) (when install - (format "Packages to install: %s. " (package-menu--list-to-prompt install))) + (format "Packages to install: %s. " + (package-menu--list-to-prompt install t))) (when upgrade - (format "Packages to upgrade: %s. " (package-menu--list-to-prompt upgrade))) + (format "Packages to upgrade: %s. " + (package-menu--list-to-prompt upgrade))) "Proceed? "))) @@ -3615,8 +3694,13 @@ packages list, respectively." (defun package-menu-execute (&optional noquery) "Perform marked Package Menu actions. Packages marked for installation are downloaded and installed, -packages marked for deletion are removed, -and packages marked for upgrading are downloaded and upgraded. +packages marked for deletion are removed, and packages marked for +upgrading are downloaded and upgraded. + +If no packages are marked, the action taken depends on the state +of the package under point. If it's not already installed, this +command will install the package, and if it's installed, it will +delete the package. Optional argument NOQUERY non-nil means do not ask the user to confirm." (interactive nil package-menu-mode) @@ -3634,8 +3718,20 @@ Optional argument NOQUERY non-nil means do not ask the user to confirm." ((eq cmd ?I) (push pkg-desc install-list)))) (forward-line))) + ;; Nothing marked. (unless (or delete-list install-list) - (user-error "No operations specified")) + ;; Not on a package line. + (unless (tabulated-list-get-id) + (user-error "No operations specified")) + (let* ((id (tabulated-list-get-id)) + (status (package-menu-get-status))) + (cond + ((member status '("installed")) + (push id delete-list)) + ((member status '("available" "avail-obso" "new" "dependency")) + (push id install-list)) + (t (user-error "No default action available for status: %s" + status))))) (let-alist (package-menu--partition-transaction install-list delete-list) (when (or noquery (package-menu--prompt-transaction-p .delete .install .upgrade)) @@ -4096,7 +4192,9 @@ The list is displayed in a buffer named `*Packages*'." "Return the version number of the package in which this is used. Assumes it is used from an Elisp file placed inside the top-level directory of an installed ELPA package. -The return value is a string (or nil in case we can't find it)." +The return value is a string (or nil in case we can't find it). +It works in more cases if the call is in the file which contains +the `Version:' header." ;; In a sense, this is a lie, but it does just what we want: precompute ;; the version at compile time and hardcodes it into the .elc file! (declare (pure t)) @@ -4115,6 +4213,7 @@ The return value is a string (or nil in case we can't find it)." (let* ((pkgdir (file-name-directory file)) (pkgname (file-name-nondirectory (directory-file-name pkgdir))) (mainfile (expand-file-name (concat pkgname ".el") pkgdir))) + (unless (file-readable-p mainfile) (setq mainfile file)) (when (file-readable-p mainfile) (require 'lisp-mnt) (with-temp-buffer @@ -4193,17 +4292,19 @@ activations need to be changed, such as when `package-load-list' is modified." (locate-library (package--autoloads-file-name pkg)))) (pfile (prin1-to-string file))) (insert "(let ((load-true-file-name " pfile ")\ -(load-file-name " pfile "))\n") +\(load-file-name " pfile "))\n") (insert-file-contents file) ;; Fixup the special #$ reader form and throw away comments. (while (re-search-forward "#\\$\\|^;\\(.*\n\\)" nil 'move) - (unless (nth 8 (syntax-ppss)) + (unless (ppss-string-terminator (save-match-data (syntax-ppss))) (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)) + (delete-dups + (append ',(mapcar #'package-desc-name package--quickstart-pkgs) + package-activated-list))) (current-buffer)) (let ((info-dirs (butlast Info-directory-list))) (when info-dirs @@ -4218,6 +4319,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/pcase.el b/lisp/emacs-lisp/pcase.el index 7a82b416e55..07443dabfef 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -328,7 +328,7 @@ PATTERNS are normal `pcase' patterns, and VALUES are expression. Evaluation happens sequentially as in `setq' (not in parallel). -An example: (pcase-setq `((,a) [(,b)]) '((1) [(2)])) +An example: (pcase-setq \\=`((,a) [(,b)]) \\='((1) [(2)])) VAL is presumed to match PAT. Failure to match may signal an error or go undetected, binding variables to arbitrary values, such as nil. @@ -435,7 +435,7 @@ how many time this CODEGEN is called." (macroexp-warn-and-return (format "pcase pattern %S shadowed by previous pcase pattern" (car case)) - main)))) + main nil nil (car case))))) main))) (defun pcase--expand (exp cases) @@ -941,7 +941,7 @@ Otherwise, it defers to REST which is a list of branches of the form (if (eq upat '_) code (macroexp-warn-and-return "Pattern t is deprecated. Use `_' instead" - code)))) + code nil nil upat)))) ((eq upat 'pcase--dontcare) :pcase--dontcare) ((memq (car-safe upat) '(guard pred)) (if (eq (car upat) 'pred) (pcase--mark-used sym)) diff --git a/lisp/emacs-lisp/pp.el b/lisp/emacs-lisp/pp.el index 9a48c7f908e..a3ff2ecbaa6 100644 --- a/lisp/emacs-lisp/pp.el +++ b/lisp/emacs-lisp/pp.el @@ -24,6 +24,7 @@ ;;; Code: +(require 'cl-lib) (defvar font-lock-verbose) (defgroup pp nil @@ -33,22 +34,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 +78,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 +103,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 +141,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) @@ -144,6 +177,10 @@ Also add the value to the front of the list in the variable `values'." (let ((pt (point))) (save-excursion (forward-sexp -1) + ;; Make `pp-eval-last-sexp' work the same way `eval-last-sexp' + ;; does. + (when (looking-at ",@?") + (goto-char (match-end 0))) (read ;; If first line is commented, ignore all leading comments: (if (save-excursion (beginning-of-line) (looking-at-p "[ \t]*;")) @@ -179,6 +216,192 @@ 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) + (memq (car sexp) '(quote function))) + (cond + ((symbolp (cadr sexp)) + (let ((print-quoted t)) + (prin1 sexp (current-buffer)))) + ((consp (cadr sexp)) + (insert (if (eq (car sexp) 'quote) + "'" "#'")) + (pp--format-list (cadr sexp) + (set-marker (make-marker) (1- (point)))))) + (pp--format-list sexp))) + (t + (prin1 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 + (if (consp sexp) + (pp--insert " " (pop sexp)) + (pp--insert " . " sexp) + (setq sexp nil))) + (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 (and (not (bobp)) (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/range.el b/lisp/emacs-lisp/range.el new file mode 100644 index 00000000000..38c2866cd4c --- /dev/null +++ b/lisp/emacs-lisp/range.el @@ -0,0 +1,467 @@ +;;; ranges.el --- range functions -*- lexical-binding: t; -*- + +;; Copyright (C) 1996-2022 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.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: + +;; A "range" is a list that represents a list of integers. A range is +;; a list containing cons cells of start/end pairs, as well as integers. +;; +;; ((2 . 5) 9 (11 . 13)) +;; +;; represents the list (2 3 4 5 9 11 12 13). + +;;; Code: + +(defun range-normalize (range) + "Normalize RANGE. +If RANGE is a single range, return (RANGE). Otherwise, return RANGE." + (if (listp (cdr-safe range)) + range + (list range))) + +(defun range-denormalize (range) + "If RANGE contains a single range, then return that. +If not, return RANGE as is." + (if (and (consp (car range)) + (length= range 1)) + (car range) + range)) + +(defun range-difference (range1 range2) + "Return the range of elements in RANGE1 that do not appear in RANGE2. +Both ranges must be in ascending order." + (setq range1 (range-normalize range1)) + (setq range2 (range-normalize range2)) + (let* ((new-range (cons nil (copy-sequence range1))) + (r new-range)) + (while (cdr r) + (let* ((r1 (cadr r)) + (r2 (car range2)) + (min1 (if (numberp r1) r1 (car r1))) + (max1 (if (numberp r1) r1 (cdr r1))) + (min2 (if (numberp r2) r2 (car r2))) + (max2 (if (numberp r2) r2 (cdr r2)))) + + (cond ((> min1 max1) + ;; Invalid range: may result from overlap condition (below) + ;; remove Invalid range + (setcdr r (cddr r))) + ((and (= min1 max1) + (listp r1)) + ;; Inefficient representation: may result from overlap + ;; condition (below) + (setcar (cdr r) min1)) + ((not min2) + ;; All done with range2 + (setq r nil)) + ((< max1 min2) + ;; No overlap: range1 precedes range2 + (pop r)) + ((< max2 min1) + ;; No overlap: range2 precedes range1 + (pop range2)) + ((and (<= min2 min1) (<= max1 max2)) + ;; Complete overlap: range1 removed + (setcdr r (cddr r))) + (t + (setcdr r (nconc (list (cons min1 (1- min2)) + (cons (1+ max2) max1)) + (cddr r))))))) + (cdr new-range))) + +(defun range-intersection (range1 range2) + "Return intersection of RANGE1 and RANGE2." + (let* (out + (min1 (car range1)) + (max1 (if (numberp min1) + (if (numberp (cdr range1)) + (prog1 (cdr range1) + (setq range1 nil)) min1) + (prog1 (cdr min1) + (setq min1 (car min1))))) + (min2 (car range2)) + (max2 (if (numberp min2) + (if (numberp (cdr range2)) + (prog1 (cdr range2) + (setq range2 nil)) min2) + (prog1 (cdr min2) + (setq min2 (car min2)))))) + (setq range1 (cdr range1) + range2 (cdr range2)) + (while (and min1 min2) + (cond ((< max1 min2) ; range1 precedes range2 + (setq range1 (cdr range1) + min1 nil)) + ((< max2 min1) ; range2 precedes range1 + (setq range2 (cdr range2) + min2 nil)) + (t ; some sort of overlap is occurring + (let ((min (max min1 min2)) + (max (min max1 max2))) + (setq out (if (= min max) + (cons min out) + (cons (cons min max) out)))) + (if (< max1 max2) ; range1 ends before range2 + (setq min1 nil) ; incr range1 + (setq min2 nil)))) ; incr range2 + (unless min1 + (setq min1 (car range1) + max1 (if (numberp min1) min1 + (prog1 (cdr min1) (setq min1 (car min1)))) + range1 (cdr range1))) + (unless min2 + (setq min2 (car range2) + max2 (if (numberp min2) min2 + (prog1 (cdr min2) (setq min2 (car min2)))) + range2 (cdr range2)))) + (cond ((cdr out) + (nreverse out)) + ((numberp (car out)) + out) + (t + (car out))))) + +(defun range-compress-list (numbers) + "Convert a sorted list of numbers to a range list." + (let ((first (car numbers)) + (last (car numbers)) + result) + (cond + ((null numbers) + nil) + ((not (listp (cdr numbers))) + numbers) + (t + (while numbers + (cond ((= last (car numbers)) nil) ;Omit duplicated number + ((= (1+ last) (car numbers)) ;Still in sequence + (setq last (car numbers))) + (t ;End of one sequence + (setq result + (cons (if (= first last) first + (cons first last)) + result)) + (setq first (car numbers)) + (setq last (car numbers)))) + (setq numbers (cdr numbers))) + (nreverse (cons (if (= first last) first (cons first last)) + result)))))) + +(defun range-uncompress (ranges) + "Expand a list of ranges into a list of numbers. +RANGES is either a single range on the form `(num . num)' or a list of +these ranges." + (let (first last result) + (cond + ((null ranges) + nil) + ((not (listp (cdr ranges))) + (setq first (car ranges)) + (setq last (cdr ranges)) + (while (<= first last) + (setq result (cons first result)) + (setq first (1+ first))) + (nreverse result)) + (t + (while ranges + (if (atom (car ranges)) + (when (numberp (car ranges)) + (setq result (cons (car ranges) result))) + (setq first (caar ranges)) + (setq last (cdar ranges)) + (while (<= first last) + (setq result (cons first result)) + (setq first (1+ first)))) + (setq ranges (cdr ranges))) + (nreverse result))))) + +(defun range-add-list (ranges list) + "Return a list of ranges that has all articles from both RANGES and LIST. +Note: LIST has to be sorted over `<'." + (if (not ranges) + (range-compress-list list) + (setq list (copy-sequence list)) + (unless (listp (cdr ranges)) + (setq ranges (list ranges))) + (let ((out ranges) + ilist lowest highest temp) + (while (and ranges list) + (setq ilist list) + (setq lowest (or (and (atom (car ranges)) (car ranges)) + (caar ranges))) + (while (and list (cdr list) (< (cadr list) lowest)) + (setq list (cdr list))) + (when (< (car ilist) lowest) + (setq temp list) + (setq list (cdr list)) + (setcdr temp nil) + (setq out (nconc (range-compress-list ilist) out))) + (setq highest (or (and (atom (car ranges)) (car ranges)) + (cdar ranges))) + (while (and list (<= (car list) highest)) + (setq list (cdr list))) + (setq ranges (cdr ranges))) + (when list + (setq out (nconc (range-compress-list list) out))) + (setq out (sort out (lambda (r1 r2) + (< (or (and (atom r1) r1) (car r1)) + (or (and (atom r2) r2) (car r2)))))) + (setq ranges out) + (while ranges + (if (atom (car ranges)) + (when (cdr ranges) + (if (atom (cadr ranges)) + (when (= (1+ (car ranges)) (cadr ranges)) + (setcar ranges (cons (car ranges) + (cadr ranges))) + (setcdr ranges (cddr ranges))) + (when (= (1+ (car ranges)) (caadr ranges)) + (setcar (cadr ranges) (car ranges)) + (setcar ranges (cadr ranges)) + (setcdr ranges (cddr ranges))))) + (when (cdr ranges) + (if (atom (cadr ranges)) + (when (= (1+ (cdar ranges)) (cadr ranges)) + (setcdr (car ranges) (cadr ranges)) + (setcdr ranges (cddr ranges))) + (when (= (1+ (cdar ranges)) (caadr ranges)) + (setcdr (car ranges) (cdadr ranges)) + (setcdr ranges (cddr ranges)))))) + (setq ranges (cdr ranges))) + out))) + +(defun range-remove (range1 range2) + "Return a range that has all articles from RANGE2 removed from RANGE1. +The returned range is always a list. RANGE2 can also be a unsorted +list of articles. RANGE1 is modified by side effects, RANGE2 is not +modified." + (if (or (null range1) (null range2)) + range1 + (let (out r1 r2 r1-min r1-max r2-min r2-max + (range2 (copy-tree range2))) + (setq range1 (if (listp (cdr range1)) range1 (list range1)) + range2 (sort (if (listp (cdr range2)) range2 (list range2)) + (lambda (e1 e2) + (< (if (consp e1) (car e1) e1) + (if (consp e2) (car e2) e2)))) + r1 (car range1) + r2 (car range2) + r1-min (if (consp r1) (car r1) r1) + r1-max (if (consp r1) (cdr r1) r1) + r2-min (if (consp r2) (car r2) r2) + r2-max (if (consp r2) (cdr r2) r2)) + (while (and range1 range2) + (cond ((< r2-max r1-min) ; r2 < r1 + (pop range2) + (setq r2 (car range2) + r2-min (if (consp r2) (car r2) r2) + r2-max (if (consp r2) (cdr r2) r2))) + ((and (<= r2-min r1-min) (<= r1-max r2-max)) ; r2 overlap r1 + (pop range1) + (setq r1 (car range1) + r1-min (if (consp r1) (car r1) r1) + r1-max (if (consp r1) (cdr r1) r1))) + ((and (<= r2-min r1-min) (<= r2-max r1-max)) ; r2 overlap min r1 + (pop range2) + (setq r1-min (1+ r2-max) + r2 (car range2) + r2-min (if (consp r2) (car r2) r2) + r2-max (if (consp r2) (cdr r2) r2))) + ((and (<= r1-min r2-min) (<= r2-max r1-max)) ; r2 contained in r1 + (if (eq r1-min (1- r2-min)) + (push r1-min out) + (push (cons r1-min (1- r2-min)) out)) + (pop range2) + (if (< r2-max r1-max) ; finished with r1? + (setq r1-min (1+ r2-max)) + (pop range1) + (setq r1 (car range1) + r1-min (if (consp r1) (car r1) r1) + r1-max (if (consp r1) (cdr r1) r1))) + (setq r2 (car range2) + r2-min (if (consp r2) (car r2) r2) + r2-max (if (consp r2) (cdr r2) r2))) + ((and (<= r2-min r1-max) (<= r1-max r2-max)) ; r2 overlap max r1 + (if (eq r1-min (1- r2-min)) + (push r1-min out) + (push (cons r1-min (1- r2-min)) out)) + (pop range1) + (setq r1 (car range1) + r1-min (if (consp r1) (car r1) r1) + r1-max (if (consp r1) (cdr r1) r1))) + ((< r1-max r2-min) ; r2 > r1 + (pop range1) + (if (eq r1-min r1-max) + (push r1-min out) + (push (cons r1-min r1-max) out)) + (setq r1 (car range1) + r1-min (if (consp r1) (car r1) r1) + r1-max (if (consp r1) (cdr r1) r1))))) + (when r1 + (if (eq r1-min r1-max) + (push r1-min out) + (push (cons r1-min r1-max) out)) + (pop range1)) + (while range1 + (push (pop range1) out)) + (nreverse out)))) + +(defun range-member-p (number ranges) + "Say whether NUMBER is in RANGES." + (if (not (listp (cdr ranges))) + (and (>= number (car ranges)) + (<= number (cdr ranges))) + (let ((not-stop t)) + (while (and ranges + (if (numberp (car ranges)) + (>= number (car ranges)) + (>= number (caar ranges))) + not-stop) + (when (if (numberp (car ranges)) + (= number (car ranges)) + (and (>= number (caar ranges)) + (<= number (cdar ranges)))) + (setq not-stop nil)) + (setq ranges (cdr ranges))) + (not not-stop)))) + +(defun range-list-intersection (list ranges) + "Return a list of numbers in LIST that are members of RANGES. +oLIST is a sorted list." + (setq ranges (range-normalize ranges)) + (let (number result) + (while (setq number (pop list)) + (while (and ranges + (if (numberp (car ranges)) + (< (car ranges) number) + (< (cdar ranges) number))) + (setq ranges (cdr ranges))) + (when (and ranges + (if (numberp (car ranges)) + (= (car ranges) number) + ;; (caar ranges) <= number <= (cdar ranges) + (>= number (caar ranges)))) + (push number result))) + (nreverse result))) + +(defun range-list-difference (list ranges) + "Return a list of numbers in LIST that are not members of RANGES. +LIST is a sorted list." + (setq ranges (range-normalize ranges)) + (let (number result) + (while (setq number (pop list)) + (while (and ranges + (if (numberp (car ranges)) + (< (car ranges) number) + (< (cdar ranges) number))) + (setq ranges (cdr ranges))) + (when (or (not ranges) + (if (numberp (car ranges)) + (not (= (car ranges) number)) + ;; not ((caar ranges) <= number <= (cdar ranges)) + (< number (caar ranges)))) + (push number result))) + (nreverse result))) + +(defun range-length (range) + "Return the length RANGE would have if uncompressed." + (cond + ((null range) + 0) + ((not (listp (cdr range))) + (- (cdr range) (car range) -1)) + (t + (let ((sum 0)) + (dolist (x range sum) + (setq sum + (+ sum (if (consp x) (- (cdr x) (car x) -1) 1)))))))) + +(defun range-concat (range1 range2) + "Add RANGE2 to RANGE1 (nondestructively)." + (unless (listp (cdr range1)) + (setq range1 (list range1))) + (unless (listp (cdr range2)) + (setq range2 (list range2))) + (let ((item1 (pop range1)) + (item2 (pop range2)) + range item selector) + (while (or item1 item2) + (setq selector + (cond + ((null item1) nil) + ((null item2) t) + ((and (numberp item1) (numberp item2)) (< item1 item2)) + ((numberp item1) (< item1 (car item2))) + ((numberp item2) (< (car item1) item2)) + (t (< (car item1) (car item2))))) + (setq item + (or + (let ((tmp1 item) (tmp2 (if selector item1 item2))) + (cond + ((null tmp1) tmp2) + ((null tmp2) tmp1) + ((and (numberp tmp1) (numberp tmp2)) + (cond + ((eq tmp1 tmp2) tmp1) + ((eq (1+ tmp1) tmp2) (cons tmp1 tmp2)) + ((eq (1+ tmp2) tmp1) (cons tmp2 tmp1)) + (t nil))) + ((numberp tmp1) + (cond + ((and (>= tmp1 (car tmp2)) (<= tmp1 (cdr tmp2))) tmp2) + ((eq (1+ tmp1) (car tmp2)) (cons tmp1 (cdr tmp2))) + ((eq (1- tmp1) (cdr tmp2)) (cons (car tmp2) tmp1)) + (t nil))) + ((numberp tmp2) + (cond + ((and (>= tmp2 (car tmp1)) (<= tmp2 (cdr tmp1))) tmp1) + ((eq (1+ tmp2) (car tmp1)) (cons tmp2 (cdr tmp1))) + ((eq (1- tmp2) (cdr tmp1)) (cons (car tmp1) tmp2)) + (t nil))) + ((< (1+ (cdr tmp1)) (car tmp2)) nil) + ((< (1+ (cdr tmp2)) (car tmp1)) nil) + (t (cons (min (car tmp1) (car tmp2)) + (max (cdr tmp1) (cdr tmp2)))))) + (progn + (if item (push item range)) + (if selector item1 item2)))) + (if selector + (setq item1 (pop range1)) + (setq item2 (pop range2)))) + (if item (push item range)) + (reverse range))) + +(defun range-map (func range) + "Apply FUNC to each value contained by RANGE." + (setq range (range-normalize range)) + (while range + (let ((span (pop range))) + (if (numberp span) + (funcall func span) + (let ((first (car span)) + (last (cdr span))) + (while (<= first last) + (funcall func first) + (setq first (1+ first)))))))) + +(provide 'range) + +;;; range.el ends here diff --git a/lisp/emacs-lisp/re-builder.el b/lisp/emacs-lisp/re-builder.el index d460407a803..24770fac67f 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." @@ -323,7 +323,10 @@ Except for Lisp syntax this is the same as `reb-regexp'.") (reb-lisp-mode)) (t (reb-mode))) (reb-restart-font-lock) - (reb-do-update)) + ;; When using `rx' syntax, the initial syntax () is invalid. But + ;; don't signal an error in that case. + (ignore-errors + (reb-do-update))) (defun reb-mode-buffer-p () "Return non-nil if the current buffer is a RE Builder buffer." @@ -448,7 +451,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 +486,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 +609,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/rmc.el b/lisp/emacs-lisp/rmc.el index df0fc339e6d..195035e6be9 100644 --- a/lisp/emacs-lisp/rmc.el +++ b/lisp/emacs-lisp/rmc.el @@ -25,8 +25,107 @@ (require 'seq) +(defun rmc--add-key-description (elem) + (let* ((char (car elem)) + (name (cadr elem)) + (pos (seq-position name char)) + (desc (key-description (char-to-string char))) + (graphical-terminal + (display-supports-face-attributes-p + '(:underline t) (window-frame))) + (altered-name + (cond + ;; Not in the name string, or a special character. + ((or (not pos) + (member desc '("ESC" "TAB" "RET" "DEL" "SPC"))) + (format "%s %s" + (if graphical-terminal + (propertize desc 'face 'read-multiple-choice-face) + (propertize desc 'face 'help-key-binding)) + name)) + ;; The prompt character is in the name, so highlight + ;; it on graphical terminals. + (graphical-terminal + (setq name (copy-sequence name)) + (put-text-property pos (1+ pos) + 'face 'read-multiple-choice-face + name) + name) + ;; And put it in [bracket] on non-graphical terminals. + (t + (concat + (substring name 0 pos) + "[" + (upcase (substring name pos (1+ pos))) + "]" + (substring name (1+ pos))))))) + (cons char altered-name))) + +(defun rmc--show-help (prompt help-string show-help choices altered-names) + (let* ((buf-name (if (stringp show-help) + show-help + "*Multiple Choice Help*")) + (buf (get-buffer-create buf-name))) + (if (stringp help-string) + (with-help-window buf + (with-current-buffer buf + (insert help-string))) + (with-help-window buf + (with-current-buffer buf + (erase-buffer) + (pop-to-buffer buf) + (insert prompt "\n\n") + (let* ((columns (/ (window-width) 25)) + (fill-column 21) + (times 0) + (start (point))) + (dolist (elem choices) + (goto-char start) + (unless (zerop times) + (if (zerop (mod times columns)) + ;; Go to the next "line". + (goto-char (setq start (point-max))) + ;; Add padding. + (while (not (eobp)) + (end-of-line) + (insert (make-string (max (- (* (mod times columns) + (+ fill-column 4)) + (current-column)) + 0) + ?\s)) + (forward-line 1)))) + (setq times (1+ times)) + (let ((text + (with-temp-buffer + (insert (format + "%c: %s\n" + (car elem) + (cdr (assq (car elem) altered-names)))) + (fill-region (point-min) (point-max)) + (when (nth 2 elem) + (let ((start (point))) + (insert (nth 2 elem)) + (unless (bolp) + (insert "\n")) + (fill-region start (point-max)))) + (buffer-string)))) + (goto-char start) + (dolist (line (split-string text "\n")) + (end-of-line) + (if (not (bolp)) + (insert line) + (insert (make-string + (max (- (* (mod (1- times) columns) + (+ fill-column 4)) + (current-column)) + 0) + ?\s)) + (insert line "\n")) + (forward-line 1)))))))) + buf)) + ;;;###autoload -(defun read-multiple-choice (prompt choices &optional help-string) +(defun read-multiple-choice (prompt choices &optional help-string show-help) "Ask user to select an entry from CHOICES, promting with PROMPT. This function allows to ask the user a multiple-choice question. @@ -42,6 +141,9 @@ the optional argument HELP-STRING. This argument is a string that should contain a more detailed description of all of the possible choices. `read-multiple-choice' will display that description in a help buffer if the user requests that. +If optional argument SHOW-HELP is non-nil, show the help screen +immediately, before any user input. If SHOW-HELP is a string, +use it as the name of the help buffer. This function translates user input into responses by consulting the bindings in `query-replace-map'; see the documentation of @@ -67,45 +169,20 @@ Usage example: \\='((?a \"always\") (?s \"session only\") (?n \"no\")))" - (let* ((altered-names nil) + (let* ((prompt-choices + (if show-help choices (append choices '((?? "?"))))) + (altered-names (mapcar #'rmc--add-key-description prompt-choices)) (full-prompt (format "%s (%s): " prompt - (mapconcat - (lambda (elem) - (let* ((name (cadr elem)) - (pos (seq-position name (car elem))) - (altered-name - (cond - ;; Not in the name string. - ((not pos) - (format "[%c] %s" (car elem) name)) - ;; The prompt character is in the name, so highlight - ;; it on graphical terminals... - ((display-supports-face-attributes-p - '(:underline t) (window-frame)) - (setq name (copy-sequence name)) - (put-text-property pos (1+ pos) - 'face 'read-multiple-choice-face - name) - name) - ;; And put it in [bracket] on non-graphical terminals. - (t - (concat - (substring name 0 pos) - "[" - (upcase (substring name pos (1+ pos))) - "]" - (substring name (1+ pos))))))) - (push (cons (car elem) altered-name) - altered-names) - altered-name)) - (append choices '((?? "?"))) - ", "))) + (mapconcat (lambda (e) (cdr e)) altered-names ", "))) tchar buf wrong-char answer) (save-window-excursion (save-excursion + (if show-help + (setq buf (rmc--show-help prompt help-string show-help + choices altered-names))) (while (not tchar) (message "%s%s" (if wrong-char @@ -124,7 +201,7 @@ Usage example: (lambda (elem) (cons (capitalize (cadr elem)) (car elem))) - choices))) + prompt-choices))) (condition-case nil (let ((cursor-in-echo-area t)) (read-event)) @@ -161,57 +238,8 @@ Usage example: tchar nil) (when wrong-char (ding)) - (setq buf (get-buffer-create "*Multiple Choice Help*")) - (if (stringp help-string) - (with-help-window buf - (with-current-buffer buf - (insert help-string))) - (with-help-window buf - (with-current-buffer buf - (erase-buffer) - (pop-to-buffer buf) - (insert prompt "\n\n") - (let* ((columns (/ (window-width) 25)) - (fill-column 21) - (times 0) - (start (point))) - (dolist (elem choices) - (goto-char start) - (unless (zerop times) - (if (zerop (mod times columns)) - ;; Go to the next "line". - (goto-char (setq start (point-max))) - ;; Add padding. - (while (not (eobp)) - (end-of-line) - (insert (make-string (max (- (* (mod times columns) - (+ fill-column 4)) - (current-column)) - 0) - ?\s)) - (forward-line 1)))) - (setq times (1+ times)) - (let ((text - (with-temp-buffer - (insert (format - "%c: %s\n" - (car elem) - (cdr (assq (car elem) altered-names)))) - (fill-region (point-min) (point-max)) - (when (nth 2 elem) - (let ((start (point))) - (insert (nth 2 elem)) - (unless (bolp) - (insert "\n")) - (fill-region start (point-max)))) - (buffer-string)))) - (goto-char start) - (dolist (line (split-string text "\n")) - (end-of-line) - (if (bolp) - (insert line "\n") - (insert line)) - (forward-line 1)))))))))))) + (setq buf (rmc--show-help prompt help-string show-help + choices altered-names)))))) (when (buffer-live-p buf) (kill-buffer buf)) (assq tchar choices))) diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index abfe51d32b5..133d3c9e118 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -299,6 +299,7 @@ sorted. FUNCTION must be a function of one argument." TYPE must be one of following symbols: vector, string or list. \n(fn TYPE SEQUENCE...)" + (setq sequences (mapcar #'seq-into-sequence sequences)) (pcase type ('vector (apply #'vconcat sequences)) ('string (apply #'concat sequences)) @@ -402,23 +403,23 @@ found or not." (setq count (+ 1 count)))) count)) -(with-suppressed-warnings ((obsolete seq-contains)) - (cl-defgeneric seq-contains (sequence elt &optional testfn) - "Return the first element in SEQUENCE that is equal to ELT. +(cl-defgeneric seq-contains (sequence elt &optional testfn) + "Return the first element in SEQUENCE that is equal to ELT. Equality is defined by TESTFN if non-nil or by `equal' if nil." - (declare (obsolete seq-contains-p "27.1")) - (seq-some (lambda (e) - (when (funcall (or testfn #'equal) elt e) - e)) - sequence))) + (declare (obsolete seq-contains-p "27.1")) + (seq-some (lambda (e) + (when (funcall (or testfn #'equal) elt e) + e)) + sequence)) (cl-defgeneric seq-contains-p (sequence elt &optional testfn) "Return non-nil if SEQUENCE contains an element equal to ELT. Equality is defined by TESTFN if non-nil or by `equal' if nil." (catch 'seq--break (seq-doseq (e sequence) - (when (funcall (or testfn #'equal) e elt) - (throw 'seq--break t))) + (let ((r (funcall (or testfn #'equal) e elt))) + (when r + (throw 'seq--break r)))) nil)) (cl-defgeneric seq-set-equal-p (sequence1 sequence2 &optional testfn) diff --git a/lisp/emacs-lisp/shadow.el b/lisp/emacs-lisp/shadow.el index 2c83bc7b503..2343a9b589f 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) @@ -180,12 +177,11 @@ See the documentation for `list-load-path-shadows' for further information." . (1 font-lock-warning-face))) "Keywords to highlight in `load-path-shadows-mode'.") -(define-derived-mode load-path-shadows-mode fundamental-mode "LP-Shadows" +(define-derived-mode load-path-shadows-mode special-mode "LP-Shadows" "Major mode for `load-path' shadows buffer." (setq-local font-lock-defaults '((load-path-shadows-font-lock-keywords))) - (setq buffer-undo-list t - buffer-read-only t)) + (setq buffer-undo-list t)) ;; TODO use text-properties instead, a la dired. (define-button-type 'load-path-shadows-find-file diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el index 99035c9e892..92b9c1dd32e 100644 --- a/lisp/emacs-lisp/shortdoc.el +++ b/lisp/emacs-lisp/shortdoc.el @@ -47,30 +47,68 @@ "Add GROUP to the list of defined documentation groups. FUNCTIONS is a list of elements on the form: - (fun + (FUNC :no-manual BOOL :args ARGS - :eval EXAMPLE-FORM + :eval EVAL :no-eval EXAMPLE-FORM - :no-eval* EXAMPLE-FORM :no-value EXAMPLE-FORM + :no-eval* EXAMPLE-FORM :result RESULT-FORM - :result-string RESULT-FORM + :result-string RESULT-STRING :eg-result RESULT-FORM - :eg-result-string RESULT-FORM) + :eg-result-string RESULT-STRING) + +FUNC is the function being documented. -BOOL should be non-nil if the function isn't documented in the +NO-MANUAL should be non-nil if FUNC isn't documented in the manual. -ARGS is optional; the function's signature is displayed if ARGS -is not present. +ARGS is optional list of function FUNC's arguments. FUNC's +signature is displayed automatically if ARGS is not present. +Specifying ARGS might be useful where you don't want to document +some of the uncommon arguments a function might have. + +While the `:no-manual' and `:args' property can be used for +any (FUNC ..) form, all of the other properties shown above +cannot be used simultaneously in such a form. + +Here are some common forms with examples of properties that go +together: + +1. Document a form or string, and its evaluated return value. + (FUNC + :eval EVAL) + +If EVAL is a string, it will be inserted as is, and then that +string will be `read' and evaluated. + +2. Document a form or string, but manually document its evaluation + result. The provided form will not be evaluated. + + (FUNC + :no-eval EXAMPLE-FORM + :result RESULT-FORM ;Use `:result-string' if value is in string form + ) + +Using `:no-value' is the same as using `:no-eval'. + +Use `:no-eval*' instead of `:no-eval' where the successful +execution of the documented form depends on some conditions. -If EVAL isn't a string, it will be printed with `prin1', and then -evaluated to give a result, which is also printed. If it's a -string, it'll be inserted as is, then the string will be `read', -and then evaluated. +3. Document a form or string EXAMPLE-FORM. Also manually + document an example result. This result could be unrelated to + the documented form. -There can be any number of :example/:result elements." + (FUNC + :no-eval EXAMPLE-FORM + :eg-result RESULT-FORM ;Use `:eg-result-string' if value is in string form + ) + +A FUNC form can have any number of `:no-eval' (or `:no-value'), +`:no-eval*', `:result', `:result-string', `:eg-result' and +`:eg-result-string' properties." + (declare (indent defun)) `(progn (setq shortdoc--groups (delq (assq ',group shortdoc--groups) shortdoc--groups)) @@ -195,6 +233,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")) @@ -215,11 +260,16 @@ There can be any number of :example/:result elements." :no-manual t :eval (string-blank-p " \n")) (string-lessp - :eval (string-lessp "foo" "bar")) + :eval (string-lessp "foo" "bar") + :eval (string-lessp "pic4.png" "pic32.png") + :eval (string-lessp "1.1" "1 2")) (string-greaterp :eval (string-greaterp "foo" "bar")) (string-version-lessp - :eval (string-version-lessp "pic4.png" "pic32.png")) + :eval (string-version-lessp "pic4.png" "pic32.png") + :eval (string-version-lessp "1.1" "1 2")) + (string-collate-lessp + :eval (string-collate-lessp "1.1" "1 2")) (string-prefix-p :eval (string-prefix-p "foo" "foobar")) (string-suffix-p @@ -241,7 +291,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 +328,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 +408,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,17 +1269,54 @@ 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) +(defun shortdoc-display-group (group &optional function same-window) "Pop to a buffer with short documentation summary for functions in GROUP. -If FUNCTION is non-nil, place point on the entry for FUNCTION (if any)." +If FUNCTION is non-nil, place point on the entry for FUNCTION (if any). +If SAME-WINDOW, don't pop to a new window." (interactive (list (completing-read "Show summary for functions in: " (mapcar #'car shortdoc--groups)))) (when (stringp group) (setq group (intern group))) (unless (assq group shortdoc--groups) (error "No such documentation group %s" group)) - (pop-to-buffer (format "*Shortdoc %s*" group)) + (funcall (if same-window + #'pop-to-buffer-same-window + #'pop-to-buffer) + (format "*Shortdoc %s*" group)) (let ((inhibit-read-only t) (prev nil)) (erase-buffer) @@ -1245,6 +1345,9 @@ If FUNCTION is non-nil, place point on the entry for FUNCTION (if any)." (text-property-search-forward 'shortdoc-function function t) (beginning-of-line))) +;;;###autoload +(defalias 'shortdoc #'shortdoc-display-group) + (defun shortdoc--display-function (data) (let ((function (pop data)) (start-section (point)) @@ -1351,11 +1454,14 @@ function's documentation in the Info manual"))) If GROUP doesn't exist, it will be created. If SECTION doesn't exist, it will be added. +ELEM is a Lisp form. See `define-short-documentation-group' for +details. + Example: (shortdoc-add-function - 'file \"Predicates\" - '(file-locked-p :no-eval (file-locked-p \"/tmp\")))" + \\='file \"Predicates\" + \\='(file-locked-p :no-eval (file-locked-p \"/tmp\")))" (let ((glist (assq group shortdoc--groups))) (unless glist (setq glist (list group)) @@ -1369,14 +1475,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/smie.el b/lisp/emacs-lisp/smie.el index b2283e66e4f..61d52026b38 100644 --- a/lisp/emacs-lisp/smie.el +++ b/lisp/emacs-lisp/smie.el @@ -1301,9 +1301,9 @@ Only meaningful when called from within `smie-rules-function'." (let ((afterpos (save-excursion (let ((tok (funcall smie-forward-token-function))) (unless tok - (with-demoted-errors - (error "smie-rule-separator: Can't skip token %s" - smie--token)))) + (funcall (if debug-on-error #'error #'message) + "smie-rule-separator: Can't skip token %s" + smie--token))) (skip-chars-forward " ") (unless (eolp) (point))))) (or (and afterpos @@ -1820,7 +1820,7 @@ to which that point should be aligned, if we were to reindent it.") "Indent current line using the SMIE indentation engine." (interactive) (let* ((savep (point)) - (indent (or (with-demoted-errors + (indent (or (with-demoted-errors "SMIE Error: %S" (save-excursion (forward-line 0) (skip-chars-forward " \t") @@ -1846,7 +1846,9 @@ to which that point should be aligned, if we were to reindent it.") (move-to-column fc) (syntax-ppss)))) (while - (and (with-demoted-errors + ;; We silence the error completely since errors are "normal" in + ;; some cases and an error message would be annoying (bug#19342). + (and (ignore-error scan-error (save-excursion (let ((end (point)) (bsf nil) ;Best-so-far. diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index 9529d51e40b..9cd793d05c5 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -81,116 +81,6 @@ Note how the single `-' got converted into a list before threading." (declare (indent 0) (debug thread-first)) `(internal--thread-argument nil ,@forms)) - -(defsubst internal--listify (elt) - "Wrap ELT in a list if it is not one. -If ELT is of the form ((EXPR)), listify (EXPR) with a dummy symbol." - (cond - ((symbolp elt) (list elt elt)) - ((null (cdr elt)) - (list (make-symbol "s") (car elt))) - (t elt))) - -(defsubst internal--check-binding (binding) - "Check BINDING is properly formed." - (when (> (length binding) 2) - (signal - 'error - (cons "`let' bindings can have only one value-form" binding))) - binding) - -(defsubst internal--build-binding-value-form (binding prev-var) - "Build the conditional value form for BINDING using PREV-VAR." - (let ((var (car binding))) - `(,var (and ,prev-var ,(cadr binding))))) - -(defun internal--build-binding (binding prev-var) - "Check and build a single BINDING with PREV-VAR." - (thread-first - binding - internal--listify - internal--check-binding - (internal--build-binding-value-form prev-var))) - -(defun internal--build-bindings (bindings) - "Check and build conditional value forms for BINDINGS." - (let ((prev-var t)) - (mapcar (lambda (binding) - (let ((binding (internal--build-binding binding prev-var))) - (setq prev-var (car binding)) - binding)) - bindings))) - -(defmacro if-let* (varlist then &rest else) - "Bind variables according to VARLIST and evaluate THEN or ELSE. -This is like `if-let' but doesn't handle a VARLIST of the form -\(SYMBOL SOMETHING) specially." - (declare (indent 2) - (debug ((&rest [&or symbolp (symbolp form) (form)]) - body))) - (if varlist - `(let* ,(setq varlist (internal--build-bindings varlist)) - (if ,(caar (last varlist)) - ,then - ,@else)) - `(let* () ,then))) - -(defmacro when-let* (varlist &rest body) - "Bind variables according to VARLIST and conditionally evaluate BODY. -This is like `when-let' but doesn't handle a VARLIST of the form -\(SYMBOL SOMETHING) specially." - (declare (indent 1) (debug if-let*)) - (list 'if-let* varlist (macroexp-progn body))) - -(defmacro and-let* (varlist &rest body) - "Bind variables according to VARLIST and conditionally evaluate BODY. -Like `when-let*', except if BODY is empty and all the bindings -are non-nil, then the result is non-nil." - (declare (indent 1) (debug if-let*)) - (let (res) - (if varlist - `(let* ,(setq varlist (internal--build-bindings varlist)) - (when ,(setq res (caar (last varlist))) - ,@(or body `(,res)))) - `(let* () ,@(or body '(t)))))) - -;;;###autoload -(defmacro if-let (spec then &rest else) - "Bind variables according to SPEC and evaluate THEN or ELSE. -Evaluate each binding in turn, as in `let*', stopping if a -binding value is nil. If all are non-nil return the value of -THEN, otherwise the last form in ELSE. - -Each element of SPEC is a list (SYMBOL VALUEFORM) that binds -SYMBOL to the value of VALUEFORM. An element can additionally be -of the form (VALUEFORM), which is evaluated and checked for nil; -i.e. SYMBOL can be omitted if only the test result is of -interest. It can also be of the form SYMBOL, then the binding of -SYMBOL is checked for nil. - -As a special case, interprets a SPEC of the form \(SYMBOL SOMETHING) -like \((SYMBOL SOMETHING)). This exists for backward compatibility -with an old syntax that accepted only one binding." - (declare (indent 2) - (debug ([&or (symbolp form) ; must be first, Bug#48489 - (&rest [&or symbolp (symbolp form) (form)])] - body))) - (when (and (<= (length spec) 2) - (not (listp (car spec)))) - ;; Adjust the single binding case - (setq spec (list spec))) - (list 'if-let* spec then (macroexp-progn else))) - -;;;###autoload -(defmacro when-let (spec &rest body) - "Bind variables according to SPEC and conditionally evaluate BODY. -Evaluate each binding in turn, stopping if a binding value is nil. -If all are non-nil, return the value of the last form in BODY. - -The variable list SPEC is the same as in `if-let'." - (declare (indent 1) (debug if-let)) - (list 'if-let spec (macroexp-progn body))) - (defsubst hash-table-empty-p (hash-table) "Check whether HASH-TABLE is empty (has 0 elements)." (zerop (hash-table-count hash-table))) @@ -208,7 +98,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") @@ -318,12 +210,6 @@ than this function." (end (substring string (- (length string) length))) (t (substring string 0 length))))) -;;;###autoload -(defun string-lines (string &optional omit-nulls) - "Split STRING into a list of lines. -If OMIT-NULLS, empty lines will be removed from the results." - (split-string string "\n" omit-nulls)) - (defun string-pad (string length &optional padding start) "Pad STRING to LENGTH using PADDING. If PADDING is nil, the space character is used. If not nil, it @@ -400,6 +286,172 @@ 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 string-pixel-width (string) + "Return the width of STRING in pixels." + (if (zerop (length string)) + 0 + ;; Keeping a work buffer around is more efficient than creating a + ;; new temporary buffer. + (with-current-buffer (get-buffer-create " *string-pixel-width*") + (delete-region (point-min) (point-max)) + (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)))) + +;;;###autoload +(defun read-process-name (prompt) + "Query the user for a process and return the process object." + ;; Currently supports only the PROCESS argument. + ;; Must either return a list containing a process, or signal an error. + ;; (Returning `nil' would mean the current buffer's process.) + (unless (fboundp 'process-list) + (error "Asynchronous subprocesses are not supported on this system")) + ;; Local function to return cons of a complete-able name, and the + ;; associated process object, for use with `completing-read'. + (cl-flet ((procitem + (p) (when (process-live-p p) + (let ((pid (process-id p)) + (procname (process-name p)) + (procbuf (process-buffer p))) + (and (eq (process-type p) 'real) + (cons (if procbuf + (format "%s (%s) in buffer %s" + procname pid + (buffer-name procbuf)) + (format "%s (%s)" procname pid)) + p)))))) + ;; Perform `completing-read' for a process. + (let* ((currproc (get-buffer-process (current-buffer))) + (proclist (or (process-list) + (error "No processes found"))) + (collection (delq nil (mapcar #'procitem proclist))) + (selection (completing-read + (format-prompt prompt + (and currproc + (eq (process-type currproc) 'real) + (procitem currproc))) + collection nil :require-match nil nil + (car (seq-find (lambda (proc) + (eq currproc (cdr proc))) + collection)))) + (process (and selection + (cdr (assoc selection collection))))) + (unless process + (error "No process selected")) + process))) + +(defmacro with-buffer-unmodified-if-unchanged (&rest body) + "Like `progn', but change buffer-modified status only if buffer text changes. +If the buffer was unmodified before execution of BODY, and +buffer text after execution of BODY is identical to what it was +before, ensure that buffer is still marked unmodified afterwards. +For example, the following won't change the buffer's modification +status: + + (with-buffer-unmodified-if-unchanged + (insert \"a\") + (delete-char -1)) + +Note that only changes in the raw byte sequence of the buffer text, +as stored in the internal representation, are monitored for the +purpose of detecting the lack of changes in buffer text. Any other +changes that are normally perceived as \"buffer modifications\", such +as changes in text properties, `buffer-file-coding-system', buffer +multibyteness, etc. -- will not be noticed, and the buffer will still +be marked unmodified, effectively ignoring those changes." + (declare (debug t) (indent 0)) + (let ((hash (gensym)) + (buffer (gensym))) + `(let ((,hash (and (not (buffer-modified-p)) + (buffer-hash))) + (,buffer (current-buffer))) + (prog1 + (progn + ,@body) + ;; If we didn't change anything in the buffer (and the buffer + ;; was previously unmodified), then flip the modification status + ;; back to "unchanged". + (when (and ,hash (buffer-live-p ,buffer)) + (with-current-buffer ,buffer + (when (and (buffer-modified-p) + (equal ,hash (buffer-hash))) + (restore-buffer-modified-p nil)))))))) (provide 'subr-x) diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index 3d944bf5e16..7d815a3cedc 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.") @@ -255,18 +264,14 @@ variables `tabulated-list-tty-sort-indicator-asc' and Populated by `tabulated-list-init-header'.") (defvar tabulated-list--header-overlay nil) -(defun tabulated-list-line-number-width () - "Return the width taken by `display-line-numbers' in the current buffer." - ;; line-number-display-width returns the value for the selected - ;; window, which might not be the window in which the current buffer - ;; is displayed. - (if (not display-line-numbers) - 0 - (let ((cbuf-window (get-buffer-window (current-buffer) t))) - (if (window-live-p cbuf-window) - (with-selected-window cbuf-window - (line-number-display-width 'columns)) - 4)))) +(define-obsolete-function-alias 'tabulated-list-line-number-width + 'header-line-indent--line-number-width "29.1") +(define-obsolete-function-alias 'tabulated-list-watch-line-number-width + 'header-line-indent--watch-line-number-width "29.1") +(define-obsolete-function-alias 'tabulated-list-watch-line-number-width + 'header-line-indent--watch-line-number-width "29.1") +(define-obsolete-function-alias 'tabulated-list-window-scroll-function + 'header-line-indent--window-scroll-function "29.1") (defun tabulated-list-init-header () "Set up header line for the Tabulated List buffer." @@ -280,9 +285,9 @@ Populated by `tabulated-list-init-header'.") (hcols (mapcar #'car tabulated-list-format)) (tabulated-list--near-rows (list hcols hcols)) (cols nil)) - (if display-line-numbers - (setq x (+ x (tabulated-list-line-number-width)))) - (push (propertize " " 'display `(space :align-to ,x)) cols) + (push (propertize " " 'display + `(space :align-to (+ header-line-indent-width ,x))) + cols) (dotimes (n len) (let* ((col (aref tabulated-list-format n)) (not-last-col (< n (1- len))) @@ -333,20 +338,25 @@ Populated by `tabulated-list-init-header'.") (when (> shift 0) (setq cols (cons (car cols) - (cons (propertize (make-string shift ?\s) - 'display - `(space :align-to ,(+ x shift))) - (cdr cols)))) + (cons + (propertize + (make-string shift ?\s) + 'display + `(space :align-to + (+ header-line-indent-width ,(+ x shift)))) + (cdr cols)))) (setq x (+ x shift))))) (if (>= pad-right 0) - (push (propertize " " - 'display `(space :align-to ,next-x) - 'face 'fixed-pitch) + (push (propertize + " " + 'display `(space :align-to + (+ header-line-indent-width ,next-x)) + 'face 'fixed-pitch) cols)) (setq x next-x))) (setq cols (apply 'concat (nreverse cols))) (if tabulated-list-use-header-line - (setq header-line-format cols) + (setq header-line-format (list "" 'header-line-indent cols)) (setq-local tabulated-list--header-string cols)))) (defun tabulated-list-print-fake-header () @@ -547,7 +557,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 +583,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 @@ -668,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 @@ -712,6 +732,7 @@ Interactively, N is the prefix numeric argument, and defaults to 1." (interactive "p") (let ((start (current-column)) + (entry (tabulated-list-get-entry)) (nb-cols (length tabulated-list-format)) (col-nb 0) (total-width 0) @@ -719,14 +740,25 @@ Interactively, N is the prefix numeric argument, and defaults to col-width) (while (and (not found) (< col-nb nb-cols)) - (if (> start - (setq total-width - (+ total-width - (setq col-width - (cadr (aref tabulated-list-format - col-nb)))))) + (if (>= start + (setq total-width + (+ total-width + (max (setq col-width + (cadr (aref tabulated-list-format + col-nb))) + (let ((desc (aref entry col-nb))) + (string-width (if (stringp desc) + desc + (car desc))))) + (or (plist-get (nthcdr 3 (aref tabulated-list-format + col-nb)) + :pad-right) + 1)))) (setq col-nb (1+ col-nb)) (setq found t) + ;; `tabulated-list-format' may be a constant (sharing list + ;; structures), so copy it before mutating. + (setq tabulated-list-format (copy-tree tabulated-list-format t)) (setf (cadr (aref tabulated-list-format col-nb)) (max 1 (+ col-width n))) (tabulated-list-print t) @@ -739,23 +771,6 @@ Interactively, N is the prefix numeric argument, and defaults to (interactive "p") (tabulated-list-widen-current-column (- n))) -(defvar tabulated-list--current-lnum-width nil) -(defun tabulated-list-watch-line-number-width (_window) - (if display-line-numbers - (let ((lnum-width (tabulated-list-line-number-width))) - (when (not (= tabulated-list--current-lnum-width lnum-width)) - (setq-local tabulated-list--current-lnum-width lnum-width) - (tabulated-list-init-header))))) - -(defun tabulated-list-window-scroll-function (window _start) - (if display-line-numbers - (let ((lnum-width - (with-selected-window window - (line-number-display-width 'columns)))) - (when (not (= tabulated-list--current-lnum-width lnum-width)) - (setq-local tabulated-list--current-lnum-width lnum-width) - (tabulated-list-init-header))))) - (defun tabulated-list-next-column (&optional arg) "Go to the start of the next column after point on the current line. If ARG is provided, move that many columns." @@ -826,15 +841,7 @@ as the ewoc pretty-printer." ;; Avoid messing up the entries' display just because the first ;; column of the first entry happens to begin with a R2L letter. (setq bidi-paragraph-direction 'left-to-right) - ;; This is for if/when they turn on display-line-numbers - (add-hook 'display-line-numbers-mode-hook #'tabulated-list-revert nil t) - ;; This is for if/when they customize the line-number face or when - ;; the line-number width needs to change due to scrolling. - (setq-local tabulated-list--current-lnum-width 0) - (add-hook 'pre-redisplay-functions - #'tabulated-list-watch-line-number-width nil t) - (add-hook 'window-scroll-functions - #'tabulated-list-window-scroll-function nil t)) + (header-line-indent-mode)) (put 'tabulated-list-mode 'mode-class 'special) diff --git a/lisp/emacs-lisp/text-property-search.el b/lisp/emacs-lisp/text-property-search.el index 9f86a28eb64..d11980f4f45 100644 --- a/lisp/emacs-lisp/text-property-search.el +++ b/lisp/emacs-lisp/text-property-search.el @@ -47,7 +47,7 @@ match if is not `equal' to VALUE. Furthermore, a nil PREDICATE means that the match region is ended if the value changes. For instance, this means that if you loop with - (while (setq prop (text-property-search-forward 'face)) + (while (setq prop (text-property-search-forward \\='face)) ...) you will get all distinct regions with non-nil `face' values in @@ -166,7 +166,6 @@ and if a matching region is found, place point at the start of the region." (let ((origin (point)) (ended nil) pos) - (forward-char -1) ;; Find the previous candidate. (while (not ended) (setq pos (previous-single-property-change (point) property)) diff --git a/lisp/emacs-lisp/timer-list.el b/lisp/emacs-lisp/timer-list.el index c93a50cabfe..aef18d0ba27 100644 --- a/lisp/emacs-lisp/timer-list.el +++ b/lisp/emacs-lisp/timer-list.el @@ -62,7 +62,7 @@ ((numberp repeat) (propertize (format "%12s" (format-seconds - "%dd %hh %mm %z%,1ss" repeat)) + "%x%dd %hh %mm %z%,1ss" repeat)) 'help-echo "Repeat interval")) ((null repeat) (propertize " -" 'help-echo "Runs once")) diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el index 27359dfbfce..fd29abf40a3 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/trace.el b/lisp/emacs-lisp/trace.el index 71eca5a3230..165f5c7bfe2 100644 --- a/lisp/emacs-lisp/trace.el +++ b/lisp/emacs-lisp/trace.el @@ -172,9 +172,10 @@ You can call this function to add internal values in the trace buffer." LEVEL is the trace level, ARGS is the list of arguments passed to FUNCTION, and CONTEXT is a string describing the dynamic context (e.g. values of some global variables)." - (let ((print-circle t)) + (let ((print-circle t) + (print-escape-newlines t)) (format "%s%s%d -> %S%s\n" - (mapconcat 'char-to-string (make-string (max 0 (1- level)) ?|) " ") + (mapconcat #'char-to-string (make-string (max 0 (1- level)) ?|) " ") (if (> level 1) " " "") level ;; FIXME: Make it so we can click the function name to jump to its @@ -187,7 +188,8 @@ some global variables)." LEVEL is the trace level, VALUE value returned by FUNCTION, and CONTEXT is a string describing the dynamic context (e.g. values of some global variables)." - (let ((print-circle t)) + (let ((print-circle t) + (print-escape-newlines t)) (format "%s%s%d <- %s: %S%s\n" (mapconcat 'char-to-string (make-string (1- level) ?|) " ") (if (> level 1) " " "") @@ -278,7 +280,8 @@ If `current-prefix-arg' is non-nil, also read a buffer and a \"context\" nil read-expression-map t 'read-expression-history)))) (lambda () - (let ((print-circle t)) + (let ((print-circle t) + (print-escape-newlines t)) (concat " [" (prin1-to-string (eval exp t)) "]")))))))) ;;;###autoload diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el new file mode 100644 index 00000000000..61265c97c28 --- /dev/null +++ b/lisp/emacs-lisp/vtable.el @@ -0,0 +1,976 @@ +;;; vtable.el --- Displaying data in tables -*- lexical-binding: t; -*- + +;; Copyright (C) 2022 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) +(require 'eieio) +(require 'text-property-search) +(require 'mule-util) + +(defface vtable + '((t :inherit variable-pitch)) + "Face used (by default) for vtables." + :version "29.1" + :group 'faces) + +(cl-defstruct vtable-column + "A vtable column." + name + width + min-width + max-width + primary + align + getter + formatter + displayer + -numerical) + +(defclass vtable () + ((columns :initarg :columns :accessor vtable-columns) + (objects :initarg :objects :accessor vtable-objects) + (objects-function :initarg :objects-function + :accessor vtable-objects-function) + (getter :initarg :getter :accessor vtable-getter) + (formatter :initarg :formatter :accessor vtable-formatter) + (displayer :initarg :displayer :accessor vtable-displayer) + (use-header-line :initarg :use-header-line + :accessor vtable-use-header-line) + (face :initarg :face :accessor vtable-face) + (actions :initarg :actions :accessor vtable-actions) + (keymap :initarg :keymap :accessor vtable-keymap) + (separator-width :initarg :separator-width :accessor vtable-separator-width) + (divider :initarg :divider :accessor vtable-divider :initform nil) + (sort-by :initarg :sort-by :accessor vtable-sort-by) + (ellipsis :initarg :ellipsis :accessor vtable-ellipsis) + (column-colors :initarg :column-colors :accessor vtable-column-colors) + (row-colors :initarg :row-colors :accessor vtable-row-colors) + (-cached-colors :initform nil) + (-cache :initform (make-hash-table :test #'equal)) + (-cached-keymap :initform nil) + (-has-column-spec :initform nil)) + "An object to hold the data for a table.") + +(defvar-keymap vtable-map + "S" #'vtable-sort-by-current-column + "{" #'vtable-narrow-current-column + "}" #'vtable-widen-current-column + "g" #'vtable-revert-command + "M-<left>" #'vtable-previous-column + "M-<right>" #'vtable-next-column) + +(defvar-keymap vtable-header-line-map + :parent vtable-map + "<follow-link>" 'mouse-face + "<mouse-2>" #'vtable-header-line-sort) + +(cl-defun make-vtable (&key columns objects objects-function + getter + formatter + displayer + (use-header-line t) + (face 'vtable) + actions keymap + (separator-width 1) + divider + divider-width + sort-by + (ellipsis t) + (insert t) + row-colors + column-colors) + "Create and insert a vtable at point. +The vtable object is returned. If INSERT is nil, the table won't +be inserted. + +See info node `(vtable)Top' for vtable documentation." + (when objects-function + (setq objects (funcall objects-function))) + ;; We'll be altering the list, so create a copy. + (setq objects (copy-sequence objects)) + (let ((table + (make-instance + 'vtable + :objects objects + :objects-function objects-function + :getter getter + :formatter formatter + :displayer displayer + :use-header-line use-header-line + :face face + :actions actions + :keymap keymap + :separator-width separator-width + :sort-by sort-by + :row-colors row-colors + :column-colors column-colors + :ellipsis ellipsis))) + ;; Store whether the user has specified columns or not. + (setf (slot-value table '-has-column-spec) (not (not columns))) + ;; Auto-generate the columns. + (unless columns + (unless objects + (error "Can't auto-generate columns; no objects")) + (setq columns (make-list (length (car objects)) ""))) + (setf (vtable-columns table) + (mapcar (lambda (column) + (cond + ;; We just have the name (as a string). + ((stringp column) + (make-vtable-column :name column)) + ;; A plist of keywords/values. + ((listp column) + (apply #'make-vtable-column column)) + ;; A full `vtable-column' object. + (t + column))) + columns)) + ;; Compute missing column data. + (setf (vtable-columns table) (vtable--compute-columns table)) + ;; Compute the colors. + (when (or row-colors column-colors) + (setf (slot-value table '-cached-colors) + (vtable--compute-colors row-colors column-colors))) + ;; Compute the divider. + (when (or divider divider-width) + (setf (vtable-divider table) + (propertize + (or (copy-sequence divider) + (propertize + " " 'display + (list 'space :width + (list (vtable--compute-width table divider-width))))) + 'mouse-face 'highlight + 'keymap + (define-keymap + "<drag-mouse-1>" #'vtable--drag-resize-column + "<down-mouse-1>" #'ignore)))) + ;; Compute the keymap. + (setf (slot-value table '-cached-keymap) (vtable--make-keymap table)) + (unless sort-by + (seq-do-indexed (lambda (column index) + (when (vtable-column-primary column) + (push (cons index (vtable-column-primary column)) + (vtable-sort-by table)))) + (vtable-columns table))) + (when insert + (vtable-insert table)) + table)) + +(defun vtable--compute-colors (row-colors column-colors) + (cond + ((null column-colors) + (mapcar #'vtable--make-color-face row-colors)) + ((null row-colors) + (mapcar #'vtable--make-color-face column-colors)) + (t + (cl-loop for row in row-colors + collect (cl-loop for column in column-colors + collect (vtable--face-blend + (vtable--make-color-face row) + (vtable--make-color-face column))))))) + +(defun vtable--make-color-face (object) + (if (stringp object) + (list :background object) + object)) + +(defun vtable--face-blend (face1 face2) + (let ((foreground (vtable--face-color face1 face2 #'face-foreground + :foreground)) + (background (vtable--face-color face1 face2 #'face-background + :background))) + `(,@(and foreground (list :foreground foreground)) + ,@(and background (list :background background))))) + +(defun vtable--face-color (face1 face2 accessor slot) + (let ((col1 (if (facep face1) + (funcall accessor face1) + (plist-get face1 slot))) + (col2 (if (facep face2) + (funcall accessor face2) + (plist-get face2 slot)))) + (if (and col1 col2) + (vtable--color-blend col1 col2) + (or col1 col2)))) + +;;; FIXME: This is probably not the right way to blend two colors, is +;;; it? +(defun vtable--color-blend (color1 color2) + (cl-destructuring-bind (r g b) + (mapcar (lambda (n) (* (/ n 2) 255.0)) + (cl-mapcar #'+ (color-name-to-rgb color1) + (color-name-to-rgb color2))) + (format "#%02X%02X%02X" r g b))) + +;;; Interface utility functions. + +(defun vtable-current-table () + "Return the table under point." + (get-text-property (point) 'vtable)) + +(defun vtable-current-object () + "Return the object under point." + (get-text-property (point) 'vtable-object)) + +(defun vtable-current-column () + "Return the index of the column under point." + (get-text-property (point) 'vtable-column)) + +(defun vtable-beginning-of-table () + "Go to the start of the current table." + (if (text-property-search-backward 'vtable (vtable-current-table)) + (point) + (goto-char (point-min)))) + +(defun vtable-end-of-table () + "Go to the end of the current table." + (if (text-property-search-forward 'vtable (vtable-current-table)) + (point) + (goto-char (point-max)))) + +(defun vtable-goto-object (object) + "Go to OBJECT in the current table. +Return the position of the object if found, and nil if not." + (let ((start (point))) + (vtable-beginning-of-table) + (save-restriction + (narrow-to-region (point) (save-excursion (vtable-end-of-table))) + (if (text-property-search-forward 'vtable-object object #'eq) + (progn + (forward-line -1) + (point)) + (goto-char start) + nil)))) + +(defun vtable-goto-table (table) + "Go to TABLE in the current buffer. +If TABLE is found, return the position of the start of the table. +If it can't be found, return nil and don't move point." + (let ((start (point))) + (goto-char (point-min)) + (if-let ((match (text-property-search-forward 'vtable table t))) + (goto-char (prop-match-beginning match)) + (goto-char start) + nil))) + +(defun vtable-goto-column (column) + "Go to COLUMN on the current line." + (beginning-of-line) + (if-let ((match (text-property-search-forward 'vtable-column column t))) + (goto-char (prop-match-beginning match)) + (end-of-line))) + +(defun vtable-update-object (table object old-object) + "Replace OLD-OBJECT in TABLE with OBJECT." + (let* ((objects (vtable-objects table)) + (inhibit-read-only t)) + ;; First replace the object in the object storage. + (if (eq old-object (car objects)) + ;; It's at the head, so replace it there. + (setf (vtable-objects table) + (cons object (cdr objects))) + ;; Otherwise splice into the list. + (while (and (cdr objects) + (not (eq (cadr objects) old-object))) + (setq objects (cdr objects))) + (unless objects + (error "Can't find the old object")) + (setcar (cdr objects) object)) + ;; Then update the cache... + (let* ((line-number (seq-position old-object (car (vtable--cache table)))) + (line (elt (car (vtable--cache table)) line-number))) + (unless line + (error "Can't find cached object")) + (setcar line object) + (setcdr line (vtable--compute-cached-line table object)) + ;; ... and redisplay the line in question. + (save-excursion + (vtable-goto-object old-object) + (let ((keymap (get-text-property (point) 'keymap)) + (start (point))) + (delete-line) + (vtable--insert-line table line line-number + (nth 1 (vtable--cache table)) + (vtable--spacer table)) + (add-text-properties start (point) (list 'keymap keymap + 'vtable table)))) + ;; We may have inserted a non-numerical value into a previously + ;; all-numerical table, so recompute. + (vtable--recompute-numerical table (cdr line))))) + +(defun vtable-remove-object (table object) + "Remove OBJECT from TABLE. +This will also remove the displayed line." + ;; First remove from the objects. + (setf (vtable-objects table) (delq object (vtable-objects table))) + ;; Then adjust the cache and display. + (let ((cache (vtable--cache table)) + (inhibit-read-only t)) + (setcar cache (delq (assq object (car cache)) (car cache))) + (save-excursion + (vtable-goto-table table) + (when (vtable-goto-object object) + (delete-line))))) + +(defun vtable-insert-object (table object &optional after-object) + "Insert OBJECT into TABLE after AFTER-OBJECT. +If AFTER-OBJECT is nil (or doesn't exist in the table), insert +OBJECT at the end. +This also updates the displayed table." + ;; First insert into the objects. + (let (pos) + (if (and after-object + (setq pos (memq after-object (vtable-objects table)))) + ;; Splice into list. + (setcdr pos (cons object (cdr pos))) + ;; Append. + (nconc (vtable-objects table) (list object)))) + ;; Then adjust the cache and display. + (save-excursion + (vtable-goto-table table) + (let* ((cache (vtable--cache table)) + (inhibit-read-only t) + (keymap (get-text-property (point) 'keymap)) + (elem (and after-object + (assq after-object (car cache)))) + (line (cons object (vtable--compute-cached-line table object)))) + (if (not elem) + ;; Append. + (progn + (setcar cache (nconc (car cache) (list line))) + (vtable-end-of-table)) + ;; Splice into list. + (let ((pos (memq elem (car cache)))) + (setcdr pos (cons line (cdr pos))) + (unless (vtable-goto-object after-object) + (vtable-end-of-table)))) + (let ((start (point))) + ;; FIXME: We have to adjust colors in lines below this if we + ;; have :row-colors. + (vtable--insert-line table line 0 + (nth 1 cache) (vtable--spacer table)) + (add-text-properties start (point) (list 'keymap keymap + 'vtable table))) + ;; We may have inserted a non-numerical value into a previously + ;; all-numerical table, so recompute. + (vtable--recompute-numerical table (cdr line))))) + +(defun vtable-column (table index) + "Return the name of the INDEXth column in TABLE." + (vtable-column-name (elt (vtable-columns table) index))) + +;;; Generating the table. + +(defun vtable--get-value (object index column table) + "Compute a cell value." + (cond + ((vtable-column-getter column) + (funcall (vtable-column-getter column) + object table)) + ((vtable-getter table) + (funcall (vtable-getter table) + object index table)) + ;; No getter functions; standard getters. + ((stringp object) + object) + (t + (elt object index)))) + +(defun vtable--compute-columns (table) + (let ((numerical (make-vector (length (vtable-columns table)) t)) + (columns (vtable-columns table))) + ;; First determine whether there are any all-numerical columns. + (dolist (object (vtable-objects table)) + (seq-do-indexed + (lambda (_elem index) + (unless (numberp (vtable--get-value object index (elt columns index) + table)) + (setf (elt numerical index) nil))) + (vtable-columns table))) + ;; Then fill in defaults. + (seq-map-indexed + (lambda (column index) + ;; This is used when displaying. + (unless (vtable-column-align column) + (setf (vtable-column-align column) + (if (elt numerical index) + 'right + 'left))) + ;; This is used for sorting. + (setf (vtable-column--numerical column) + (elt numerical index)) + column) + (vtable-columns table)))) + +(defun vtable--spacer (table) + (vtable--compute-width table (vtable-separator-width table))) + +(defun vtable--recompute-cache (table) + (let* ((data (vtable--compute-cache table)) + (widths (vtable--compute-widths table data))) + (setf (gethash (vtable--cache-key) (slot-value table '-cache)) + (list data widths)))) + +(defun vtable--ensure-cache (table) + (or (vtable--cache table) + (vtable--recompute-cache table))) + +(defun vtable-insert (table) + (let* ((spacer (vtable--spacer table)) + (start (point)) + (ellipsis (if (vtable-ellipsis table) + (propertize (truncate-string-ellipsis) + 'face (vtable-face table)) + "")) + (ellipsis-width (string-pixel-width ellipsis)) + ;; We maintain a cache per screen/window width, so that we render + ;; correctly if Emacs is open on two different screens (or the + ;; user resizes the frame). + (widths (nth 1 (vtable--ensure-cache table)))) + ;; Don't insert any header or header line if the user hasn't + ;; specified the columns. + (when (slot-value table '-has-column-spec) + (if (vtable-use-header-line table) + (vtable--set-header-line table widths spacer) + ;; Insert the header line directly into the buffer, and put a + ;; keymap to be able to sort the columns there (by clicking on + ;; them). + (vtable--insert-header-line table widths spacer) + (add-text-properties start (point) + (list 'keymap vtable-header-line-map + 'rear-nonsticky t + 'vtable table)) + (setq start (point)))) + (vtable--sort table) + ;; Insert the data. + (let ((line-number 0)) + (dolist (line (car (vtable--cache table))) + (vtable--insert-line table line line-number widths spacer + ellipsis ellipsis-width) + (setq line-number (1+ line-number)))) + (add-text-properties start (point) + (list 'rear-nonsticky t + 'vtable table)) + (goto-char start))) + +(defun vtable--insert-line (table line line-number widths spacer + &optional ellipsis ellipsis-width) + (let ((start (point)) + (columns (vtable-columns table)) + (column-colors + (and (vtable-column-colors table) + (if (vtable-row-colors table) + (elt (slot-value table '-cached-colors) + (mod line-number (length (vtable-row-colors table)))) + (slot-value table '-cached-colors)))) + (divider (vtable-divider table)) + (keymap (slot-value table '-cached-keymap))) + (seq-do-indexed + (lambda (elem index) + (let ((value (nth 0 elem)) + (column (elt columns index)) + (pre-computed (nth 2 elem))) + ;; See if we have any formatters here. + (cond + ((vtable-column-formatter column) + (setq value (funcall (vtable-column-formatter column) value) + pre-computed nil)) + ((vtable-formatter table) + (setq value (funcall (vtable-formatter table) + value index table) + pre-computed nil))) + (let ((displayed + ;; Allow any displayers to have their say. + (cond + ((vtable-column-displayer column) + (funcall (vtable-column-displayer column) + value (elt widths index) table)) + ((vtable-displayer table) + (funcall (vtable-displayer table) + value index (elt widths index) table)) + (pre-computed + ;; If we don't have a displayer, use the pre-made + ;; (cached) string value. + (if (> (nth 1 elem) (elt widths index)) + (concat + (vtable--limit-string + pre-computed (- (elt widths index) ellipsis-width)) + ellipsis) + pre-computed)) + ;; Recompute widths. + (t + (if (> (string-pixel-width value) (elt widths index)) + (concat + (vtable--limit-string + value (- (elt widths index) ellipsis-width)) + ellipsis) + value)))) + (start (point)) + ;; Don't insert the separator after the final column. + (last (= index (- (length line) 2)))) + (if (eq (vtable-column-align column) 'left) + (progn + (insert displayed) + (insert (propertize + " " 'display + (list 'space + :width (list + (+ (- (elt widths index) + (string-pixel-width displayed)) + (if last 0 spacer))))))) + ;; Align to the right. + (insert (propertize " " 'display + (list 'space + :width (list (- (elt widths index) + (string-pixel-width + displayed))))) + displayed) + (unless last + (insert (propertize " " 'display + (list 'space + :width (list spacer)))))) + (put-text-property start (point) 'vtable-column index) + (put-text-property start (point) 'keymap keymap) + (when column-colors + (add-face-text-property + start (point) + (elt column-colors (mod index (length column-colors))))) + (when divider + (insert divider) + (setq start (point)))))) + (cdr line)) + (insert "\n") + (put-text-property start (point) 'vtable-object (car line)) + (unless column-colors + (when-let ((row-colors (slot-value table '-cached-colors))) + (add-face-text-property + start (point) + (elt row-colors (mod line-number (length row-colors)))))))) + +(defun vtable--cache-key () + (cons (frame-terminal) (window-width))) + +(defun vtable--cache (table) + (gethash (vtable--cache-key) (slot-value table '-cache))) + +(defun vtable--clear-cache (table) + (setf (gethash (vtable--cache-key) (slot-value table '-cache)) nil)) + +(defun vtable--sort (table) + (pcase-dolist (`(,index . ,direction) (vtable-sort-by table)) + (let ((cache (vtable--cache table)) + (numerical (vtable-column--numerical + (elt (vtable-columns table) index))) + (numcomp (if (eq direction 'descend) + #'> #'<)) + (stringcomp (if (eq direction 'descend) + #'string> #'string<))) + (setcar cache + (sort (car cache) + (lambda (e1 e2) + (let ((c1 (elt e1 (1+ index))) + (c2 (elt e2 (1+ index)))) + (if numerical + (funcall numcomp (car c1) (car c2)) + (funcall + stringcomp + (if (stringp (car c1)) + (car c1) + (format "%s" (car c1))) + (if (stringp (car c2)) + (car c2) + (format "%s" (car c2)))))))))))) + +(defun vtable--indicator (table index) + (let ((order (car (last (vtable-sort-by table))))) + (if (eq index (car order)) + ;; We're sorting by this column last, so return an indicator. + (catch 'found + (dolist (candidate (nth (if (eq (cdr order) 'ascend) + 1 + 0) + '((?▼ ?v) + (?▲ ?^)))) + (when (char-displayable-p candidate) + (throw 'found (string candidate))))) + ""))) + +(defun vtable--insert-header-line (table widths spacer) + ;; Insert the header directly into the buffer. + (let ((start (point)) + (divider (vtable-divider table)) + (cmap (define-keymap + "<header-line> <drag-mouse-1>" #'vtable--drag-resize-column + "<header-line> <down-mouse-1>" #'ignore)) + (dmap (define-keymap + "<header-line> <drag-mouse-1>" + (lambda (e) + (interactive "e") + (vtable--drag-resize-column e t)) + "<header-line> <down-mouse-1>" #'ignore))) + (seq-do-indexed + (lambda (column index) + (let* ((name (propertize + (vtable-column-name column) + 'face (list 'header-line (vtable-face table)) + 'mouse-face 'header-line-highlight + 'keymap cmap)) + (start (point)) + (indicator (vtable--indicator table index)) + (indicator-width (string-pixel-width indicator)) + (last (= index (1- (length (vtable-columns table))))) + displayed) + (setq displayed + (if (> (string-pixel-width name) + (- (elt widths index) indicator-width)) + (vtable--limit-string + name (- (elt widths index) indicator-width)) + name)) + (let ((fill-width + (+ (- (elt widths index) + (string-pixel-width displayed) + indicator-width + (vtable-separator-width table) + ;; We want the indicator to not be quite flush + ;; right. + (/ (vtable--char-width table) 2.0)) + (if last 0 spacer)))) + (if (or (not last) + (zerop indicator-width) + (< (seq-reduce #'+ widths 0) (window-width nil t))) + ;; Normal case. + (insert + displayed + (propertize " " 'display + (list 'space :width (list fill-width))) + indicator) + ;; This is the final column, and we have a sorting + ;; indicator, and the table is too wide for the window. + (let* ((pre-indicator (string-pixel-width + (buffer-substring (point-min) (point)))) + (pre-fill + (- (window-width nil t) + pre-indicator + (string-pixel-width displayed)))) + (insert + displayed + (propertize " " 'display + (list 'space :width (list pre-fill))) + indicator + (propertize " " 'display + (list 'space :width + (list (- fill-width pre-fill)))))))) + (when (and divider (not last)) + (insert (propertize divider 'keymap dmap))) + (insert (propertize + " " 'display + (list 'space :width (list + (/ (vtable--char-width table) 2.0))))) + (put-text-property start (point) 'vtable-column index))) + (vtable-columns table)) + (insert "\n") + (add-face-text-property start (point) 'header-line))) + +(defun vtable--drag-resize-column (e &optional next) + "Resize the column by dragging. +If NEXT, do the next column." + (interactive "e") + (let* ((pos-start (event-start e)) + (obj (posn-object pos-start))) + (with-current-buffer (window-buffer (posn-window pos-start)) + (let ((column + ;; In the header line we have a text property on the + ;; divider. + (or (get-text-property (if obj (cdr obj) + (posn-point pos-start)) + 'vtable-column + (car obj)) + ;; For reasons of efficiency, we don't have that in + ;; the buffer itself, so find the column. + (save-excursion + (goto-char (posn-point pos-start)) + (1+ + (get-text-property + (prop-match-beginning + (text-property-search-backward 'vtable-column)) + 'vtable-column))))) + (start-x (car (posn-x-y pos-start))) + (end-x (car (posn-x-y (event-end e))))) + (when (or (> column 0) next) + (vtable--alter-column-width (vtable-current-table) + (if next + column + (1- column)) + (- end-x start-x))))))) + +(defun vtable--recompute-numerical (table line) + "Recompute numericalness of columns if necessary." + (let ((columns (vtable-columns table)) + (recompute nil)) + (seq-do-indexed + (lambda (elem index) + (when (and (vtable-column--numerical (elt columns index)) + (not (numberp elem))) + (setq recompute t))) + line) + (when recompute + (vtable--compute-columns table)))) + +(defun vtable--set-header-line (table widths spacer) + (setq header-line-format + (string-replace + "%" "%%" + (with-temp-buffer + (insert " ") + (vtable--insert-header-line table widths spacer) + ;; Align the header with the (possibly) fringed buffer text. + (put-text-property + (point-min) (1+ (point-min)) + 'display '(space :align-to 0)) + (buffer-substring (point-min) (1- (point-max)))))) + (vtable-header-mode 1)) + +(defun vtable--limit-string (string pixels) + (while (and (length> string 0) + (> (string-pixel-width string) pixels)) + (setq string (substring string 0 (1- (length string))))) + string) + +(defun vtable--char-width (table) + (string-pixel-width (propertize "x" 'face (vtable-face table)))) + +(defun vtable--compute-width (table spec) + (cond + ((numberp spec) + (* spec (vtable--char-width table))) + ((string-match "\\([0-9.]+\\)ex" spec) + (* (string-to-number (match-string 1 spec)) (vtable--char-width table))) + ((string-match "\\([0-9.]+\\)px" spec) + (string-to-number (match-string 1 spec))) + ((string-match "\\([0-9.]+\\)%" spec) + (* (string-to-number (match-string 1 spec)) (window-width nil t))) + (t + (error "Invalid spec: %s" spec)))) + +(defun vtable--compute-widths (table cache) + "Compute the display widths for TABLE." + (seq-into + (seq-map-indexed + (lambda (column index) + (let ((width + (or + ;; Explicit widths. + (and (vtable-column-width column) + (vtable--compute-width table (vtable-column-width column))) + ;; Compute based on the displayed widths of + ;; the data. + (seq-max (seq-map (lambda (elem) + (nth 1 (elt (cdr elem) index))) + cache))))) + ;; Let min-width/max-width specs have their say. + (when-let ((min-width (and (vtable-column-min-width column) + (vtable--compute-width + table (vtable-column-min-width column))))) + (setq width (max width min-width))) + (when-let ((max-width (and (vtable-column-max-width column) + (vtable--compute-width + table (vtable-column-max-width column))))) + (setq width (min width max-width))) + width)) + (vtable-columns table)) + 'vector)) + +(defun vtable--compute-cache (table) + (seq-map + (lambda (object) + (cons object (vtable--compute-cached-line table object))) + (vtable-objects table))) + +(defun vtable--compute-cached-line (table object) + (seq-map-indexed + (lambda (column index) + (let* ((value (vtable--get-value object index column table)) + (string (if (stringp value) + (copy-sequence value) + (format "%s" value)))) + (add-face-text-property 0 (length string) + (vtable-face table) + t string) + ;; We stash the computed width and string here -- if there are + ;; no formatters/displayers, we'll be using the string, and + ;; then won't have to recreate it. + (list value (string-pixel-width string) string))) + (vtable-columns table))) + +(defun vtable--make-keymap (table) + (let ((map (if (or (vtable-actions table) + (vtable-keymap table)) + (copy-keymap vtable-map) + vtable-map))) + (when-let ((actions (vtable-actions table))) + (while actions + (funcall (lambda (key binding) + (keymap-set map key + (lambda (object) + (interactive (list (vtable-current-object))) + (funcall binding object)))) + (car actions) (cadr actions)) + (setq actions (cddr actions)))) + (if (vtable-keymap table) + (progn + (setf (vtable-keymap table) + (copy-keymap (vtable-keymap table))) + ;; Respect any previously set parent keymaps. + (set-keymap-parent (vtable-keymap table) + (if (keymap-parent (vtable-keymap table)) + (append (ensure-list + (vtable-keymap table)) + (list map)) + map)) + (vtable-keymap table)) + map))) + +(defun vtable-revert () + "Regenerate the table under point." + (let ((table (vtable-current-table)) + (object (vtable-current-object)) + (column (vtable-current-column)) + (inhibit-read-only t)) + (unless table + (user-error "No table under point")) + (delete-region (vtable-beginning-of-table) (vtable-end-of-table)) + (vtable-insert table) + (when object + (vtable-goto-object object)) + (when column + (vtable-goto-column column)))) + +(defun vtable--widths (table) + (nth 1 (vtable--ensure-cache table))) + +;;; Commands. + +(defvar-keymap vtable-header-mode-map + "<header-line> <mouse-1>" 'vtable-header-line-sort + "<header-line> <mouse-2>" 'vtable-header-line-sort) + +(define-minor-mode vtable-header-mode + "Minor mode for buffers with vtables with headers." + :keymap vtable-header-mode-map) + +(defun vtable-narrow-current-column (&optional n) + "Narrow the current column by N characters. +If N isn't given, N defaults to 1. + +Interactively, N is the prefix argument." + (interactive "p") + (let* ((table (vtable-current-table)) + (column (vtable-current-column))) + (unless column + (user-error "No column under point")) + (vtable--alter-column-width table column + (- (* (vtable--char-width table) (or n 1)))))) + +(defun vtable--alter-column-width (table column delta) + (let ((widths (vtable--widths table))) + (setf (aref widths column) + (max (* (vtable--char-width table) 2) + (+ (aref widths column) delta))) + ;; Store the width so it'll be respected on a revert. + (setf (vtable-column-width (elt (vtable-columns table) column)) + (format "%dpx" (aref widths column))) + (vtable-revert))) + +(defun vtable-widen-current-column (&optional n) + "Widen the current column by N characters. +If N isn't given, N defaults to 1. + +Interactively, N is the prefix argument." + (interactive "p") + (vtable-narrow-current-column (- n))) + +(defun vtable-previous-column () + "Go to the previous column." + (interactive) + (vtable-goto-column + (max 0 (1- (or (vtable-current-column) + (length (vtable--widths (vtable-current-table)))))))) + +(defun vtable-next-column () + "Go to the next column." + (interactive) + (when (vtable-current-column) + (vtable-goto-column + (min (1- (length (vtable--widths (vtable-current-table)))) + (1+ (vtable-current-column)))))) + +(defun vtable-revert-command () + "Re-query data and regenerate the table under point." + (interactive) + (let ((table (vtable-current-table))) + (when (vtable-objects-function table) + (setf (vtable-objects table) (funcall (vtable-objects-function table)))) + (vtable--clear-cache table)) + (vtable-revert)) + +(defun vtable-sort-by-current-column () + "Sort the table under point by the column under point." + (interactive) + (unless (vtable-current-column) + (user-error "No current column")) + (let* ((table (vtable-current-table)) + (last (car (last (vtable-sort-by table)))) + (index (vtable-current-column))) + ;; First prune any previous appearance of this column. + (setf (vtable-sort-by table) + (delq (assq index (vtable-sort-by table)) + (vtable-sort-by table))) + ;; Then insert this as the last sort key. + (setf (vtable-sort-by table) + (append (vtable-sort-by table) + (list (cons index + (if (eq (car last) index) + (if (eq (cdr last) 'ascend) + 'descend + 'ascend) + 'ascend)))))) + (vtable-revert)) + +(defun vtable-header-line-sort (e) + "Sort a vtable from the header line." + (interactive "e") + (let* ((pos (event-start e)) + (obj (posn-object pos))) + (with-current-buffer (window-buffer (posn-window pos)) + (goto-char (point-min)) + (vtable-goto-column + (get-text-property (if obj (cdr obj) (posn-point pos)) + 'vtable-column + (car obj))) + (vtable-sort-by-current-column)))) + +(provide 'vtable) + +;;; vtable.el ends here diff --git a/lisp/emacs-lisp/warnings.el b/lisp/emacs-lisp/warnings.el index 55adb9c8b91..23e20c3b10c 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 6e10c36e77a..162d1bb641b 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 2d69ef9d246..a7f3d5fe14c 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. @@ -574,7 +572,7 @@ Only call fct for visible lines if VISIBLE==t. Set undo boundary if UNDO is non-nil. Rectangle is padded if PAD = t or numeric and (cua--rectangle-virtual-edges) Perform auto-tabify after operation if TABIFY is non-nil. -Mark is kept if keep-clear is 'keep and cleared if keep-clear is 'clear." +Mark is kept if keep-clear is `keep' and cleared if keep-clear is `clear'." (declare (indent 4)) (let* ((inhibit-field-text-motion t) (start (cua--rectangle-top)) diff --git a/lisp/emulation/viper-cmd.el b/lisp/emulation/viper-cmd.el index e08d19c6115..ddb49609d40 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)) @@ -2321,7 +2318,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) @@ -2610,12 +2606,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))) @@ -2629,12 +2625,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)))) @@ -2652,10 +2648,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))) @@ -2673,10 +2669,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))) @@ -4726,15 +4722,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 @@ -4792,7 +4788,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 0427e8ae774..d1bf5e38d53 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 7eac6a413ad..5430cd700bd 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 21580996049..1a90cab7674 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) @@ -63,8 +62,8 @@ or a triple-click." ;; time interval in millisecond within which successive clicks are ;; considered related (defcustom viper-multiclick-timeout (if (viper-window-display-p) - double-click-time - 500) + (mouse-double-click-time) + 500) "Time interval in milliseconds for mouse clicks to be considered related." :type 'integer) @@ -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 df33496fd8d..6d23ae9a0fd 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 51c1bf7d623..b1c361145ca 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 85b0e35d7be..18e47c682e8 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 8ece09d1488..f41429f7734 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 @@ -294,12 +295,12 @@ enough, since keyservers have strict timeout settings." :created (and (match-string 4) (not (string-empty-p (match-string 4))) - (seconds-to-time + (time-convert (string-to-number (match-string 4)))) :expires (and (match-string 5) (not (string-empty-p (match-string 5))) - (seconds-to-time + (time-convert (string-to-number (match-string 5)))) :flags (mapcar (lambda (flag) @@ -318,15 +319,11 @@ enough, since keyservers have strict timeout settings." :created (and (match-string 2) (not (string-empty-p (match-string 2))) - (decode-time (seconds-to-time - (string-to-number - (match-string 2))))) + (decode-time (string-to-number (match-string 2)))) :expires (and (match-string 3) (not (string-empty-p (match-string 3))) - (decode-time (seconds-to-time - (string-to-number - (match-string 3))))) + (decode-time (string-to-number (match-string 3)))) :flags (mapcar (lambda (flag) (cdr (assq flag '((?r revoked) @@ -341,4 +338,6 @@ enough, since keyservers have strict timeout settings." (forward-line)) keys)) +(provide 'epa-ks) + ;;; epa-ks.el ends here diff --git a/lisp/epa.el b/lisp/epa.el index d4ff3d1ee73..742c37d085b 100644 --- a/lisp/epa.el +++ b/lisp/epa.el @@ -235,11 +235,6 @@ You should bind this variable with `let', but do not set it globally.") (define-key keymap "q" 'epa-exit-buffer) keymap)) -(defvar epa-info-mode-map - (let ((keymap (make-sparse-keymap))) - (define-key keymap "q" 'delete-window) - keymap)) - (defvar epa-exit-buffer-function #'quit-window) (defun epa--button-key-text (key) @@ -607,7 +602,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 +647,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 +1235,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 4f161938307..c5d946cb76c 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-autoaway.el b/lisp/erc/erc-autoaway.el index 979f93f693c..8d970bd6b96 100644 --- a/lisp/erc/erc-autoaway.el +++ b/lisp/erc/erc-autoaway.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2002-2004, 2006-2022 Free Software Foundation, Inc. ;; Author: Jorgen Schaefer <forcer@forcix.cx> -;; Maintainer: Amin Bandali <bandali@gnu.org> +;; Maintainer: Amin Bandali <bandali@gnu.org>, F. Jason Park <jp@neverwas.me> ;; URL: https://www.emacswiki.org/emacs/ErcAutoAway ;; This file is part of GNU Emacs. diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el index 9e85d285d5c..1252a5b4fac 100644 --- a/lisp/erc/erc-backend.el +++ b/lisp/erc/erc-backend.el @@ -4,7 +4,7 @@ ;; Filename: erc-backend.el ;; Author: Lawrence Mitchell <wence@gmx.li> -;; Maintainer: Amin Bandali <bandali@gnu.org> +;; Maintainer: Amin Bandali <bandali@gnu.org>, F. Jason Park <jp@neverwas.me> ;; Created: 2004-05-7 ;; Keywords: comm, IRC, chat, client, internet @@ -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.") @@ -310,8 +315,7 @@ This will only be consulted if the coding system in :version "24.1" :type '(repeat coding-system)) -(defcustom erc-server-coding-system (if (and (fboundp 'coding-system-p) - (coding-system-p 'undecided) +(defcustom erc-server-coding-system (if (and (coding-system-p 'undecided) (coding-system-p 'utf-8)) '(utf-8 . undecided) nil) @@ -459,7 +463,7 @@ If POS is out of range, the value is nil." (defun erc-bounds-of-word-at-point () "Return the bounds of word at point, or nil if we're not at a word. If no `subword-mode' is active, then this is -\(bounds-of-thing-at-point 'word)." +\(bounds-of-thing-at-point \\='word)." (if (or (erc-word-at-arg-p (point)) (erc-word-at-arg-p (1- (point)))) (save-excursion @@ -533,7 +537,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 +621,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 +665,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 +1181,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) @@ -1178,7 +1191,7 @@ Would expand to: aliases)) (let* ((hook-name (intern (format "erc-server-%s-functions" name))) (fn-name (intern (format "erc-server-%s" name))) - (hook-doc (format-message "\ + (hook-doc (format "\ %sHook called upon receiving a %%s server response. Each function is called with two arguments, the process associated with the response and the parsed response. If the function returns @@ -1189,7 +1202,7 @@ See also `%s'." (concat extra-var-doc "\n\n") "") fn-name)) - (fn-doc (format-message "\ + (fn-doc (format "\ %sHandler for a %s server response. PROC is the server process which returned the response. PARSED is the actual response as an `erc-response' struct. diff --git a/lisp/erc/erc-button.el b/lisp/erc/erc-button.el index 680de6d5aab..aeada705c4a 100644 --- a/lisp/erc/erc-button.el +++ b/lisp/erc/erc-button.el @@ -3,7 +3,7 @@ ;; Copyright (C) 1996-2004, 2006-2022 Free Software Foundation, Inc. ;; Author: Mario Lang <mlang@delysid.org> -;; Maintainer: Amin Bandali <bandali@gnu.org> +;; Maintainer: Amin Bandali <bandali@gnu.org>, F. Jason Park <jp@neverwas.me> ;; Keywords: comm, irc, button, url, regexp ;; URL: https://www.emacswiki.org/emacs/ErcButton @@ -125,7 +125,7 @@ longer than `erc-fill-column'." ;; a button, it makes no sense to optimize performance by ;; bytecompiling lambdas in this alist. On the other hand, it makes ;; things hard to maintain. - '(('nicknames 0 erc-button-buttonize-nicks erc-nick-popup 0) + '((nicknames 0 erc-button-buttonize-nicks erc-nick-popup 0) (erc-button-url-regexp 0 t browse-url-button-open-url 0) ("<URL: *\\([^<> ]+\\) *>" 0 t browse-url-button-open-url 1) ;;; ("(\\(\\([^~\n \t@][^\n \t@]*\\)@\\([a-zA-Z0-9.:-]+\\)\\)" 1 t finger 2 3) @@ -158,12 +158,12 @@ REGEXP is the string matching text around the button or a symbol strings, or an alist with the strings in the car. Note that entries in lists or alists are considered to be nicks or other complete words. Therefore they are enclosed in \\< and \\> - while searching. REGEXP can also be the quoted symbol - \\='nicknames, which matches the nickname of any user on the + while searching. REGEXP can also be the symbol + `nicknames', which matches the nickname of any user on the current server. BUTTON is the number of the regexp grouping actually matching the - button. This is ignored if REGEXP is \\='nicknames. + button. This is ignored if REGEXP is `nicknames'. FORM is a Lisp expression which must eval to true for the button to be added. @@ -174,17 +174,15 @@ CALLBACK is the function to call when the user push this button. PAR is a number of a regexp grouping whose text will be passed to CALLBACK. There can be several PAR arguments. If REGEXP is - \\='nicknames, these are ignored, and CALLBACK will be called with + `nicknames', these are ignored, and CALLBACK will be called with the nickname matched as the argument." - :version "24.1" ; remove finger (bug#4443) + :version "29.1" :type '(repeat (list :tag "Button" (choice :tag "Matches" regexp (variable :tag "Variable containing regexp") - ;; FIXME It really does mean 'nicknames - ;; rather than just nicknames. - (const :tag "Nicknames" 'nicknames)) + (const :tag "Nicknames" nicknames)) (integer :tag "Number of the regexp section that matches") (choice :tag "When to buttonize" (const :tag "Always" t) @@ -256,7 +254,9 @@ specified by `erc-button-alist'." regexp) (erc-button-remove-old-buttons) (dolist (entry alist) - (if (equal (car entry) (quote (quote nicknames))) + (if (or (eq (car entry) 'nicknames) + ;; Old form retained for backward compatibility. + (equal (car entry) (quote 'nicknames))) (erc-button-add-nickname-buttons entry) (progn (setq regexp (or (and (stringp (car entry)) (car entry)) diff --git a/lisp/erc/erc-capab.el b/lisp/erc/erc-capab.el index 7b7773d5e13..8d0f40af994 100644 --- a/lisp/erc/erc-capab.el +++ b/lisp/erc/erc-capab.el @@ -2,9 +2,9 @@ ;; Copyright (C) 2006-2022 Free Software Foundation, Inc. -;; Maintainer: Amin Bandali <bandali@gnu.org> +;; Maintainer: Amin Bandali <bandali@gnu.org>, F. Jason Park <jp@neverwas.me> -; This file is part of GNU Emacs. +;; 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 diff --git a/lisp/erc/erc-compat.el b/lisp/erc/erc-compat.el index 0541d1604cb..16cfb15a5ae 100644 --- a/lisp/erc/erc-compat.el +++ b/lisp/erc/erc-compat.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2002-2003, 2005-2022 Free Software Foundation, Inc. ;; Author: Alex Schroeder <alex@gnu.org> -;; Maintainer: Amin Bandali <bandali@gnu.org> +;; Maintainer: Amin Bandali <bandali@gnu.org>, F. Jason Park <jp@neverwas.me> ;; URL: https://www.emacswiki.org/emacs/ERC ;; This file is part of GNU Emacs. @@ -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 399e5fb114c..ff486b2d4ea 100644 --- a/lisp/erc/erc-dcc.el +++ b/lisp/erc/erc-dcc.el @@ -1,12 +1,11 @@ ;;; erc-dcc.el --- CTCP DCC module for ERC -*- lexical-binding: t; -*- -;; Copyright (C) 1993-1995, 1998, 2002-2004, 2006-2022 Free Software -;; Foundation, Inc. +;; Copyright (C) 1993-2022 Free Software Foundation, Inc. ;; Author: Ben A. Mesander <ben@gnu.ai.mit.edu> ;; Noah Friedman <friedman@prep.ai.mit.edu> ;; Per Persson <pp@sno.pp.se> -;; Maintainer: Amin Bandali <bandali@gnu.org> +;; Maintainer: Amin Bandali <bandali@gnu.org>, F. Jason Park <jp@neverwas.me> ;; Keywords: comm ;; Created: 1994-01-23 @@ -44,7 +43,7 @@ ;; /dcc chat nick - Either accept pending chat offer from nick, or offer ;; DCC chat to nick ;; /dcc close type [nick] - Close DCC connection (SEND/GET/CHAT) with nick -;; /dcc get nick [file] - Accept DCC offer from nick +;; /dcc get [-t][-s] nick [file] - Accept DCC offer from nick ;; /dcc list - List all DCC offers/connections ;; /dcc send nick file - Offer DCC SEND to nick @@ -106,7 +105,11 @@ Looks like: :file - for outgoing sends, the full path to the file. For incoming sends, the suggested filename or vetted filename - :size - size of the file, may be nil on incoming DCCs") + :size - size of the file, may be nil on incoming DCCs + + :secure - optional item indicating sender support for TLS + + :turbo - optional item indicating sender support for TSEND") (defun erc-dcc-list-add (type nick peer parent &rest args) "Add a new entry of type TYPE to `erc-dcc-list' and return it." @@ -120,12 +123,13 @@ Looks like: ;; more: the entry data from erc-dcc-list for this particular process. (defvar erc-dcc-connect-function 'erc-dcc-open-network-stream) -(defun erc-dcc-open-network-stream (procname buffer addr port _entry) +(defun erc-dcc-open-network-stream (procname buffer addr port entry) ;; FIXME: Time to try activating this again!? (if nil; (fboundp 'open-network-stream-nowait) ;; this currently crashes ;; cvs emacs (open-network-stream-nowait procname buffer addr port) - (open-network-stream procname buffer addr port))) + (open-network-stream procname buffer addr port + :type (and (plist-get entry :secure) 'tls)))) (erc-define-catalog 'english @@ -145,13 +149,14 @@ Looks like: (dcc-get-bytes-received . "DCC: %f: %b bytes received") (dcc-get-complete . "DCC: file %f transfer complete (%s bytes in %t seconds)") + (dcc-get-failed . "DCC: file %f transfer failed at %s of %v in %t seconds") (dcc-get-cmd-aborted . "DCC: Aborted getting %f from %n") (dcc-get-file-too-long . "DCC: %f: File longer than sender claimed; aborting transfer") (dcc-get-notfound . "DCC: %n hasn't offered %f for DCC transfer") - (dcc-list-head . "DCC: From Type Active Size Filename") - (dcc-list-line . "DCC: -------- ---- ------ -------------- --------") - (dcc-list-item . "DCC: %-8n %-4t %-6a %-14s %f") + (dcc-list-head . "DCC: From Type Active Size Filename") + (dcc-list-line . "DCC: -------- ---- ------ ----------------- --------") + (dcc-list-item . "DCC: %-8n %-4t %-6a %-17s %f%u") (dcc-list-end . "DCC: End of list.") (dcc-malformed . "DCC: error: %n (%u@%h) sent malformed request: %q") (dcc-privileged-port @@ -183,9 +188,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) @@ -198,7 +201,7 @@ compared with `erc-nick-equal-p' which is IRC case-insensitive." (erc-extract-nick test) (erc-extract-nick val))) ;; not a nick - (eq test val) + (equal test val) (setq cont nil)))) (if cont (setq result elt) @@ -508,8 +511,12 @@ At least one of TYPE and NICK must be provided." FILE is the filename. If FILE is split into multiple arguments, re-join the arguments, separated by a space. PROC is the server process." - (setq file (and file (mapconcat #'identity file " "))) - (let* ((elt (erc-dcc-member :nick nick :type 'GET)) + (let* ((args (seq-group-by (lambda (s) (eq ?- (aref s 0))) (cons nick file))) + (flags (prog1 (cdr (assq t args)) + (setq args (cdr (assq nil args)) + nick (pop args) + file (and args (mapconcat #'identity args " "))))) + (elt (erc-dcc-member :nick nick :type 'GET :file file)) (filename (or file (plist-get elt :file) "unknown"))) (if elt (let* ((file (read-file-name @@ -529,7 +536,13 @@ PROC is the server process." 'dcc-get-cmd-aborted ?n nick ?f filename))) (t - (erc-dcc-get-file elt file proc)))) + (erc-dcc-get-file elt file proc))) + (when (member "-s" flags) + (setq erc-dcc-list (cons (plist-put elt :secure t) + (delq elt erc-dcc-list)))) + (when (member "-t" flags) + (setq erc-dcc-list (cons (plist-put elt :turbo t) + (delq elt erc-dcc-list))))) (erc-display-message nil '(notice error) 'active 'dcc-get-notfound ?n nick ?f filename)))) @@ -567,6 +580,7 @@ It lists the current state of `erc-dcc-list' in an easy to read manner." (process-status (plist-get elt :peer)) "no") ?s (concat size + ;; FIXME consider uniquified names, e.g., foo.bin<2> (if (and (eq 'GET (plist-get elt :type)) (plist-member elt :file) (buffer-live-p (get-buffer (plist-get elt :file))) @@ -578,7 +592,12 @@ It lists the current state of `erc-dcc-list' in an easy to read manner." (format " (%d%%)" (floor (* 100.0 byte-count) (plist-get elt :size)))))) - ?f (or (and (plist-member elt :file) (plist-get elt :file)) ""))) + ?f (or (and (plist-member elt :file) (plist-get elt :file)) "") + ?u (if-let* ((flags (concat (and (plist-get elt :turbo) "t") + (and (plist-get elt :secure) "s"))) + ((not (string-empty-p flags)))) + (concat " (" flags ")") + ""))) (erc-display-message nil 'notice 'active 'dcc-list-end) @@ -605,6 +624,10 @@ separated by a space." (defvar erc-dcc-query-handler-alist '(("SEND" . erc-dcc-handle-ctcp-send) + ("TSEND" . erc-dcc-handle-ctcp-send) + ("SSEND" . erc-dcc-handle-ctcp-send) + ("TSSEND" . erc-dcc-handle-ctcp-send) + ("STSEND" . erc-dcc-handle-ctcp-send) ("CHAT" . erc-dcc-handle-ctcp-chat))) ;;;###autoload @@ -623,12 +646,16 @@ that subcommand." ?q query ?n nick ?u login ?h host)))) (defconst erc-dcc-ctcp-query-send-regexp - (concat "^DCC SEND \\(?:" + (rx bot "DCC " (group-n 6 (: (** 0 2 (any "TS")) "SEND")) " " ;; Following part matches either filename without spaces ;; or filename enclosed in double quotes with any number ;; of escaped double quotes inside. - "\"\\(\\(?:\\\\\"\\|[^\"\\]\\)+\\)\"\\|\\([^ ]+\\)" - "\\) \\([0-9]+\\) \\([0-9]+\\) *\\([0-9]*\\)")) + (: (or (: ?\" (group-n 1 (+ (or (: ?\\ ?\") (not (any ?\" ?\\))))) ?\") + (group-n 2 (+ (not " "))))) + (: " " (group-n 3 (+ digit)) + " " (group-n 4 (+ digit)) + (* " ") (group-n 5 (* digit))) + eot)) (define-inline erc-dcc-unquote-filename (filename) (inline-quote @@ -653,12 +680,14 @@ It extracts the information about the dcc request and adds it to 'dcc-request-bogus ?r "SEND" ?n nick ?u login ?h host)) ((string-match erc-dcc-ctcp-query-send-regexp query) - (let ((filename - (or (match-string 2 query) - (erc-dcc-unquote-filename (match-string 1 query)))) - (ip (erc-decimal-to-ip (match-string 3 query))) - (port (match-string 4 query)) - (size (match-string 5 query))) + (let* ((filename (or (match-string 2 query) + (erc-dcc-unquote-filename (match-string 1 query)))) + (ip (erc-decimal-to-ip (match-string 3 query))) + (port (match-string 4 query)) + (size (match-string 5 query)) + (sub (substring (match-string 6 query) 0 -4)) + (secure (seq-contains-p sub ?S #'eq)) + (turbo (seq-contains-p sub ?T #'eq))) ;; FIXME: a warning really should also be sent ;; if the ip address != the host the dcc sender is on. (erc-display-message @@ -675,7 +704,9 @@ It extracts the information about the dcc request and adds it to 'GET (format "%s!%s@%s" nick login host) nil proc :ip ip :port port :file filename - :size (string-to-number size)) + :size (string-to-number size) + :turbo (and turbo t) + :secure (and secure t)) (if (and (eq erc-dcc-send-request 'auto) (erc-dcc-auto-mask-p (format "\"%s!%s@%s\"" nick login host))) (erc-dcc-get-file (car erc-dcc-list) filename proc)))) @@ -771,7 +802,7 @@ the matching regexp, or nil if none found." PROC is the process-object of the DCC connection. Returns the number of bytes sent." (let* ((elt (erc-dcc-member :peer proc)) - (confirmed-marker (plist-get elt :sent)) + (confirmed-marker (plist-get elt :confirmed)) (sent-marker (plist-get elt :sent))) (with-current-buffer (process-buffer proc) (when erc-dcc-verbose @@ -923,8 +954,7 @@ and making the connection." (inhibit-file-name-operation 'write-region)) (write-region (point) (point) erc-dcc-file-name nil 'nomessage)) - (setq erc-server-process parent-proc - erc-dcc-entry-data entry) + (setq erc-server-process parent-proc) (setq erc-dcc-byte-count 0) (setq proc (funcall erc-dcc-connect-function @@ -938,8 +968,8 @@ and making the connection." (set-process-filter proc #'erc-dcc-get-filter) (set-process-sentinel proc #'erc-dcc-get-sentinel) - (setq entry (plist-put entry :start-time (erc-current-time))) - (setq entry (plist-put entry :peer proc))))) + (setq erc-dcc-entry-data (plist-put (plist-put entry :peer proc) + :start-time (erc-current-time)))))) (defun erc-dcc-append-contents (buffer _file) "Append the contents of BUFFER to FILE. @@ -955,6 +985,16 @@ The contents of the BUFFER will then be erased." (setq erc-dcc-byte-count (+ (buffer-size) erc-dcc-byte-count)) (erase-buffer)))) +;; If people really need this, we can convert it into a proper option. + +(defvar erc-dcc--X-send-final-turbo-ack nil + "Workaround for maverick turbo senders that only require a final ACK. +The only known culprit is WeeChat, with its xfer.network.fast_send +option, which is on by default. Leaving this set to nil and calling +/DCC GET -t works just fine, but WeeChat sees it as a failure even +though the file arrives in its entirety. Setting this to t may +alleviate such problems.") + (defun erc-dcc-get-filter (proc str) "This is the process filter for transfers from other clients to this one. It reads incoming bytes from the network and stores them in the DCC @@ -989,31 +1029,43 @@ rather than every 1024 byte block, but nobody seems to care." 'dcc-get-file-too-long ?f (file-name-nondirectory (buffer-name))) (delete-process proc)) - (t - (process-send-string - proc (erc-pack-int received-bytes))))))) - + ;; Some senders want us to hang up. Only observed w. TSEND. + ((and (plist-get erc-dcc-entry-data :turbo) + (= received-bytes (plist-get erc-dcc-entry-data :size))) + (when erc-dcc--X-send-final-turbo-ack + (process-send-string proc (erc-pack-int received-bytes))) + (delete-process proc)) + ((not (or (plist-get erc-dcc-entry-data :turbo) + (process-get proc :reportingp))) + (process-put proc :reportingp t) + (process-send-string proc (erc-pack-int received-bytes)) + (process-put proc :reportingp nil)))))) -(defun erc-dcc-get-sentinel (proc _event) +(defun erc-dcc-get-sentinel (proc event) "This is the process sentinel for CTCP DCC SEND connections. It shuts down the connection and notifies the user that the transfer is complete." ;; FIXME, we should look at EVENT, and also check size. + (unless (member event '("connection broken by remote peer\n" + "deleted\n")) + (lwarn 'erc :warning "Unexpected sentinel event %S for %s" + (string-trim-right event) proc)) (with-current-buffer (process-buffer proc) (delete-process proc) (setq erc-dcc-list (delete erc-dcc-entry-data erc-dcc-list)) (unless (= (point-min) (point-max)) (erc-dcc-append-contents (current-buffer) erc-dcc-file-name)) - (erc-display-message - nil 'notice erc-server-process - 'dcc-get-complete - ?f erc-dcc-file-name - ?s (number-to-string erc-dcc-byte-count) - ?t (format "%.0f" - (erc-time-diff (plist-get erc-dcc-entry-data :start-time) - nil)))) - (kill-buffer (process-buffer proc)) - (delete-process proc)) + (let ((done (= erc-dcc-byte-count (plist-get erc-dcc-entry-data :size)))) + (erc-display-message + nil (if done 'notice '(notice error)) erc-server-process + (if done 'dcc-get-complete 'dcc-get-failed) + ?v (plist-get erc-dcc-entry-data :size) + ?f erc-dcc-file-name + ?s (number-to-string erc-dcc-byte-count) + ?t (format "%.0f" + (erc-time-diff (plist-get erc-dcc-entry-data :start-time) + nil)))) + (kill-buffer))) ;;; CHAT handling diff --git a/lisp/erc/erc-desktop-notifications.el b/lisp/erc/erc-desktop-notifications.el index 8ece765ef0d..1897f53dc16 100644 --- a/lisp/erc/erc-desktop-notifications.el +++ b/lisp/erc/erc-desktop-notifications.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2012-2022 Free Software Foundation, Inc. ;; Author: Julien Danjou <julien@danjou.info> -;; Maintainer: Amin Bandali <bandali@gnu.org> +;; Maintainer: Amin Bandali <bandali@gnu.org>, F. Jason Park <jp@neverwas.me> ;; Keywords: comm ;; This file is part of GNU Emacs. diff --git a/lisp/erc/erc-ezbounce.el b/lisp/erc/erc-ezbounce.el index 8f46a1c8dd1..958783f2394 100644 --- a/lisp/erc/erc-ezbounce.el +++ b/lisp/erc/erc-ezbounce.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2002, 2004, 2006-2022 Free Software Foundation, Inc. ;; Author: Andreas Fuchs <asf@void.at> -;; Maintainer: Amin Bandali <bandali@gnu.org> +;; Maintainer: Amin Bandali <bandali@gnu.org>, F. Jason Park <jp@neverwas.me> ;; Keywords: comm ;; This file is part of GNU Emacs. diff --git a/lisp/erc/erc-fill.el b/lisp/erc/erc-fill.el index 492830c3e13..140e7fdfc61 100644 --- a/lisp/erc/erc-fill.el +++ b/lisp/erc/erc-fill.el @@ -4,7 +4,7 @@ ;; Author: Andreas Fuchs <asf@void.at> ;; Mario Lang <mlang@delysid.org> -;; Maintainer: Amin Bandali <bandali@gnu.org> +;; Maintainer: Amin Bandali <bandali@gnu.org>, F. Jason Park <jp@neverwas.me> ;; URL: https://www.emacswiki.org/emacs/ErcFilling ;; This file is part of GNU Emacs. diff --git a/lisp/erc/erc-goodies.el b/lisp/erc/erc-goodies.el index 677f077c2ee..8fef23945d4 100644 --- a/lisp/erc/erc-goodies.el +++ b/lisp/erc/erc-goodies.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2001-2022 Free Software Foundation, Inc. ;; Author: Jorgen Schaefer <forcer@forcix.cx> -;; Maintainer: Amin Bandali <bandali@gnu.org> +;; Maintainer: Amin Bandali <bandali@gnu.org>, F. Jason Park <jp@neverwas.me> ;; Most code is taken verbatim from erc.el, see there for the original ;; authors. @@ -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-ibuffer.el b/lisp/erc/erc-ibuffer.el index f1184ff5eb2..417c0b898a7 100644 --- a/lisp/erc/erc-ibuffer.el +++ b/lisp/erc/erc-ibuffer.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2002, 2004, 2006-2022 Free Software Foundation, Inc. ;; Author: Mario Lang <mlang@delysid.org> -;; Maintainer: Amin Bandali <bandali@gnu.org> +;; Maintainer: Amin Bandali <bandali@gnu.org>, F. Jason Park <jp@neverwas.me> ;; Keywords: comm ;; This file is part of GNU Emacs. diff --git a/lisp/erc/erc-identd.el b/lisp/erc/erc-identd.el index eab219f4c1e..5c0a2c1a481 100644 --- a/lisp/erc/erc-identd.el +++ b/lisp/erc/erc-identd.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2003, 2006-2022 Free Software Foundation, Inc. ;; Author: John Wiegley <johnw@gnu.org> -;; Maintainer: Amin Bandali <bandali@gnu.org> +;; Maintainer: Amin Bandali <bandali@gnu.org>, F. Jason Park <jp@neverwas.me> ;; Keywords: comm ;; This file is part of GNU Emacs. diff --git a/lisp/erc/erc-imenu.el b/lisp/erc/erc-imenu.el index f9713032e92..64a8f82b2a9 100644 --- a/lisp/erc/erc-imenu.el +++ b/lisp/erc/erc-imenu.el @@ -1,10 +1,9 @@ ;;; erc-imenu.el --- Imenu support for ERC -*- lexical-binding: t; -*- -;; Copyright (C) 2001-2002, 2004, 2006-2022 Free Software Foundation, -;; Inc. +;; Copyright (C) 2001-2022 Free Software Foundation, Inc. ;; Author: Mario Lang <mlang@delysid.org> -;; Maintainer: Amin Bandali <bandali@gnu.org> +;; Maintainer: Amin Bandali <bandali@gnu.org>, F. Jason Park <jp@neverwas.me> ;; Keywords: comm ;; URL: https://www.emacswiki.org/emacs/ErcImenu diff --git a/lisp/erc/erc-join.el b/lisp/erc/erc-join.el index 175e83f3c90..b9788c192bc 100644 --- a/lisp/erc/erc-join.el +++ b/lisp/erc/erc-join.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2002-2004, 2006-2022 Free Software Foundation, Inc. ;; Author: Alex Schroeder <alex@gnu.org> -;; Maintainer: Amin Bandali <bandali@gnu.org> +;; Maintainer: Amin Bandali <bandali@gnu.org>, F. Jason Park <jp@neverwas.me> ;; Keywords: comm, irc ;; URL: https://www.emacswiki.org/emacs/ErcAutoJoin diff --git a/lisp/erc/erc-lang.el b/lisp/erc/erc-lang.el index 354203aa090..d059caf5a32 100644 --- a/lisp/erc/erc-lang.el +++ b/lisp/erc/erc-lang.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2002, 2004, 2006-2022 Free Software Foundation, Inc. ;; Author: Alex Schroeder <alex@gnu.org> -;; Maintainer: Amin Bandali <bandali@gnu.org> +;; Maintainer: Amin Bandali <bandali@gnu.org>, F. Jason Park <jp@neverwas.me> ;; Old-Version: 1.0.0 ;; URL: https://www.emacswiki.org/emacs/ErcLang ;; Keywords: comm @@ -32,10 +32,8 @@ (require 'erc) -;; FIXME: It's ISO 639-1, not ISO 638. ISO 638 is for paper, board and pulps. -;; The Lisp variable should be renamed. - -(defvar iso-638-languages +(define-obsolete-variable-alias 'iso-638-languages 'iso-639-1-languages "29.1") +(defvar iso-639-1-languages '(("aa" . "Afar") ("ab" . "Abkhazian") ("af" . "Afrikaans") @@ -197,12 +195,12 @@ Normungsinstitut (ON), Postfach 130, A-1021 Vienna, Austria.") (defun language (code) "Return the language name for the ISO CODE." (interactive (list (completing-read "ISO language code: " - iso-638-languages))) - (message "%s" (cdr (assoc code iso-638-languages)))) + iso-639-1-languages))) + (message "%s" (cdr (assoc code iso-639-1-languages)))) (defun erc-cmd-LANG (language) "Display the language name for the language code given by LANGUAGE." - (let ((lang (cdr (assoc language iso-638-languages)))) + (let ((lang (cdr (assoc language iso-639-1-languages)))) (erc-display-message nil 'notice 'active (or lang (concat language ": No such domain")))) diff --git a/lisp/erc/erc-list.el b/lisp/erc/erc-list.el index c7cd0ceba83..5266b680c38 100644 --- a/lisp/erc/erc-list.el +++ b/lisp/erc/erc-list.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2008-2022 Free Software Foundation, Inc. ;; Author: Tom Tromey <tromey@redhat.com> -;; Maintainer: Amin Bandali <bandali@gnu.org> +;; Maintainer: Amin Bandali <bandali@gnu.org>, F. Jason Park <jp@neverwas.me> ;; Old-Version: 0.1 ;; URL: https://www.emacswiki.org/emacs/ErcList ;; Keywords: comm diff --git a/lisp/erc/erc-log.el b/lisp/erc/erc-log.el index 056701d6200..57093d3fc6c 100644 --- a/lisp/erc/erc-log.el +++ b/lisp/erc/erc-log.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2003-2022 Free Software Foundation, Inc. ;; Author: Lawrence Mitchell <wence@gmx.li> -;; Maintainer: Amin Bandali <bandali@gnu.org> +;; Maintainer: Amin Bandali <bandali@gnu.org>, F. Jason Park <jp@neverwas.me> ;; URL: https://www.emacswiki.org/emacs/ErcLogging ;; Keywords: comm, IRC, chat, client, Internet, logging diff --git a/lisp/erc/erc-match.el b/lisp/erc/erc-match.el index aa78590539b..7c9174ff66a 100644 --- a/lisp/erc/erc-match.el +++ b/lisp/erc/erc-match.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2002-2022 Free Software Foundation, Inc. ;; Author: Andreas Fuchs <asf@void.at> -;; Maintainer: Amin Bandali <bandali@gnu.org> +;; Maintainer: Amin Bandali <bandali@gnu.org>, F. Jason Park <jp@neverwas.me> ;; Keywords: comm ;; URL: https://www.emacswiki.org/emacs/ErcMatch diff --git a/lisp/erc/erc-menu.el b/lisp/erc/erc-menu.el index fd14d8b0ad8..455a7c3cd2f 100644 --- a/lisp/erc/erc-menu.el +++ b/lisp/erc/erc-menu.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2001-2002, 2004-2022 Free Software Foundation, Inc. ;; Author: Mario Lang <mlang@delysid.org> -;; Maintainer: Amin Bandali <bandali@gnu.org> +;; Maintainer: Amin Bandali <bandali@gnu.org>, F. Jason Park <jp@neverwas.me> ;; Keywords: comm, menu ;; This file is part of GNU Emacs. diff --git a/lisp/erc/erc-netsplit.el b/lisp/erc/erc-netsplit.el index 30bb18344d7..17ed881b12b 100644 --- a/lisp/erc/erc-netsplit.el +++ b/lisp/erc/erc-netsplit.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2002-2004, 2006-2022 Free Software Foundation, Inc. ;; Author: Mario Lang <mlang@delysid.org> -;; Maintainer: Amin Bandali <bandali@gnu.org> +;; Maintainer: Amin Bandali <bandali@gnu.org>, F. Jason Park <jp@neverwas.me> ;; Keywords: comm ;; This file is part of GNU Emacs. diff --git a/lisp/erc/erc-networks.el b/lisp/erc/erc-networks.el index 9377e701c39..553697ae847 100644 --- a/lisp/erc/erc-networks.el +++ b/lisp/erc/erc-networks.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2002, 2004-2022 Free Software Foundation, Inc. ;; Author: Mario Lang <mlang@lexx.delysid.org> -;; Maintainer: Amin Bandali <bandali@gnu.org> +;; Maintainer: Amin Bandali <bandali@gnu.org>, F. Jason Park <jp@neverwas.me> ;; Keywords: comm ;; This file is part of GNU Emacs. diff --git a/lisp/erc/erc-notify.el b/lisp/erc/erc-notify.el index a3fe04d392c..911a574b17e 100644 --- a/lisp/erc/erc-notify.el +++ b/lisp/erc/erc-notify.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2002-2004, 2006-2022 Free Software Foundation, Inc. ;; Author: Mario Lang <mlang@lexx.delysid.org> -;; Maintainer: Amin Bandali <bandali@gnu.org> +;; Maintainer: Amin Bandali <bandali@gnu.org>, F. Jason Park <jp@neverwas.me> ;; URL: https://www.emacswiki.org/emacs/ErcNotify ;; Keywords: comm diff --git a/lisp/erc/erc-page.el b/lisp/erc/erc-page.el index e53178ce63a..087e5a67d07 100644 --- a/lisp/erc/erc-page.el +++ b/lisp/erc/erc-page.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2002, 2004, 2006-2022 Free Software Foundation, Inc. -;; Maintainer: Amin Bandali <bandali@gnu.org> +;; Maintainer: Amin Bandali <bandali@gnu.org>, F. Jason Park <jp@neverwas.me> ;; This file is part of GNU Emacs. diff --git a/lisp/erc/erc-pcomplete.el b/lisp/erc/erc-pcomplete.el index 384be500ad7..af8528dbc38 100644 --- a/lisp/erc/erc-pcomplete.el +++ b/lisp/erc/erc-pcomplete.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2002-2004, 2006-2022 Free Software Foundation, Inc. ;; Author: Sacha Chua <sacha@free.net.ph> -;; Maintainer: Amin Bandali <bandali@gnu.org> +;; Maintainer: Amin Bandali <bandali@gnu.org>, F. Jason Park <jp@neverwas.me> ;; Keywords: comm ;; URL: https://www.emacswiki.org/emacs/ErcCompletion diff --git a/lisp/erc/erc-replace.el b/lisp/erc/erc-replace.el index 03153c69988..e46862d6a64 100644 --- a/lisp/erc/erc-replace.el +++ b/lisp/erc/erc-replace.el @@ -1,10 +1,9 @@ ;;; erc-replace.el --- wash and massage messages inserted into the buffer -*- lexical-binding: t; -*- -;; Copyright (C) 2001-2002, 2004, 2006-2022 Free Software Foundation, -;; Inc. +;; Copyright (C) 2001-2022 Free Software Foundation, Inc. ;; Author: Andreas Fuchs <asf@void.at> -;; Maintainer: Amin Bandali <bandali@gnu.org> +;; Maintainer: Amin Bandali <bandali@gnu.org>, F. Jason Park <jp@neverwas.me> ;; URL: https://www.emacswiki.org/emacs/ErcReplace ;; Keywords: comm, IRC, client, Internet diff --git a/lisp/erc/erc-ring.el b/lisp/erc/erc-ring.el index 0f6851a98a3..9dd1fab6403 100644 --- a/lisp/erc/erc-ring.el +++ b/lisp/erc/erc-ring.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2001-2004, 2006-2022 Free Software Foundation, Inc. ;; Author: Alex Schroeder <alex@gnu.org> -;; Maintainer: Amin Bandali <bandali@gnu.org> +;; Maintainer: Amin Bandali <bandali@gnu.org>, F. Jason Park <jp@neverwas.me> ;; Keywords: comm ;; URL: https://www.emacswiki.org/emacs/ErcHistory diff --git a/lisp/erc/erc-services.el b/lisp/erc/erc-services.el index dcd786411f2..cc5d5701e44 100644 --- a/lisp/erc/erc-services.el +++ b/lisp/erc/erc-services.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2002-2004, 2006-2022 Free Software Foundation, Inc. -;; Maintainer: Amin Bandali <bandali@gnu.org> +;; Maintainer: Amin Bandali <bandali@gnu.org>, F. Jason Park <jp@neverwas.me> ;; URL: https://www.emacswiki.org/emacs/ErcNickserv ;; This file is part of GNU Emacs. @@ -444,15 +444,12 @@ it returns nil." (cl-second (assoc network erc-nickserv-passwords))))) (when erc-use-auth-source-for-nickserv-password - (let ((secret (cl-first (auth-source-search - :max 1 :require '(:secret) - :host server - ;; Ensure a string for :port - :port (format "%s" port) - :user nick)))) - (when secret - (let ((passwd (plist-get secret :secret))) - (if (functionp passwd) (funcall passwd) passwd))))) + (auth-source-pick-first-password + :require '(:secret) + :host server + ;; Ensure a string for :port + :port (format "%s" port) + :user nick)) (when erc-prompt-for-nickserv-password (read-passwd (format "NickServ password for %s on %s (RET to cancel): " diff --git a/lisp/erc/erc-sound.el b/lisp/erc/erc-sound.el index 86978f9d794..5cae64572f0 100644 --- a/lisp/erc/erc-sound.el +++ b/lisp/erc/erc-sound.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2002-2003, 2006-2022 Free Software Foundation, Inc. -;; Maintainer: Amin Bandali <bandali@gnu.org> +;; Maintainer: Amin Bandali <bandali@gnu.org>, F. Jason Park <jp@neverwas.me> ;; URL: https://www.emacswiki.org/emacs/ErcSound ;; This file is part of GNU Emacs. diff --git a/lisp/erc/erc-speedbar.el b/lisp/erc/erc-speedbar.el index ead0d374b18..5b06c21612f 100644 --- a/lisp/erc/erc-speedbar.el +++ b/lisp/erc/erc-speedbar.el @@ -4,7 +4,7 @@ ;; Author: Mario Lang <mlang@delysid.org> ;; Contributor: Eric M. Ludlam <zappo@gnu.org> -;; Maintainer: Amin Bandali <bandali@gnu.org> +;; Maintainer: Amin Bandali <bandali@gnu.org>, F. Jason Park <jp@neverwas.me> ;; URL: https://www.emacswiki.org/emacs/ErcSpeedbar ;; This file is part of GNU Emacs. diff --git a/lisp/erc/erc-spelling.el b/lisp/erc/erc-spelling.el index d9cfc9bc985..91e6777b7c0 100644 --- a/lisp/erc/erc-spelling.el +++ b/lisp/erc/erc-spelling.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2005-2022 Free Software Foundation, Inc. ;; Author: Jorgen Schaefer <forcer@forcix.cx> -;; Maintainer: Amin Bandali <bandali@gnu.org> +;; Maintainer: Amin Bandali <bandali@gnu.org>, F. Jason Park <jp@neverwas.me> ;; Keywords: comm, irc ;; URL: https://www.emacswiki.org/emacs/ErcSpelling diff --git a/lisp/erc/erc-stamp.el b/lisp/erc/erc-stamp.el index d74a53bc71e..cdab3241c12 100644 --- a/lisp/erc/erc-stamp.el +++ b/lisp/erc/erc-stamp.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2002-2004, 2006-2022 Free Software Foundation, Inc. ;; Author: Mario Lang <mlang@delysid.org> -;; Maintainer: Amin Bandali <bandali@gnu.org> +;; Maintainer: Amin Bandali <bandali@gnu.org>, F. Jason Park <jp@neverwas.me> ;; Keywords: comm, timestamp ;; URL: https://www.emacswiki.org/emacs/ErcStamp diff --git a/lisp/erc/erc-status-sidebar.el b/lisp/erc/erc-status-sidebar.el index 39430ee6598..8997be00ae0 100644 --- a/lisp/erc/erc-status-sidebar.el +++ b/lisp/erc/erc-status-sidebar.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2017, 2020-2022 Free Software Foundation, Inc. ;; Author: Andrew Barbarello -;; Maintainer: Amin Bandali <bandali@gnu.org> +;; Maintainer: Amin Bandali <bandali@gnu.org>, F. Jason Park <jp@neverwas.me> ;; URL: https://github.com/drewbarbs/erc-status-sidebar ;; This file is part of GNU Emacs. diff --git a/lisp/erc/erc-track.el b/lisp/erc/erc-track.el index 2196c5411eb..9118d7b994f 100644 --- a/lisp/erc/erc-track.el +++ b/lisp/erc/erc-track.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2002-2022 Free Software Foundation, Inc. ;; Author: Mario Lang <mlang@delysid.org> -;; Maintainer: Amin Bandali <bandali@gnu.org> +;; Maintainer: Amin Bandali <bandali@gnu.org>, F. Jason Park <jp@neverwas.me> ;; Keywords: comm ;; URL: https://www.emacswiki.org/emacs/ErcChannelTracking diff --git a/lisp/erc/erc-truncate.el b/lisp/erc/erc-truncate.el index 8a8842bc484..d998718a8fc 100644 --- a/lisp/erc/erc-truncate.el +++ b/lisp/erc/erc-truncate.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2003-2004, 2006-2022 Free Software Foundation, Inc. ;; Author: Andreas Fuchs <asf@void.at> -;; Maintainer: Amin Bandali <bandali@gnu.org> +;; Maintainer: Amin Bandali <bandali@gnu.org>, F. Jason Park <jp@neverwas.me> ;; URL: https://www.emacswiki.org/emacs/ErcTruncation ;; Keywords: IRC, chat, client, Internet, logging diff --git a/lisp/erc/erc-xdcc.el b/lisp/erc/erc-xdcc.el index ee2a8c936f7..ca8ff6c080b 100644 --- a/lisp/erc/erc-xdcc.el +++ b/lisp/erc/erc-xdcc.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2003-2004, 2006-2022 Free Software Foundation, Inc. ;; Author: Mario Lang <mlang@delysid.org> -;; Maintainer: Amin Bandali <bandali@gnu.org> +;; Maintainer: Amin Bandali <bandali@gnu.org>, F. Jason Park <jp@neverwas.me> ;; Keywords: comm ;; This file is part of GNU Emacs. diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 635228e7f55..ff482d49338 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -3,7 +3,7 @@ ;; Copyright (C) 1997-2022 Free Software Foundation, Inc. ;; Author: Alexander L. Belikoff (alexander@belikoff.net) -;; Maintainer: Amin Bandali <bandali@gnu.org> +;; Maintainer: Amin Bandali <bandali@gnu.org>, F. Jason Park <jp@neverwas.me> ;; Contributors: Sergey Berezin (sergey.berezin@cs.cmu.edu), ;; Mario Lang (mlang@delysid.org), ;; Alex Schroeder (alex@gnu.org) @@ -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) @@ -1759,12 +1761,7 @@ nil." (lambda (bufname) (let ((buf (if (consp bufname) (cdr bufname) (get-buffer bufname)))) - (when buf - (erc--buffer-p buf (lambda () t) proc) - (with-current-buffer buf - (and (derived-mode-p 'erc-mode) - (or (null proc) - (eq proc erc-server-process)))))))))) + (and buf (erc--buffer-p buf (lambda () t) proc))))))) (defun erc-switch-to-buffer (&optional arg) "Prompt for an ERC buffer to switch to. When invoked with prefix argument, use all ERC buffers. Without @@ -2060,19 +2057,12 @@ Returns the buffer for the given server or channel." ;; password stuff (setq erc-session-password (or passwd - (let ((secret - (plist-get - (nth 0 - (auth-source-search :host server - :max 1 - :user nick - ;; secrets.el wouldn’t accept a number - :port (if (numberp port) (number-to-string port) port) - :require '(:secret))) - :secret))) - (if (functionp secret) - (funcall secret) - secret)))) + (auth-source-pick-first-password + :host server + :user nick + ;; secrets.el wouldn’t accept a number + :port (if (numberp port) (number-to-string port) port) + :require '(:secret)))) ;; client certificate (only useful if connecting over TLS) (setq erc-session-client-certificate client-certificate) ;; debug output buffer @@ -2279,7 +2269,7 @@ Example usage: (erc-tls :server \"irc.libera.chat\" :port 6697 :client-certificate - '(\"/home/bandali/my-cert.key\" + \\='(\"/home/bandali/my-cert.key\" \"/home/bandali/my-cert.crt\"))" (interactive (let ((erc-default-port erc-default-port-tls)) (erc-select-read-args))) @@ -2403,7 +2393,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 +2807,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 +2955,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) @@ -3187,16 +3175,12 @@ For a list of user commands (/join /part, ...): (put 'erc-cmd-HELP 'process-not-needed t) (defun erc-server-join-channel (server channel &optional secret) - (let* ((secret (or secret - (plist-get (nth 0 (auth-source-search - :max 1 - :host server - :port "irc" - :user channel)) - :secret))) - (password (if (functionp secret) - (funcall secret) - secret))) + (let ((password + (or secret + (auth-source-pick-first-password + :host server + :port "irc" + :user channel)))) (erc-log (format "cmd: JOIN: %s" channel)) (erc-server-send (concat "JOIN " channel (if password @@ -3608,11 +3592,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)) @@ -3639,12 +3625,7 @@ If S is non-nil, it will be used as the quit reason." "Zippy quit message. If S is non-nil, it will be used as the quit reason." - (or s - (if (fboundp 'yow) - (if (>= emacs-major-version 28) - (string-replace "\n" "" (yow)) - (replace-regexp-in-string "\n" "" (yow))) - (erc-quit/part-reason-default)))) + (or s (erc-quit/part-reason-default))) (make-obsolete 'erc-quit-reason-zippy "it will be removed." "24.4") @@ -3668,12 +3649,7 @@ If S is non-nil, it will be used as the part reason." "Zippy part message. If S is non-nil, it will be used as the quit reason." - (or s - (if (fboundp 'yow) - (if (>= emacs-major-version 28) - (string-replace "\n" "" (yow)) - (replace-regexp-in-string "\n" "" (yow))) - (erc-quit/part-reason-default)))) + (or s (erc-quit/part-reason-default))) (make-obsolete 'erc-part-reason-zippy "it will be removed." "24.4") @@ -3754,13 +3730,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/em-banner.el b/lisp/eshell/em-banner.el index ecac9d2a30e..a2f8a58220c 100644 --- a/lisp/eshell/em-banner.el +++ b/lisp/eshell/em-banner.el @@ -61,10 +61,9 @@ modules may have a simple template to begin with." "The banner message to be displayed when Eshell is loaded. This can be any sexp, and should end with at least two newlines." :type 'sexp + :risky t :group 'eshell-banner) -(put 'eshell-banner-message 'risky-local-variable t) - (defcustom eshell-banner-load-hook nil "A list of functions to run when `eshell-banner' is loaded." :version "24.1" ; removed eshell-banner-initialize diff --git a/lisp/eshell/em-basic.el b/lisp/eshell/em-basic.el index 27b343ad398..448b6787ee7 100644 --- a/lisp/eshell/em-basic.el +++ b/lisp/eshell/em-basic.el @@ -82,7 +82,11 @@ equivalent of `echo' can always be achieved by using `identity'." It returns a formatted value that should be passed to `eshell-print' or `eshell-printn' for display." (if eshell-plain-echo-behavior - (concat (apply 'eshell-flatten-and-stringify args) "\n") + (progn + ;; If the output does not end in a newline, do not emit one. + (setq eshell-ensure-newline-p nil) + (concat (apply #'eshell-flatten-and-stringify args) + (when output-newline "\n"))) (let ((value (cond ((= (length args) 0) "") @@ -109,18 +113,33 @@ or `eshell-printn' for display." "Implementation of `echo'. See `eshell-plain-echo-behavior'." (eshell-eval-using-options "echo" args - '((?n nil nil output-newline "terminate with a newline") - (?h "help" nil nil "output this help screen") + '((?n nil (nil) output-newline + "do not output the trailing newline") + (?N nil (t) output-newline + "terminate with a newline") + (?E nil nil _disable-escapes + "don't interpret backslash escapes (default)") + (?h "help" nil nil + "output this help screen") :preserve-args - :usage "[-n] [object]") - (eshell-echo args output-newline))) + :usage "[OPTION]... [OBJECT]...") + (if eshell-plain-echo-behavior + (eshell-echo args (if output-newline (car output-newline) t)) + ;; In Emacs 28.1 and earlier, "-n" was used to add a newline to + ;; non-plain echo in Eshell. This caused confusion due to "-n" + ;; generally having the opposite meaning for echo. Retain this + ;; compatibility for the time being. For more info, see + ;; bug#27361. + (when (equal output-newline '(nil)) + (display-warning + :warning "To terminate with a newline, you should use -N instead.")) + (eshell-echo args output-newline)))) (defun eshell/printnl (&rest args) - "Print out each of the arguments, separated by newlines." + "Print out each of the arguments as strings, separated by newlines." (let ((elems (flatten-tree args))) - (while elems - (eshell-printn (eshell-echo (list (car elems)))) - (setq elems (cdr elems))))) + (dolist (elem elems) + (eshell-printn (eshell-stringify elem))))) (defun eshell/listify (&rest args) "Return the argument(s) as a single list." @@ -136,39 +155,37 @@ or `eshell-printn' for display." "umask" args '((?S "symbolic" nil symbolic-p "display umask symbolically") (?h "help" nil nil "display this usage message") + :preserve-args :usage "[-S] [mode]") - (if (or (not args) symbolic-p) - (let ((modstr - (concat "000" - (format "%o" - (logand (lognot (default-file-modes)) - 511))))) - (setq modstr (substring modstr (- (length modstr) 3))) - (when symbolic-p - (let ((mode (default-file-modes))) - (setq modstr - (format - "u=%s,g=%s,o=%s" - (concat (and (= (logand mode 64) 64) "r") - (and (= (logand mode 128) 128) "w") - (and (= (logand mode 256) 256) "x")) - (concat (and (= (logand mode 8) 8) "r") - (and (= (logand mode 16) 16) "w") - (and (= (logand mode 32) 32) "x")) - (concat (and (= (logand mode 1) 1) "r") - (and (= (logand mode 2) 2) "w") - (and (= (logand mode 4) 4) "x")))))) - (eshell-printn modstr)) - (setcar args (eshell-convert (car args))) - (if (numberp (car args)) - (set-default-file-modes - (- 511 (car (read-from-string - (concat "?\\" (number-to-string (car args))))))) - (error "Setting umask symbolically is not yet implemented")) + (cond + (symbolic-p + (let ((mode (default-file-modes))) + (eshell-printn + (format "u=%s,g=%s,o=%s" + (concat (and (= (logand mode 64) 64) "r") + (and (= (logand mode 128) 128) "w") + (and (= (logand mode 256) 256) "x")) + (concat (and (= (logand mode 8) 8) "r") + (and (= (logand mode 16) 16) "w") + (and (= (logand mode 32) 32) "x")) + (concat (and (= (logand mode 1) 1) "r") + (and (= (logand mode 2) 2) "w") + (and (= (logand mode 4) 4) "x")))))) + ((not args) + (eshell-printn (format "%03o" (logand (lognot (default-file-modes)) + #o777)))) + (t + (when (stringp (car args)) + (if (string-match "^[0-7]+$" (car args)) + (setcar args (string-to-number (car args) 8)) + (error "Setting umask symbolically is not yet implemented"))) + (set-default-file-modes (- #o777 (car args))) (eshell-print - "Warning: umask changed for all new files created by Emacs.\n")) + "Warning: umask changed for all new files created by Emacs.\n"))) nil)) +(put 'eshell/umask 'eshell-no-numeric-conversions t) + (provide 'em-basic) ;; Local Variables: diff --git a/lisp/eshell/em-cmpl.el b/lisp/eshell/em-cmpl.el index 706eb8aede0..f4c1302629b 100644 --- a/lisp/eshell/em-cmpl.el +++ b/lisp/eshell/em-cmpl.el @@ -226,19 +226,17 @@ to writing a completion function." (let ((completion-at-point-functions '(elisp-completion-at-point))) (completion-at-point))) -(defvar eshell-cmpl-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [(control ?i)] #'completion-at-point) - ;; jww (1999-10-19): Will this work on anything but X? - (define-key map [backtab] #'pcomplete-reverse) - (define-key map [(meta ??)] #'completion-help-at-point) - (define-key map [(meta control ?i)] #'eshell-complete-lisp-symbol) - ;; C-c prefix: - (define-key map (kbd "C-c M-h") #'eshell-completion-help) - (define-key map (kbd "C-c TAB") #'pcomplete-expand-and-complete) - (define-key map (kbd "C-c C-i") #'pcomplete-expand-and-complete) - (define-key map (kbd "C-c SPC") #'pcomplete-expand) - map)) +(defvar-keymap eshell-cmpl-mode-map + "C-i" #'completion-at-point + ;; jww (1999-10-19): Will this work on anything but X? + "<backtab>" #'pcomplete-reverse + "M-?" #'completion-help-at-point + "C-M-i" #'eshell-complete-lisp-symbol + ;; C-c prefix: + "C-c M-h" #'eshell-completion-help + "C-c TAB" #'pcomplete-expand-and-complete + "C-c C-i" #'pcomplete-expand-and-complete + "C-c SPC" #'pcomplete-expand) (define-minor-mode eshell-cmpl-mode "Minor mode that provides a keymap when `eshell-cmpl' active. @@ -313,18 +311,24 @@ to writing a completion function." (describe-prefix-bindings) (call-interactively 'pcomplete-help))) +(defun eshell--pcomplete-insert-tab () + (if (not pcomplete-allow-modifications) + (throw 'pcompleted nil) + (insert-and-inherit "\t") + (throw 'pcompleted t))) + (defun eshell-complete-parse-arguments () "Parse the command line arguments for `pcomplete-argument'." (when (and eshell-no-completion-during-jobs - (eshell-interactive-process)) - (insert-and-inherit "\t") - (throw 'pcompleted t)) + (eshell-interactive-process-p)) + (eshell--pcomplete-insert-tab)) (let ((end (point-marker)) (begin (save-excursion (eshell-bol) (point))) (posns (list t)) args delim) - (when (memq this-command '(pcomplete-expand - pcomplete-expand-and-complete)) + (when (and pcomplete-allow-modifications + (memq this-command '(pcomplete-expand + pcomplete-expand-and-complete))) (run-hook-with-args 'eshell-expand-input-functions begin end) (if (= begin end) (end-of-line)) @@ -337,14 +341,11 @@ to writing a completion function." (setq begin (1+ (cadr delim)) args (eshell-parse-arguments begin end))) ((eq (car delim) ?\() - (eshell-complete-lisp-symbol) - (throw 'pcompleted t)) + (throw 'pcompleted (elisp-completion-at-point))) (t - (insert-and-inherit "\t") - (throw 'pcompleted t)))) + (eshell--pcomplete-insert-tab)))) (when (get-text-property (1- end) 'comment) - (insert-and-inherit "\t") - (throw 'pcompleted t)) + (eshell--pcomplete-insert-tab)) (let ((pos begin)) (while (< pos end) (if (get-text-property pos 'arg-begin) diff --git a/lisp/eshell/em-dirs.el b/lisp/eshell/em-dirs.el index 893cad7b4fb..5396044d8ca 100644 --- a/lisp/eshell/em-dirs.el +++ b/lisp/eshell/em-dirs.el @@ -313,7 +313,7 @@ With the following piece of advice, you can make this functionality available in most of Emacs, with the exception of filename completion in the minibuffer: - (advice-add 'expand-file-name :around #'my-expand-multiple-dots) + (advice-add \\='expand-file-name :around #\\='my-expand-multiple-dots) (defun my-expand-multiple-dots (orig-fun filename &rest args) (apply orig-fun (eshell-expand-multiple-dots filename) args))" (while (string-match "\\(?:\\`\\|/\\)\\.\\.\\(\\.+\\)\\(?:\\'\\|/\\)" @@ -391,6 +391,10 @@ in the minibuffer: (unless (equal curdir newdir) (eshell-add-to-dir-ring curdir)) (let ((result (cd newdir))) + ;; If we're in "/" and cd to ".." or the like, make things + ;; less confusing by changing "/.." to "/". + (when (equal (file-truename result) "/") + (setq result (cd "/"))) (and eshell-cd-shows-directory (eshell-printn result))) (run-hooks 'eshell-directory-change-hook) diff --git a/lisp/eshell/em-elecslash.el b/lisp/eshell/em-elecslash.el new file mode 100644 index 00000000000..091acb9a861 --- /dev/null +++ b/lisp/eshell/em-elecslash.el @@ -0,0 +1,120 @@ +;;; em-elecslash.el --- electric forward slashes -*- lexical-binding:t -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; Author: Sean Whitton <spwhitton@spwhitton.name> + +;; 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: + +;; Electric forward slash in remote Eshells. + +;;; Code: + +(require 'tramp) +(require 'thingatpt) +(require 'esh-cmd) +(require 'esh-ext) +(require 'esh-mode) + +;; This makes us an option when customizing `eshell-modules-list'. +;;;###autoload +(progn +(defgroup eshell-elecslash nil + "Electric forward slash in remote Eshells. + +This module helps with supplying absolute file name arguments to +remote commands. After enabling it, typing a forward slash as +the first character of a command line argument will automatically +insert the Tramp prefix, /method:host:. The automatic insertion +applies only when `default-directory' is remote and the command +is a Lisp function. + +The result is that in most cases of supplying absolute file name +arguments to commands you should see the Tramp prefix inserted +automatically only when that's what you'd reasonably expect. +This frees you from having to keep track of whether commands are +Lisp functions or external when typing command line arguments." + :tag "Electric forward slash" + :group 'eshell-module)) + +;;; Functions: + +(defun eshell-elecslash-initialize () ;Called from `eshell-mode' via intern-soft! + "Initialize remote Eshell electric forward slash support." + (add-hook 'post-self-insert-hook + #'eshell-electric-forward-slash nil t)) + +(defun eshell-electric-forward-slash () + "Implementation of electric forward slash in remote Eshells. + +Initializing the `eshell-elecslash' module adds this function to +`post-self-insert-hook'. Typing / or ~/ as the first character +of a command line argument automatically inserts the Tramp prefix +in the case that `default-directory' is remote and the command is +a Lisp function. Typing a second forward slash undoes the +insertion." + (when (eq ?/ (char-before)) + (delete-char -1) + (let ((tilde-before (eq ?~ (char-before))) + (command (save-excursion + (eshell-bol) + (skip-syntax-forward " ") + (thing-at-point 'sexp)))) + (if (and (file-remote-p default-directory) + ;; We can't formally parse the input. But if there is + ;; one of these operators behind us, then looking at + ;; the first command would not be sensible. So be + ;; conservative: don't insert the Tramp prefix if there + ;; are any of these operators behind us. + (not (looking-back (regexp-opt '("&&" "|" ";")) + eshell-last-output-end)) + (or (= (point) eshell-last-output-end) + (and tilde-before + (= (1- (point)) eshell-last-output-end)) + (and (or tilde-before + (eq ?\s (char-syntax (char-before)))) + (or (eshell-find-alias-function command) + (and (fboundp (intern-soft command)) + (or eshell-prefer-lisp-functions + (not (eshell-search-path command)))))))) + (let ((map (make-sparse-keymap)) + (start (if tilde-before (1- (point)) (point))) + (localname + (tramp-file-name-localname + (tramp-dissect-file-name default-directory)))) + (when tilde-before (delete-char -1)) + (insert + (substring default-directory 0 + (string-search localname default-directory))) + (unless tilde-before (insert "/")) + ;; Typing a second slash undoes the insertion, for when + ;; you really do want to type a local absolute file name. + (define-key map "/" (lambda () + (interactive) + (delete-region start (point)) + (insert (if tilde-before "~/" "/")))) + (set-transient-map map)) + (insert "/"))))) + +(provide 'em-elecslash) + +;; Local Variables: +;; generated-autoload-file: "esh-groups.el" +;; End: + +;;; esh-elecslash.el ends here diff --git a/lisp/eshell/em-extpipe.el b/lisp/eshell/em-extpipe.el new file mode 100644 index 00000000000..3db1dea5955 --- /dev/null +++ b/lisp/eshell/em-extpipe.el @@ -0,0 +1,204 @@ +;;; em-extpipe.el --- external shell pipelines -*- lexical-binding:t -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; Author: Sean Whitton <spwhitton@spwhitton.name> + +;; 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: + +;; When constructing shell pipelines that will move a lot of data, it +;; is a good idea to bypass Eshell's own pipelining support and use +;; the operating system shell's instead. This module tries to make +;; that easy to do. + +;;; Code: + +(require 'cl-lib) +(require 'esh-arg) +(require 'esh-cmd) +(require 'esh-io) +(require 'esh-util) + +(eval-when-compile (require 'files-x)) + +;;; Functions: + +(defun eshell-extpipe-initialize () ;Called from `eshell-mode' via intern-soft! + "Initialize external pipelines support." + (when (boundp 'eshell-special-chars-outside-quoting) + (setq-local + eshell-special-chars-outside-quoting + (append eshell-special-chars-outside-quoting (list ?\*)))) + (add-hook 'eshell-parse-argument-hook + #'eshell-parse-external-pipeline -20 t) + (add-hook 'eshell-pre-rewrite-command-hook + #'eshell-rewrite-external-pipeline -20 t)) + +(defmacro em-extpipe--or-with-catch (&rest disjuncts) + "Evaluate DISJUNCTS like `or' but catch `eshell-incomplete'. + +If `eshell-incomplete' is thrown during the evaluation of a +disjunct, that disjunct yields nil." + (let ((result (gensym))) + `(let (,result) + (or ,@(cl-loop for disjunct in disjuncts collect + `(if (catch 'eshell-incomplete + (ignore (setq ,result ,disjunct))) + nil + ,result)))))) + +(defun eshell-parse-external-pipeline () + "Parse a pipeline intended for execution by the external shell. + +A sequence of arguments is rewritten to use the operating system +shell when it contains `*|', `*<' or `*>', where the asterisk is +preceded by whitespace or located at the start of input. + +The command extends to the next `|' character which is not +preceded by an unescaped asterisk following whitespace, or the +end of input, except that any Eshell-specific output redirections +occurring at the end are excluded. Any other `<' or `>' +appearing before the end of the command are treated as though +preceded by (whitespace and) an asterisk. + +For example, + + foo <bar *| baz >#<buffer quux> + +is equivalent to + + sh -c \"foo <bar | baz\" >#<buffer quux> + +when `shell-file-name' is `sh' and `shell-command-switch' is +`-c', but in + + foo >#<buffer quux> *| baz + +and + + foo *| baz >#<buffer quux> --some-argument + +the Eshell-specific redirect will be passed on to the operating +system shell, probably leading to undesired results. + +This function must appear early in `eshell-parse-argument-hook' +to ensure that operating system shell syntax is not interpreted +as though it were Eshell syntax." + ;; Our goal is to wrap the external command to protect it from the + ;; other members of `eshell-parse-argument-hook'. We must avoid + ;; misinterpreting a quoted `*|', `*<' or `*>' as indicating an + ;; external pipeline, hence the structure of the loop in `findbeg1'. + (cl-flet + ((findbeg1 (pat &optional go (bound (point-max))) + (let* ((start (point)) + (result + (catch 'found + (while (> bound (point)) + (let* ((found + (save-excursion + (re-search-forward + "\\(?:#?'\\|\"\\|\\\\\\)" bound t))) + (next (or (and found (match-beginning 0)) + bound))) + (if (re-search-forward pat next t) + (throw 'found (match-beginning 1)) + (goto-char next) + (while (em-extpipe--or-with-catch + (eshell-parse-lisp-argument) + (eshell-parse-backslash) + (eshell-parse-double-quote) + (eshell-parse-literal-quote))) + ;; Guard against an infinite loop if none of + ;; the parsers moved us forward. + (unless (or (> (point) next) (eobp)) + (forward-char 1)))))))) + (goto-char (if (and result go) (match-end 0) start)) + result))) + (unless (or eshell-current-argument eshell-current-quoted) + (let ((beg (point)) end + (next-marked (findbeg1 "\\(?:\\=\\|\\s-\\)\\(\\*[|<>]\\)")) + (next-unmarked + (or (findbeg1 "\\(?:\\=\\|[^*]\\|\\S-\\*\\)\\(|\\)") + (point-max)))) + (when (and next-marked (> next-unmarked next-marked) + (or (> next-marked (point)) + (looking-back "\\`\\|\\s-" nil))) + ;; Skip to the final segment of the external pipeline. + (while (findbeg1 "\\(?:\\=\\|\\s-\\)\\(\\*|\\)" t)) + ;; Find output redirections. + (while (findbeg1 + "\\([0-9]?>+&?[0-9]?\\s-*\\S-\\)" t next-unmarked) + ;; Is the output redirection Eshell-specific? We have our + ;; own logic, rather than calling `eshell-parse-argument', + ;; to avoid specifying here all the possible cars of + ;; parsed special references -- `get-buffer-create' etc. + (forward-char -1) + (let ((this-end + (save-match-data + (cond ((looking-at "#<") + (forward-char 1) + (1+ (eshell-find-delimiter ?\< ?\>))) + ((and (looking-at "/\\S-+") + (assoc (match-string 0) + eshell-virtual-targets)) + (match-end 0)))))) + (cond ((and this-end end) + (goto-char this-end)) + (this-end + (goto-char this-end) + (setq end (match-beginning 0))) + (t + (setq end nil))))) + ;; We've moved past all Eshell-specific output redirections + ;; we could find. If there is only whitespace left, then + ;; `end' is right before redirections we should exclude; + ;; otherwise, we must include everything. + (unless (and end (skip-syntax-forward "\s" next-unmarked) + (= next-unmarked (point))) + (setq end next-unmarked)) + (let ((cmd (string-trim + (buffer-substring-no-properties beg end)))) + (goto-char end) + ;; We must now drop the asterisks, unless quoted/escaped. + (with-temp-buffer + (insert cmd) + (goto-char (point-min)) + (cl-loop + for next = (findbeg1 "\\(?:\\=\\|\\s-\\)\\(\\*[|<>]\\)" t) + while next do (forward-char -2) (delete-char 1)) + (eshell-finish-arg + `(eshell-external-pipeline ,(buffer-string)))))))))) + +(defun eshell-rewrite-external-pipeline (terms) + "Rewrite an external pipeline in TERMS as parsed by +`eshell-parse-external-pipeline', which see." + (while terms + (when (and (listp (car terms)) + (eq (caar terms) 'eshell-external-pipeline)) + (with-connection-local-variables + (setcdr terms (cl-list* + shell-command-switch (cadar terms) (cdr terms))) + (setcar terms shell-file-name))) + (setq terms (cdr terms)))) + +(defsubst eshell-external-pipeline (&rest _args) + "Stub to generate an error if a pipeline is not rewritten." + (error "Unhandled external pipeline in input text")) + +(provide 'em-extpipe) +;;; esh-extpipe.el ends here diff --git a/lisp/eshell/em-glob.el b/lisp/eshell/em-glob.el index 842f27a4920..52531ff8939 100644 --- a/lisp/eshell/em-glob.el +++ b/lisp/eshell/em-glob.el @@ -233,7 +233,10 @@ resulting regular expression." "\\'"))) (defun eshell-extended-glob (glob) - "Return a list of files generated from GLOB, perhaps looking for DIRS-ONLY. + "Return a list of files matched by GLOB. +If no files match, signal an error (if `eshell-error-if-no-glob' +is non-nil), or otherwise return GLOB itself. + This function almost fully supports zsh style filename generation syntax. Things that are not supported are: @@ -243,12 +246,7 @@ syntax. Things that are not supported are: foo~x(a|b) (a|b) will be interpreted as a predicate/modifier list Mainly they are not supported because file matching is done with Emacs -regular expressions, and these cannot support the above constructs. - -If this routine fails, it returns nil. Otherwise, it returns a list -the form: - - (INCLUDE-REGEXP EXCLUDE-REGEXP (PRED-FUNC-LIST) (MOD-FUNC-LIST))" +regular expressions, and these cannot support the above constructs." (let ((paths (eshell-split-path glob)) eshell-glob-matches message-shown) (unwind-protect @@ -287,7 +285,7 @@ the form: glob (car globs) len (length glob))))) (if (and recurse-p (not glob)) - (error "`**' cannot end a globbing pattern")) + (error "`**/' cannot end a globbing pattern")) (let ((index 1)) (setq incl glob) (while (and (eq incl glob) diff --git a/lisp/eshell/em-hist.el b/lisp/eshell/em-hist.el index 49b811eae37..1877749c5cf 100644 --- a/lisp/eshell/em-hist.el +++ b/lisp/eshell/em-hist.el @@ -104,7 +104,7 @@ in bash, and any other non-nil value mirrors the \"ignoredups\" value." :type '(choice (const :tag "Don't ignore anything" nil) (const :tag "Ignore consecutive duplicates" t) - (const :tag "Only keep last duplicate" 'erase))) + (const :tag "Only keep last duplicate" erase))) (defcustom eshell-save-history-on-exit t "Determine if history should be automatically saved. @@ -125,16 +125,34 @@ the input history list. Default is to save anything that isn't all whitespace." :type '(radio (function-item eshell-input-filter-default) (function-item eshell-input-filter-initial-space) - (function :tag "Other function"))) - -(put 'eshell-input-filter 'risky-local-variable t) + (function :tag "Other function")) + :risky t) + +(defun eshell-hist--update-keymap (symbol value) + "Update `eshell-hist-mode-map' for `eshell-hist-match-partial'." + ;; Don't try to set this before it is bound. See below. + (when (and (boundp 'eshell-hist-mode-map) + (eq symbol 'eshell-hist-match-partial)) + (dolist (keyb + (if value + `(("M-p" . ,#'eshell-previous-matching-input-from-input) + ("M-n" . ,#'eshell-next-matching-input-from-input) + ("C-c M-p" . ,#'eshell-previous-input) + ("C-c M-n" . ,#'eshell-next-input)) + `(("M-p" . ,#'eshell-previous-input) + ("M-n" . ,#'eshell-next-input) + ("C-c M-p" . ,#'eshell-previous-matching-input-from-input) + ("C-c M-n" . ,#'eshell-next-matching-input-from-input)))) + (keymap-set eshell-hist-mode-map (car keyb) (cdr keyb)))) + (set-default symbol value)) (defcustom eshell-hist-match-partial t "If non-nil, movement through history is constrained by current input. -Otherwise, typing <M-p> and <M-n> will always go to the next history +Otherwise, typing \\`M-p' and \\`M-n' will always go to the next history element, regardless of any text on the command line. In that case, -<C-c M-r> and <C-c M-s> still offer that functionality." - :type 'boolean) +\\`C-c M-r' and \\`C-c M-s' still offer that functionality." + :type 'boolean + :set 'eshell-hist--update-keymap) (defcustom eshell-hist-move-to-end t "If non-nil, move to the end of the buffer before cycling history." @@ -180,43 +198,31 @@ element, regardless of any text on the command line. In that case, (defvar eshell-matching-input-from-input-string "") (defvar eshell-save-history-index nil) -(defvar eshell-isearch-map - (let ((map (copy-keymap isearch-mode-map))) - (define-key map [(control ?m)] 'eshell-isearch-return) - (define-key map [(control ?r)] 'eshell-isearch-repeat-backward) - (define-key map [(control ?s)] 'eshell-isearch-repeat-forward) - (define-key map [(control ?g)] 'eshell-isearch-abort) - (define-key map [backspace] 'eshell-isearch-delete-char) - (define-key map [delete] 'eshell-isearch-delete-char) - (define-key map "\C-c\C-c" 'eshell-isearch-cancel) - map) - "Keymap used in isearch in Eshell.") - -(defvar eshell-hist-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [up] #'eshell-previous-matching-input-from-input) - (define-key map [down] #'eshell-next-matching-input-from-input) - (define-key map [(control up)] #'eshell-previous-input) - (define-key map [(control down)] #'eshell-next-input) - (define-key map [(meta ?r)] #'eshell-previous-matching-input) - (define-key map [(meta ?s)] #'eshell-next-matching-input) - (define-key map (kbd "C-c M-r") #'eshell-previous-matching-input-from-input) - (define-key map (kbd "C-c M-s") #'eshell-next-matching-input-from-input) - ;; FIXME: Relies on `eshell-hist-match-partial' being set _before_ - ;; em-hist is loaded and won't respect changes. - (if eshell-hist-match-partial - (progn - (define-key map [(meta ?p)] 'eshell-previous-matching-input-from-input) - (define-key map [(meta ?n)] 'eshell-next-matching-input-from-input) - (define-key map (kbd "C-c M-p") #'eshell-previous-input) - (define-key map (kbd "C-c M-n") #'eshell-next-input)) - (define-key map [(meta ?p)] #'eshell-previous-input) - (define-key map [(meta ?n)] #'eshell-next-input) - (define-key map (kbd "C-c M-p") #'eshell-previous-matching-input-from-input) - (define-key map (kbd "C-c M-n") #'eshell-next-matching-input-from-input)) - (define-key map (kbd "C-c C-l") #'eshell-list-history) - (define-key map (kbd "C-c C-x") #'eshell-get-next-from-history) - map)) +(defvar-keymap eshell-isearch-map + :doc "Keymap used in isearch in Eshell." + :parent isearch-mode-map + "C-m" #'eshell-isearch-return + "C-r" #'eshell-isearch-repeat-backward + "C-s" #'eshell-isearch-repeat-forward + "C-g" #'eshell-isearch-abort + "<backspace>" #'eshell-isearch-delete-char + "<delete>" #'eshell-isearch-delete-char + "C-c C-c" #'eshell-isearch-cancel) + +(defvar-keymap eshell-hist-mode-map + "<up>" #'eshell-previous-matching-input-from-input + "<down>" #'eshell-next-matching-input-from-input + "C-<up>" #'eshell-previous-input + "C-<down>" #'eshell-next-input + "M-r" #'eshell-previous-matching-input + "M-s" #'eshell-next-matching-input + "C-c M-r" #'eshell-previous-matching-input-from-input + "C-c M-s" #'eshell-next-matching-input-from-input + "C-c C-l" #'eshell-list-history + "C-c C-x" #'eshell-get-next-from-history) +;; Update `eshell-hist-mode-map' for `eshell-hist-match-partial'. +(eshell-hist--update-keymap 'eshell-hist-match-partial + eshell-hist-match-partial) (defvar eshell-rebind-keys-alist) @@ -335,7 +341,7 @@ unless a different file is specified on the command line.") (error "No history")) (let (length file) (when (and args (string-match "^[0-9]+$" (car args))) - (setq length (min (eshell-convert (car args)) + (setq length (min (string-to-number (car args)) (ring-length eshell-history-ring)) args (cdr args))) (and length diff --git a/lisp/eshell/em-ls.el b/lisp/eshell/em-ls.el index 846f3d5e290..874591d2501 100644 --- a/lisp/eshell/em-ls.el +++ b/lisp/eshell/em-ls.el @@ -100,15 +100,14 @@ faster and conserves more memory." :type 'boolean) (defface eshell-ls-directory - '((((class color) (background light)) (:foreground "Blue" :weight bold)) - (((class color) (background dark)) (:foreground "SkyBlue" :weight bold)) - (t (:weight bold))) - "The face used for highlighting directories.") + '((t (:inherit font-lock-function-name-face))) + "The face used for highlighting directories." + :version "29.1") (defface eshell-ls-symlink - '((((class color) (background light)) (:foreground "Dark Cyan" :weight bold)) - (((class color) (background dark)) (:foreground "Cyan" :weight bold))) - "The face used for highlighting symbolic links.") + '((t (:inherit font-lock-keyword-face))) + "The face used for highlighting symbolic links." + :version "29.1") (defface eshell-ls-executable '((((class color) (background light)) (:foreground "ForestGreen" :weight bold)) diff --git a/lisp/eshell/em-pred.el b/lisp/eshell/em-pred.el index 4f4e85c1a69..d73976d3464 100644 --- a/lisp/eshell/em-pred.el +++ b/lisp/eshell/em-pred.el @@ -68,7 +68,7 @@ ordinary strings." (defcustom eshell-predicate-alist '((?/ . (eshell-pred-file-type ?d)) ; directories (?. . (eshell-pred-file-type ?-)) ; regular files - (?s . (eshell-pred-file-type ?s)) ; sockets + (?= . (eshell-pred-file-type ?s)) ; sockets (?p . (eshell-pred-file-type ?p)) ; named pipes (?@ . (eshell-pred-file-type ?l)) ; symbolic links (?% . (eshell-pred-file-type ?%)) ; allow user to specify (c def.) @@ -88,17 +88,17 @@ ordinary strings." (if (file-exists-p file) (= (file-attribute-user-id (file-attributes file)) (user-uid))))) - ;; (?G . (lambda (file) ; owned by effective gid - ;; (if (file-exists-p file) - ;; (= (file-attribute-user-id (file-attributes file)) - ;; (user-uid))))) + (?G . (lambda (file) ; owned by effective gid + (if (file-exists-p file) + (= (file-attribute-group-id (file-attributes file)) + (group-gid))))) (?* . (lambda (file) (and (file-regular-p file) (not (file-symlink-p file)) (file-executable-p file)))) (?l . (eshell-pred-file-links)) - (?u . (eshell-pred-user-or-group ?u "user" 2 'eshell-user-id)) - (?g . (eshell-pred-user-or-group ?g "group" 3 'eshell-group-id)) + (?u . (eshell-pred-user-or-group ?u "user" 2 #'eshell-user-id)) + (?g . (eshell-pred-user-or-group ?g "group" 3 #'eshell-group-id)) (?a . (eshell-pred-file-time ?a "access" 4)) (?m . (eshell-pred-file-time ?m "modification" 5)) (?c . (eshell-pred-file-time ?c "change" 6)) @@ -107,33 +107,27 @@ ordinary strings." The format of each entry is (CHAR . PREDICATE-FUNC-SEXP)" - :type '(repeat (cons character sexp))) - -(put 'eshell-predicate-alist 'risky-local-variable t) + :type '(repeat (cons character sexp)) + :risky t) (defcustom eshell-modifier-alist - '((?E . (lambda (lst) - (mapcar - (lambda (str) - (eshell-stringify - (car (eshell-parse-argument str)))) - lst))) + '((?E . (lambda (lst) (mapcar #'eshell-eval-argument lst))) (?L . (lambda (lst) (mapcar #'downcase lst))) (?U . (lambda (lst) (mapcar #'upcase lst))) (?C . (lambda (lst) (mapcar #'capitalize lst))) (?h . (lambda (lst) (mapcar #'file-name-directory lst))) - (?i . (eshell-include-members)) - (?x . (eshell-include-members t)) + (?i . (eshell-include-members ?i)) + (?x . (eshell-include-members ?x t)) (?r . (lambda (lst) (mapcar #'file-name-sans-extension lst))) (?e . (lambda (lst) (mapcar #'file-name-extension lst))) (?t . (lambda (lst) (mapcar #'file-name-nondirectory lst))) (?q . (lambda (lst) (mapcar #'eshell-escape-arg lst))) (?u . (lambda (lst) (seq-uniq lst))) (?o . (lambda (lst) (sort lst #'string-lessp))) - (?O . (lambda (lst) (nreverse (sort lst #'string-lessp)))) + (?O . (lambda (lst) (sort lst #'string-greaterp))) (?j . (eshell-join-members)) (?S . (eshell-split-members)) - (?R . 'reverse) + (?R . #'reverse) (?g . (progn (forward-char) (if (eq (char-before) ?s) @@ -143,10 +137,9 @@ The format of each entry is "A list of modifiers than can be applied to an argument expansion. The format of each entry is - (CHAR ENTRYWISE-P MODIFIER-FUNC-SEXP)" - :type '(repeat (cons character sexp))) - -(put 'eshell-modifier-alist 'risky-local-variable t) + (CHAR . MODIFIER-FUNC-SEXP)" + :type '(repeat (cons character sexp)) + :risky t) (defvar eshell-predicate-help-string "Eshell predicate quick reference: @@ -168,6 +161,7 @@ PERMISSION BITS (for owner/group/world): OWNERSHIP: U owned by effective uid + G owned by effective gid u(UID|\\='user\\=') owned by UID/user g(GID|\\='group\\=') owned by GID/group @@ -219,17 +213,29 @@ FOR LISTS OF ARGUMENTS: i/PAT/ exclude all members not matching PAT x/PAT/ exclude all members matching PAT - s/pat/match/ substitute PAT with MATCH - g/pat/match/ substitute PAT with MATCH for all occurrences + s/pat/match/ substitute PAT with MATCH + gs/pat/match/ substitute PAT with MATCH for all occurrences EXAMPLES: *.c(:o) sorted list of .c files") -(defvar eshell-pred-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-c M-q") #'eshell-display-predicate-help) - (define-key map (kbd "C-c M-m") #'eshell-display-modifier-help) - map)) +(defvar eshell-pred-delimiter-pairs + '((?\( . ?\)) + (?\[ . ?\]) + (?\< . ?\>) + (?\{ . ?\}) + (?\' . ?\') + (?\" . ?\") + (?/ . ?/) + (?| . ?|)) + "A list of delimiter pairs that can be used in argument predicates/modifiers. +Each element is of the form (OPEN . CLOSE), where OPEN and CLOSE +are characters representing the opening and closing delimiter, +respectively.") + +(defvar-keymap eshell-pred-mode-map + "C-c M-q" #'eshell-display-predicate-help + "C-c M-m" #'eshell-display-modifier-help) ;;; Functions: @@ -372,38 +378,70 @@ resultant list of strings." (lambda (file) (funcall pred (file-truename file)))))) (cons pred funcs)) +(defun eshell-get-comparison-modifier-argument (&optional functions) + "Starting at point, get the comparison modifier argument, if any. +These are the -/+ characters, corresponding to `<' and `>', +respectively. If no comparison modifier is at point, return `='. + +FUNCTIONS, if non-nil, is a list of comparison functions, +specified as (LESS-THAN GREATER-THAN EQUAL-TO)." + (let ((functions (or functions (list #'< #'> #'=)))) + (if (memq (char-after) '(?- ?+)) + (prog1 + (if (eq (char-after) ?-) (nth 0 functions) (nth 1 functions)) + (forward-char)) + (nth 2 functions)))) + +(defun eshell-get-numeric-modifier-argument () + "Starting at point, get the numeric modifier argument, if any. +If a number is found, update point to just after the number." + (when (looking-at "[0-9]+") + (prog1 + (string-to-number (match-string 0)) + (goto-char (match-end 0))))) + +(defun eshell-get-delimited-modifier-argument (&optional chained-p) + "Starting at point, get the delimited modifier argument, if any. +If the character after point is a predicate/modifier +delimiter (see `eshell-pred-delimiter-pairs', read the value of +the argument and update point to be just after the closing +delimiter. + +If CHAINED-P is true, then another delimited modifier argument +will immediately follow this one. In this case, when the opening +and closing delimiters are the same, update point to be just +before the closing delimiter. This allows modifiers like +`:s/match/repl' to work as expected." + (when-let* ((open (char-after)) + (close (cdr (assoc open eshell-pred-delimiter-pairs))) + (end (eshell-find-delimiter open close nil nil t))) + (prog1 + (replace-regexp-in-string + (rx-to-string `(seq "\\" (group (or "\\" ,open ,close)))) "\\1" + (buffer-substring-no-properties (1+ (point)) end)) + (goto-char (if (and chained-p (eq open close)) + end + (1+ end)))))) + (defun eshell-pred-user-or-group (mod-char mod-type attr-index get-id-func) "Return a predicate to test whether a file match a given user/group id." - (let (ugid open close end) - (if (looking-at "[0-9]+") - (progn - (setq ugid (string-to-number (match-string 0))) - (goto-char (match-end 0))) - (setq open (char-after)) - (if (setq close (memq open '(?\( ?\[ ?\< ?\{))) - (setq close (car (last '(?\) ?\] ?\> ?\}) - (length close)))) - (setq close open)) - (forward-char) - (setq end (eshell-find-delimiter open close)) - (unless end - (error "Malformed %s name string for modifier `%c'" - mod-type mod-char)) - (setq ugid - (funcall get-id-func (buffer-substring (point) end))) - (goto-char (1+ end))) + (let ((ugid (eshell-get-numeric-modifier-argument))) + (unless ugid + (let ((ugname (or (eshell-get-delimited-modifier-argument) + (error "Malformed %s name string for modifier `%c'" + mod-type mod-char)))) + (setq ugid (funcall get-id-func ugname)))) (unless ugid (error "Unknown %s name specified for modifier `%c'" mod-type mod-char)) (lambda (file) - (let ((attrs (file-attributes file))) - (if attrs - (= (nth attr-index attrs) ugid)))))) + (when-let ((attrs (file-attributes file))) + (= (nth attr-index attrs) ugid))))) (defun eshell-pred-file-time (mod-char mod-type attr-index) "Return a predicate to test whether a file matches a certain time." (let* ((quantum 86400) - qual when open close end) + qual when) (when (memq (char-after) '(?M ?w ?h ?m ?s)) (setq quantum (char-after)) (cond @@ -418,36 +456,21 @@ resultant list of strings." ((eq quantum ?s) (setq quantum 1))) (forward-char)) - (when (memq (char-after) '(?+ ?-)) - (setq qual (char-after)) - (forward-char)) - (if (looking-at "[0-9]+") - (progn - (setq when (time-since (* (string-to-number (match-string 0)) - quantum))) - (goto-char (match-end 0))) - (setq open (char-after)) - (if (setq close (memq open '(?\( ?\[ ?\< ?\{))) - (setq close (car (last '(?\) ?\] ?\> ?\}) - (length close)))) - (setq close open)) - (forward-char) - (setq end (eshell-find-delimiter open close)) - (unless end - (error "Malformed %s time modifier `%c'" mod-type mod-char)) - (let* ((file (buffer-substring (point) end)) - (attrs (file-attributes file))) - (unless attrs - (error "Cannot stat file `%s'" file)) - (setq when (nth attr-index attrs))) - (goto-char (1+ end))) - (let ((f (cond ((eq qual ?-) #'time-less-p) - ((eq qual ?+) (lambda (a b) (time-less-p b a))) - (#'time-equal-p)))) - (lambda (file) - (let ((attrs (file-attributes file))) - (if attrs - (funcall f when (nth attr-index attrs)))))))) + (setq qual (eshell-get-comparison-modifier-argument + (list #'time-less-p + (lambda (a b) (time-less-p b a)) + #'time-equal-p))) + (if-let ((number (eshell-get-numeric-modifier-argument))) + (setq when (time-since (* number quantum))) + (let* ((file (or (eshell-get-delimited-modifier-argument) + (error "Malformed %s time modifier `%c'" + mod-type mod-char))) + (attrs (or (file-attributes file) + (error "Cannot stat file `%s'" file)))) + (setq when (nth attr-index attrs)))) + (lambda (file) + (when-let ((attrs (file-attributes file))) + (funcall qual when (nth attr-index attrs)))))) (defun eshell-pred-file-type (type) "Return a test which tests that the file is of a certain TYPE. @@ -462,36 +485,23 @@ that `ls -l' will show in the first column of its display." '(?b ?c) (list type)))) (lambda (file) - (let ((attrs (eshell-file-attributes (directory-file-name file)))) - (if attrs - (memq (aref (file-attribute-modes attrs) 0) set)))))) + (when-let ((attrs (eshell-file-attributes (directory-file-name file)))) + (memq (aref (file-attribute-modes attrs) 0) set))))) (defsubst eshell-pred-file-mode (mode) "Return a test which tests that MODE pertains to the file." (lambda (file) - (let ((modes (file-modes file 'nofollow))) - (if modes - (not (zerop (logand mode modes))))))) + (when-let ((modes (file-modes file 'nofollow))) + (not (zerop (logand mode modes)))))) (defun eshell-pred-file-links () "Return a predicate to test whether a file has a given number of links." - (let (qual amount) - (when (memq (char-after) '(?- ?+)) - (setq qual (char-after)) - (forward-char)) - (unless (looking-at "[0-9]+") - (error "Invalid file link count modifier `l'")) - (setq amount (string-to-number (match-string 0))) - (goto-char (match-end 0)) - (let ((f (if (eq qual ?-) - #'< - (if (eq qual ?+) - #'> - #'=)))) - (lambda (file) - (let ((attrs (eshell-file-attributes file))) - (if attrs - (funcall f (file-attribute-link-number attrs) amount))))))) + (let ((qual (eshell-get-comparison-modifier-argument)) + (amount (or (eshell-get-numeric-modifier-argument) + (error "Invalid file link count modifier `l'")))) + (lambda (file) + (when-let ((attrs (eshell-file-attributes file))) + (funcall qual (file-attribute-link-number attrs) amount))))) (defun eshell-pred-file-size () "Return a predicate to test whether a file is of a given size." @@ -506,89 +516,52 @@ that `ls -l' will show in the first column of its display." ((eq qual ?p) (setq quantum 512))) (forward-char)) - (when (memq (char-after) '(?- ?+)) - (setq qual (char-after)) - (forward-char)) - (unless (looking-at "[0-9]+") - (error "Invalid file size modifier `L'")) - (setq amount (* (string-to-number (match-string 0)) quantum)) - (goto-char (match-end 0)) - (let ((f (if (eq qual ?-) - #'< - (if (eq qual ?+) - #'> - #'=)))) - (lambda (file) - (let ((attrs (eshell-file-attributes file))) - (if attrs - (funcall f (file-attribute-size attrs) amount))))))) + (setq qual (eshell-get-comparison-modifier-argument)) + (setq amount (* (or (eshell-get-numeric-modifier-argument) + (error "Invalid file size modifier `L'")) + quantum)) + (lambda (file) + (when-let ((attrs (eshell-file-attributes file))) + (funcall qual (file-attribute-size attrs) amount))))) (defun eshell-pred-substitute (&optional repeat) "Return a modifier function that will substitute matches." - (let ((delim (char-after)) - match replace end) - (forward-char) - (setq end (eshell-find-delimiter delim delim nil nil t) - match (buffer-substring-no-properties (point) end)) - (goto-char (1+ end)) - (setq end (eshell-find-delimiter delim delim nil nil t) - replace (buffer-substring-no-properties (point) end)) - (goto-char (1+ end)) - (if repeat - (lambda (lst) - (mapcar - (lambda (str) - (let ((i 0)) - (while (setq i (string-match match str i)) - (setq str (replace-match replace t nil str)))) - str) - lst)) - (lambda (lst) - (mapcar - (lambda (str) - (if (string-match match str) - (setq str (replace-match replace t nil str)) - (error (concat str ": substitution failed"))) - str) - lst))))) - -(defun eshell-include-members (&optional invert-p) - "Include only Lisp members matching a regexp." - (let ((delim (char-after)) - regexp end) - (forward-char) - (setq end (eshell-find-delimiter delim delim nil nil t) - regexp (buffer-substring-no-properties (point) end)) - (goto-char (1+ end)) - (let ((predicates - (list (if invert-p - (lambda (elem) (not (string-match regexp elem))) - (lambda (elem) (string-match regexp elem)))))) - (lambda (lst) - (eshell-winnow-list lst nil predicates))))) + (let* ((match (or (eshell-get-delimited-modifier-argument t) + (error "Malformed pattern string for modifier `s'"))) + (replace (or (eshell-get-delimited-modifier-argument) + (error "Malformed replace string for modifier `s'"))) + (function (if repeat + (lambda (str) + (replace-regexp-in-string match replace str t)) + (lambda (str) + (if (string-match match str) + (replace-match replace t nil str) + (error (concat str ": substitution failed"))))))) + (lambda (lst) (mapcar function lst)))) + +(defun eshell-include-members (mod-char &optional invert-p) + "Include only Lisp members matching a regexp. +If INVERT-P is non-nil, include only members not matching a regexp." + (let* ((regexp (or (eshell-get-delimited-modifier-argument) + (error "Malformed pattern string for modifier `%c'" + mod-char))) + (predicates + (list (if invert-p + (lambda (elem) (not (string-match regexp elem))) + (lambda (elem) (string-match regexp elem)))))) + (lambda (lst) + (eshell-winnow-list lst nil predicates)))) (defun eshell-join-members () "Return a modifier function that join matches." - (let ((delim (char-after)) - str end) - (if (not (memq delim '(?' ?/))) - (setq delim " ") - (forward-char) - (setq end (eshell-find-delimiter delim delim nil nil t) - str (buffer-substring-no-properties (point) end)) - (goto-char (1+ end))) + (let ((str (or (eshell-get-delimited-modifier-argument) + " "))) (lambda (lst) (mapconcat #'identity lst str)))) (defun eshell-split-members () "Return a modifier function that splits members." - (let ((delim (char-after)) - sep end) - (when (memq delim '(?' ?/)) - (forward-char) - (setq end (eshell-find-delimiter delim delim nil nil t) - sep (buffer-substring-no-properties (point) end)) - (goto-char (1+ end))) + (let ((sep (eshell-get-delimited-modifier-argument))) (lambda (lst) (mapcar (lambda (str) diff --git a/lisp/eshell/em-prompt.el b/lisp/eshell/em-prompt.el index 3901265e9d4..a1a91e7d634 100644 --- a/lisp/eshell/em-prompt.el +++ b/lisp/eshell/em-prompt.el @@ -96,11 +96,9 @@ arriving, or after." :options '(eshell-show-maximum-output) :group 'eshell-prompt) -(defvar eshell-prompt-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-c C-n") #'eshell-next-prompt) - (define-key map (kbd "C-c C-p") #'eshell-previous-prompt) - map)) +(defvar-keymap eshell-prompt-mode-map + "C-c C-n" #'eshell-next-prompt + "C-c C-p" #'eshell-previous-prompt) ;;; Functions: diff --git a/lisp/eshell/em-rebind.el b/lisp/eshell/em-rebind.el index 1919c87d4da..2b56c9e8444 100644 --- a/lisp/eshell/em-rebind.el +++ b/lisp/eshell/em-rebind.el @@ -136,10 +136,8 @@ This is default behavior of shells like bash." :type '(repeat function) :group 'eshell-rebind) -(defvar eshell-rebind-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-c M-l") #'eshell-lock-local-map) - map)) +(defvar-keymap eshell-rebind-mode-map + "C-c M-l" #'eshell-lock-local-map) ;; Internal Variables: @@ -240,7 +238,7 @@ lock it at that." Sends an EOF only if point is at the end of the buffer and there is no input." (interactive "p") - (let ((proc (eshell-interactive-process))) + (let ((proc (eshell-head-process))) (if (eobp) (cond ((/= (point) eshell-last-output-end) diff --git a/lisp/eshell/em-script.el b/lisp/eshell/em-script.el index e8459513f39..e0bcd8b099f 100644 --- a/lisp/eshell/em-script.el +++ b/lisp/eshell/em-script.el @@ -113,27 +113,13 @@ Comments begin with `#'." (defun eshell/source (&rest args) "Source a file in a subshell environment." - (eshell-eval-using-options - "source" args - '((?h "help" nil nil "show this usage screen") - :show-usage - :usage "FILE [ARGS] -Invoke the Eshell commands in FILE in a subshell, binding ARGS to $1, -$2, etc.") - (eshell-source-file (car args) (cdr args) t))) + (eshell-source-file (car args) (cdr args) t)) (put 'eshell/source 'eshell-no-numeric-conversions t) (defun eshell/. (&rest args) "Source a file in the current environment." - (eshell-eval-using-options - "." args - '((?h "help" nil nil "show this usage screen") - :show-usage - :usage "FILE [ARGS] -Invoke the Eshell commands in FILE within the current shell -environment, binding ARGS to $1, $2, etc.") - (eshell-source-file (car args) (cdr args)))) + (eshell-source-file (car args) (cdr args))) (put 'eshell/. 'eshell-no-numeric-conversions t) diff --git a/lisp/eshell/em-term.el b/lisp/eshell/em-term.el index e34c5ae47ce..d150c07b030 100644 --- a/lisp/eshell/em-term.el +++ b/lisp/eshell/em-term.el @@ -224,7 +224,7 @@ the buffer." ; (defun eshell-term-send-raw-string (chars) ; (goto-char eshell-last-output-end) -; (process-send-string (eshell-interactive-process) chars)) +; (process-send-string (eshell-head-process) chars)) ; (defun eshell-term-send-raw () ; "Send the last character typed through the terminal-emulator diff --git a/lisp/eshell/em-tramp.el b/lisp/eshell/em-tramp.el index e9018bdb934..aebbc36e71d 100644 --- a/lisp/eshell/em-tramp.el +++ b/lisp/eshell/em-tramp.el @@ -61,37 +61,33 @@ "Alias \"su\" to call TRAMP. Uses the system su through TRAMP's su method." - (setq args (eshell-stringify-list (flatten-tree args))) - (let ((orig-args (copy-tree args))) - (eshell-eval-using-options - "su" args - '((?h "help" nil nil "show this usage screen") - (?l "login" nil login "provide a login environment") - (? nil nil login "provide a login environment") - :usage "[- | -l | --login] [USER] + (eshell-eval-using-options + "su" args + '((?h "help" nil nil "show this usage screen") + (?l "login" nil login "provide a login environment") + (? nil nil login "provide a login environment") + :usage "[- | -l | --login] [USER] Become another USER during a login session.") - (throw 'eshell-replace-command - (let ((user "root") - (host (or (file-remote-p default-directory 'host) - "localhost")) - (dir (file-local-name (expand-file-name default-directory))) - (prefix (file-remote-p default-directory))) - (dolist (arg args) - (if (string-equal arg "-") (setq login t) (setq user arg))) - ;; `eshell-eval-using-options' does not handle "-". - (if (member "-" orig-args) (setq login t)) - (if login (setq dir "~/")) - (if (and prefix - (or - (not (string-equal - "su" (file-remote-p default-directory 'method))) - (not (string-equal - user (file-remote-p default-directory 'user))))) - (eshell-parse-command - "cd" (list (format "%s|su:%s@%s:%s" - (substring prefix 0 -1) user host dir))) - (eshell-parse-command - "cd" (list (format "/su:%s@%s:%s" user host dir))))))))) + (throw 'eshell-replace-command + (let ((user "root") + (host (or (file-remote-p default-directory 'host) + tramp-default-host)) + (dir (file-local-name (expand-file-name default-directory))) + (prefix (file-remote-p default-directory))) + (dolist (arg args) + (if (string-equal arg "-") (setq login t) (setq user arg))) + (when login (setq dir "~/")) + (if (and prefix + (or + (not (string-equal + "su" (file-remote-p default-directory 'method))) + (not (string-equal + user (file-remote-p default-directory 'user))))) + (eshell-parse-command + "cd" (list (format "%s|su:%s@%s:%s" + (substring prefix 0 -1) user host dir))) + (eshell-parse-command + "cd" (list (format "/su:%s@%s:%s" user host dir)))))))) (put 'eshell/su 'eshell-no-numeric-conversions t) @@ -99,41 +95,35 @@ Become another USER during a login session.") "Alias \"sudo\" to call Tramp. Uses the system sudo through TRAMP's sudo method." - (setq args (eshell-stringify-list (flatten-tree args))) - (let ((orig-args (copy-tree args))) - (eshell-eval-using-options - "sudo" args - '((?h "help" nil nil "show this usage screen") - (?u "user" t user "execute a command as another USER") - :show-usage - :parse-leading-options-only - :usage "[(-u | --user) USER] COMMAND + (eshell-eval-using-options + "sudo" args + '((?h "help" nil nil "show this usage screen") + (?u "user" t user "execute a command as another USER") + :show-usage + :parse-leading-options-only + :usage "[(-u | --user) USER] COMMAND Execute a COMMAND as the superuser or another USER.") - (throw 'eshell-external - (let ((user (or user "root")) - (host (or (file-remote-p default-directory 'host) - "localhost")) - (dir (file-local-name (expand-file-name default-directory))) - (prefix (file-remote-p default-directory))) - ;; `eshell-eval-using-options' reads options of COMMAND. - (while (and (stringp (car orig-args)) - (member (car orig-args) '("-u" "--user"))) - (setq orig-args (cddr orig-args))) - (let ((default-directory - (if (and prefix - (or - (not - (string-equal - "sudo" - (file-remote-p default-directory 'method))) - (not - (string-equal - user - (file-remote-p default-directory 'user))))) - (format "%s|sudo:%s@%s:%s" - (substring prefix 0 -1) user host dir) - (format "/sudo:%s@%s:%s" user host dir)))) - (eshell-named-command (car orig-args) (cdr orig-args)))))))) + (throw 'eshell-external + (let* ((user (or user "root")) + (host (or (file-remote-p default-directory 'host) + tramp-default-host)) + (dir (file-local-name (expand-file-name default-directory))) + (prefix (file-remote-p default-directory)) + (default-directory + (if (and prefix + (or + (not + (string-equal + "sudo" + (file-remote-p default-directory 'method))) + (not + (string-equal + user + (file-remote-p default-directory 'user))))) + (format "%s|sudo:%s@%s:%s" + (substring prefix 0 -1) user host dir) + (format "/sudo:%s@%s:%s" user host dir)))) + (eshell-named-command (car args) (cdr args)))))) (put 'eshell/sudo 'eshell-no-numeric-conversions t) diff --git a/lisp/eshell/esh-arg.el b/lisp/eshell/esh-arg.el index 127a46abc39..459487f4358 100644 --- a/lisp/eshell/esh-arg.el +++ b/lisp/eshell/esh-arg.el @@ -152,10 +152,8 @@ treated as a literal character." :type 'hook :group 'eshell-arg) -(defvar eshell-arg-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-c M-b") #'eshell-insert-buffer-name) - map)) +(defvar-keymap eshell-arg-mode-map + "C-c M-b" #'eshell-insert-buffer-name) ;;; Functions: @@ -182,19 +180,63 @@ treated as a literal character." (add-text-properties 0 (length string) '(escaped t) string)) string) +(defun eshell-concat (quoted &rest rest) + "Concatenate all the arguments in REST and return the result. +If QUOTED is nil, the resulting value(s) may be converted to +numbers (see `eshell-concat-1'). + +If each argument in REST is a non-list value, the result will be +a single value, as if (mapconcat #'eshell-stringify REST) had been +called, possibly converted to a number. + +If there is at least one (non-nil) list argument, the result will +be a list, with \"adjacent\" elements of consecutive arguments +concatenated as strings (again, possibly converted to numbers). +For example, concatenating \"a\", (\"b\"), and (\"c\" \"d\") +would produce (\"abc\" \"d\")." + (let (result) + (dolist (i rest result) + (when i + (cond + ((null result) + (setq result i)) + ((listp result) + (let (curr-head curr-tail) + (if (listp i) + (setq curr-head (car i) + curr-tail (cdr i)) + (setq curr-head i + curr-tail nil)) + (setq result + (append + (butlast result 1) + (list (eshell-concat-1 quoted (car (last result)) + curr-head)) + curr-tail)))) + ((listp i) + (setq result + (cons (eshell-concat-1 quoted result (car i)) + (cdr i)))) + (t + (setq result (eshell-concat-1 quoted result i)))))))) + +(defun eshell-concat-1 (quoted first second) + "Concatenate FIRST and SECOND. +If QUOTED is nil and either FIRST or SECOND are numbers, try to +convert the result to a number as well." + (let ((result (concat (eshell-stringify first) (eshell-stringify second)))) + (if (and (not quoted) + (or (numberp first) (numberp second))) + (eshell-convert-to-number result) + result))) + (defun eshell-resolve-current-argument () "If there are pending modifications to be made, make them now." (when eshell-current-argument (when eshell-arg-listified - (let ((parts eshell-current-argument)) - (while parts - (unless (stringp (car parts)) - (setcar parts - (list 'eshell-to-flat-string (car parts)))) - (setq parts (cdr parts))) - (setq eshell-current-argument - (list 'eshell-convert - (append (list 'concat) eshell-current-argument)))) + (setq eshell-current-argument + (append (list 'eshell-concat eshell-current-quoted) + eshell-current-argument)) (setq eshell-arg-listified nil)) (while eshell-current-modifiers (setq eshell-current-argument @@ -356,6 +398,30 @@ after are both returned." (list 'eshell-escape-arg arg)))) (goto-char (1+ end))))))) +(defun eshell-unescape-inner-double-quote (bound) + "Unescape escaped characters inside a double-quoted string. +The string to parse starts at point and ends at BOUND. + +If Eshell is currently parsing a quoted string and there are any +backslash-escaped characters, this will return the unescaped +string, updating point to BOUND. Otherwise, this returns nil and +leaves point where it was." + (when eshell-current-quoted + (let (strings + (start (point)) + (special-char + (rx-to-string + `(seq "\\" (group (any ,@eshell-special-chars-inside-quoting)))))) + (while (re-search-forward special-char bound t) + (push (concat (buffer-substring start (match-beginning 0)) + (match-string 1)) + strings) + (setq start (match-end 0))) + (when strings + (push (buffer-substring start bound) strings) + (goto-char bound) + (apply #'concat (nreverse strings)))))) + (defun eshell-parse-special-reference () "Parse a special syntax reference, of the form `#<args>'. @@ -379,7 +445,9 @@ If the form has no `type', the syntax is parsed as if `type' were (if (eshell-arg-delimiter (1+ end)) (prog1 (list (if buffer-p 'get-buffer-create 'get-process) - (buffer-substring-no-properties (point) end)) + (replace-regexp-in-string + (rx "\\" (group (or "\\" "<" ">"))) "\\1" + (buffer-substring-no-properties (point) end))) (goto-char (1+ end))) (ignore (goto-char here))))))) diff --git a/lisp/eshell/esh-cmd.el b/lisp/eshell/esh-cmd.el index 554e3a5c1d9..775e4c1057e 100644 --- a/lisp/eshell/esh-cmd.el +++ b/lisp/eshell/esh-cmd.el @@ -107,6 +107,7 @@ (require 'esh-module) (require 'esh-io) (require 'esh-ext) +(require 'generator) (eval-when-compile (require 'cl-lib) @@ -255,12 +256,12 @@ the command." (defcustom eshell-subcommand-bindings '((eshell-in-subcommand-p t) + (eshell-in-pipeline-p nil) (default-directory default-directory) (process-environment (eshell-copy-environment))) "A list of `let' bindings for subcommand environments." - :type 'sexp) - -(put 'risky-local-variable 'eshell-subcommand-bindings t) + :type 'sexp + :risky t) (defvar eshell-ensure-newline-p nil "If non-nil, ensure that a newline is emitted after a Lisp form. @@ -279,14 +280,33 @@ otherwise t.") (defvar eshell-in-subcommand-p nil) (defvar eshell-last-arguments nil) (defvar eshell-last-command-name nil) -(defvar eshell-last-async-proc nil - "When this foreground process completes, resume command evaluation.") +(defvar eshell-last-async-procs nil + "The currently-running foreground process(es). +When executing a pipeline, this is a cons cell whose CAR is the +first process (usually reading from stdin) and whose CDR is the +last process (usually writing to stdout). Otherwise, the CAR and +CDR are the same process. + +When the process in the CDR completes, resume command evaluation.") ;;; Functions: -(defsubst eshell-interactive-process () - "Return currently running command process, if non-Lisp." - eshell-last-async-proc) +(defsubst eshell-interactive-process-p () + "Return non-nil if there is a currently running command process." + eshell-last-async-procs) + +(defsubst eshell-head-process () + "Return the currently running process at the head of any pipeline. +This only returns external (non-Lisp) processes." + (car-safe eshell-last-async-procs)) + +(defsubst eshell-tail-process () + "Return the currently running process at the tail of any pipeline. +This only returns external (non-Lisp) processes." + (cdr-safe eshell-last-async-procs)) + +(define-obsolete-function-alias 'eshell-interactive-process + 'eshell-tail-process "29.1") (defun eshell-cmd-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the Eshell command processing module." @@ -295,7 +315,7 @@ otherwise t.") (setq-local eshell-command-arguments nil) (setq-local eshell-last-arguments nil) (setq-local eshell-last-command-name nil) - (setq-local eshell-last-async-proc nil) + (setq-local eshell-last-async-procs nil) (add-hook 'eshell-kill-hook #'eshell-resume-command nil t) @@ -306,7 +326,7 @@ otherwise t.") (add-hook 'eshell-post-command-hook (lambda () (setq eshell-current-command nil - eshell-last-async-proc nil)) + eshell-last-async-procs nil)) nil t) (add-hook 'eshell-parse-argument-hook @@ -331,6 +351,39 @@ otherwise t.") (defvar eshell--sep-terms) +(defmacro eshell-with-temp-command (region &rest body) + "Narrow the buffer to REGION and execute the forms in BODY. + +REGION is a cons cell (START . END) that specifies the region to +which to narrow the buffer. REGION can also be a string, in +which case the macro temporarily inserts it into the buffer at +point, and narrows the buffer to the inserted string. Before +executing BODY, point is set to the beginning of the narrowed +REGION. + +The value returned is the last form in BODY." + (declare (indent 1)) + `(let ((reg ,region)) + (if (stringp reg) + ;; Since parsing relies partly on buffer-local state + ;; (e.g. that of `eshell-parse-argument-hook'), we need to + ;; perform the parsing in the Eshell buffer. + (let ((begin (point)) end + (inhibit-point-motion-hooks t)) + (with-silent-modifications + (insert reg) + (setq end (point)) + (unwind-protect + (save-restriction + (narrow-to-region begin end) + (goto-char begin) + ,@body) + (delete-region begin end)))) + (save-restriction + (narrow-to-region (car reg) (cdr reg)) + (goto-char (car reg)) + ,@body)))) + (defun eshell-parse-command (command &optional args toplevel) "Parse the COMMAND, adding ARGS if given. COMMAND can either be a string, or a cons cell demarcating a buffer @@ -342,15 +395,9 @@ hooks should be run before and after the command." (append (if (consp command) (eshell-parse-arguments (car command) (cdr command)) - (let ((here (point)) - (inhibit-point-motion-hooks t)) - (with-silent-modifications - ;; FIXME: Why not use a temporary buffer and avoid this - ;; "insert&delete" business? --Stef - (insert command) - (prog1 - (eshell-parse-arguments here (point)) - (delete-region here (point)))))) + (eshell-with-temp-command command + (goto-char (point-max)) + (eshell-parse-arguments (point-min) (point-max)))) args)) (commands (mapcar @@ -764,8 +811,7 @@ This macro calls itself recursively, with NOTFIRST non-nil." (eshell-set-output-handle ,eshell-output-handle 'append nextproc) (eshell-set-output-handle ,eshell-error-handle - 'append nextproc) - (setq tailproc (or tailproc nextproc)))) + 'append nextproc))) ,(let ((head (car pipeline))) (if (memq (car head) '(let progn)) (setq head (car (last head)))) @@ -781,7 +827,10 @@ This macro calls itself recursively, with NOTFIRST non-nil." ,(cond ((not notfirst) (quote 'first)) ((cdr pipeline) t) (t (quote 'last))))) - ,(car pipeline)))))) + (let ((proc ,(car pipeline))) + (set headproc (or proc (symbol-value headproc))) + (set tailproc (or (symbol-value tailproc) proc)) + proc)))))) (defmacro eshell-do-pipelines-synchronously (pipeline) "Execute the commands in PIPELINE in sequence synchronously. @@ -813,7 +862,7 @@ This is used on systems where async subprocesses are not supported." (let ((result ,(car pipeline))) ;; tailproc gets the result of the last successful process in ;; the pipeline. - (setq tailproc (or result tailproc)) + (set tailproc (or result (symbol-value tailproc))) ,(if (cdr pipeline) `(eshell-do-pipelines-synchronously (quote ,(cdr pipeline)))) result)))) @@ -822,7 +871,11 @@ This is used on systems where async subprocesses are not supported." (defmacro eshell-execute-pipeline (pipeline) "Execute the commands in PIPELINE, connecting each to one another." - `(let ((eshell-in-pipeline-p t) tailproc) + `(let ((eshell-in-pipeline-p t) + (headproc (make-symbol "headproc")) + (tailproc (make-symbol "tailproc"))) + (set headproc nil) + (set tailproc nil) (progn ,(if (fboundp 'make-process) `(eshell-do-pipelines ,pipeline) @@ -832,7 +885,8 @@ This is used on systems where async subprocesses are not supported." (car (aref eshell-current-handles ,eshell-error-handle)) nil))) (eshell-do-pipelines-synchronously ,pipeline))) - (eshell-process-identity tailproc)))) + (eshell-process-identity (cons (symbol-value headproc) + (symbol-value tailproc)))))) (defmacro eshell-as-subcommand (command) "Execute COMMAND using a temp buffer. @@ -854,7 +908,8 @@ This avoids the need to use `let*'." (defmacro eshell-command-to-value (object) "Run OBJECT synchronously, returning its result as a string. Returns a string comprising the output from the command." - `(let ((value (make-symbol "eshell-temp"))) + `(let ((value (make-symbol "eshell-temp")) + (eshell-in-pipeline-p nil)) (eshell-do-command-to-value ,object))) ;;;_* Iterative evaluation @@ -904,21 +959,63 @@ at the moment are: "Completion for the `debug' command." (while (pcomplete-here '("errors" "commands")))) +(iter-defun eshell--find-subcommands (haystack) + "Recursively search for subcommand forms in HAYSTACK. +This yields the SUBCOMMANDs when found in forms like +\"(eshell-as-subcommand SUBCOMMAND)\"." + (dolist (elem haystack) + (cond + ((eq (car-safe elem) 'eshell-as-subcommand) + (iter-yield (cdr elem))) + ((listp elem) + (iter-yield-from (eshell--find-subcommands elem)))))) + +(defun eshell--invoke-command-directly (command) + "Determine whether the given COMMAND can be invoked directly. +COMMAND should be a non-top-level Eshell command in parsed form. + +A command can be invoked directly if all of the following are true: + +* The command is of the form + \"(eshell-trap-errors (eshell-named-command NAME ARGS))\", + where ARGS is optional. + +* NAME is a string referring to an alias function and isn't a + complex command (see `eshell-complex-commands'). + +* Any subcommands in ARGS can also be invoked directly." + (when (and (eq (car command) 'eshell-trap-errors) + (eq (car (cadr command)) 'eshell-named-command)) + (let ((name (cadr (cadr command))) + (args (cdr-safe (nth 2 (cadr command))))) + (and name (stringp name) + (not (member name eshell-complex-commands)) + (catch 'simple + (dolist (pred eshell-complex-commands t) + (when (and (functionp pred) + (funcall pred name)) + (throw 'simple nil)))) + (eshell-find-alias-function name) + (catch 'indirect-subcommand + (iter-do (subcommand (eshell--find-subcommands args)) + (unless (eshell--invoke-command-directly subcommand) + (throw 'indirect-subcommand nil))) + t))))) + (defun eshell-invoke-directly (command) - (let ((base (cadr (nth 2 (nth 2 (cadr command))))) name) - (if (and (eq (car base) 'eshell-trap-errors) - (eq (car (cadr base)) 'eshell-named-command)) - (setq name (cadr (cadr base)))) - (and name (stringp name) - (not (member name eshell-complex-commands)) - (catch 'simple - (progn - (dolist (pred eshell-complex-commands) - (if (and (functionp pred) - (funcall pred name)) - (throw 'simple nil))) - t)) - (eshell-find-alias-function name)))) + "Determine whether the given COMMAND can be invoked directly. +COMMAND should be a top-level Eshell command in parsed form, as +produced by `eshell-parse-command'." + (let ((base (cadr (nth 2 (nth 2 (cadr command)))))) + (eshell--invoke-command-directly base))) + +(defun eshell-eval-argument (argument) + "Evaluate a single Eshell ARGUMENT and return the result." + (let* ((form (eshell-with-temp-command argument + (eshell-parse-argument))) + (result (eshell-do-eval form t))) + (cl-assert (eq (car result) 'quote)) + (cadr result))) (defun eshell-eval-command (command &optional input) "Evaluate the given COMMAND iteratively." @@ -958,24 +1055,24 @@ at the moment are: (unless (or (not (stringp status)) (string= "stopped" status) (string-match eshell-reset-signals status)) - (if (eq proc (eshell-interactive-process)) + (if (eq proc (eshell-tail-process)) (eshell-resume-eval))))) (defun eshell-resume-eval () "Destructively evaluate a form which may need to be deferred." (eshell-condition-case err (progn - (setq eshell-last-async-proc nil) + (setq eshell-last-async-procs nil) (when eshell-current-command (let* (retval - (proc (catch 'eshell-defer + (procs (catch 'eshell-defer (ignore (setq retval (eshell-do-eval eshell-current-command)))))) - (if (eshell-processp proc) - (ignore (setq eshell-last-async-proc proc)) - (cadr retval))))) + (if (eshell-process-pair-p procs) + (ignore (setq eshell-last-async-procs procs)) + (cadr retval))))) (error (error (error-message-string err))))) @@ -1138,17 +1235,16 @@ be finished later after the completion of an asynchronous subprocess." (setcar form (car new-form)) (setcdr form (cdr new-form))) (eshell-do-eval form synchronous-p)) - (if (and (memq (car form) eshell-deferrable-commands) - (not eshell-current-subjob-p) - result - (eshell-processp result)) - (if synchronous-p - (eshell/wait result) + (if-let (((memq (car form) eshell-deferrable-commands)) + ((not eshell-current-subjob-p)) + (procs (eshell-make-process-pair result))) + (if synchronous-p + (eshell/wait (cdr procs)) (eshell-manipulate "inserting ignore form" (setcar form 'ignore) (setcdr form nil)) - (throw 'eshell-defer result)) - (list 'quote result)))))))))))) + (throw 'eshell-defer procs)) + (list 'quote result)))))))))))) ;; command invocation @@ -1238,8 +1334,9 @@ or an external command." (defun eshell-exec-lisp (printer errprint func-or-form args form-p) "Execute a Lisp FUNC-OR-FORM, maybe passing ARGS. PRINTER and ERRPRINT are functions to use for printing regular -messages, and errors. FORM-P should be non-nil if FUNC-OR-FORM -represent a Lisp form; ARGS will be ignored in that case." +messages and errors, respectively. FORM-P should be non-nil if +FUNC-OR-FORM represent a Lisp form; ARGS will be ignored in that +case." (eshell-condition-case err (let ((result (save-current-buffer @@ -1262,44 +1359,56 @@ represent a Lisp form; ARGS will be ignored in that case." (defsubst eshell-apply* (printer errprint func args) "Call FUNC, with ARGS, trapping errors and return them as output. PRINTER and ERRPRINT are functions to use for printing regular -messages, and errors." +messages and errors, respectively." (eshell-exec-lisp printer errprint func args nil)) (defsubst eshell-funcall* (printer errprint func &rest args) - "Call FUNC, with ARGS, trapping errors and return them as output." + "Call FUNC, with ARGS, trapping errors and return them as output. +PRINTER and ERRPRINT are functions to use for printing regular +messages and errors, respectively." (eshell-apply* printer errprint func args)) (defsubst eshell-eval* (printer errprint form) - "Evaluate FORM, trapping errors and returning them." + "Evaluate FORM, trapping errors and returning them. +PRINTER and ERRPRINT are functions to use for printing regular +messages and errors, respectively." (eshell-exec-lisp printer errprint form nil t)) (defsubst eshell-apply (func args) "Call FUNC, with ARGS, trapping errors and return them as output. -PRINTER and ERRPRINT are functions to use for printing regular -messages, and errors." - (eshell-apply* 'eshell-print 'eshell-error func args)) +Print the result using `eshell-print'; if an error occurs, print +it via `eshell-error'." + (eshell-apply* #'eshell-print #'eshell-error func args)) (defsubst eshell-funcall (func &rest args) - "Call FUNC, with ARGS, trapping errors and return them as output." + "Call FUNC, with ARGS, trapping errors and return them as output. +Print the result using `eshell-print'; if an error occurs, print +it via `eshell-error'." (eshell-apply func args)) (defsubst eshell-eval (form) - "Evaluate FORM, trapping errors and returning them." - (eshell-eval* 'eshell-print 'eshell-error form)) + "Evaluate FORM, trapping errors and returning them. +Print the result using `eshell-print'; if an error occurs, print +it via `eshell-error'." + (eshell-eval* #'eshell-print #'eshell-error form)) (defsubst eshell-applyn (func args) "Call FUNC, with ARGS, trapping errors and return them as output. -PRINTER and ERRPRINT are functions to use for printing regular -messages, and errors." - (eshell-apply* 'eshell-printn 'eshell-errorn func args)) +Print the result using `eshell-printn'; if an error occurs, print it +via `eshell-errorn'." + (eshell-apply* #'eshell-printn #'eshell-errorn func args)) (defsubst eshell-funcalln (func &rest args) - "Call FUNC, with ARGS, trapping errors and return them as output." + "Call FUNC, with ARGS, trapping errors and return them as output. +Print the result using `eshell-printn'; if an error occurs, print it +via `eshell-errorn'." (eshell-applyn func args)) (defsubst eshell-evaln (form) - "Evaluate FORM, trapping errors and returning them." - (eshell-eval* 'eshell-printn 'eshell-errorn form)) + "Evaluate FORM, trapping errors and returning them. +Print the result using `eshell-printn'; if an error occurs, print it +via `eshell-errorn'." + (eshell-eval* #'eshell-printn #'eshell-errorn form)) (defvar eshell-last-output-end) ;Defined in esh-mode.el. diff --git a/lisp/eshell/esh-io.el b/lisp/eshell/esh-io.el index 5179947da76..3644c1a18b5 100644 --- a/lisp/eshell/esh-io.el +++ b/lisp/eshell/esh-io.el @@ -147,9 +147,10 @@ not be added to this variable." function (choice (const :tag "Func returns output-func" t) (const :tag "Func is output-func" nil)))) + :risky t :group 'eshell-io) -(put 'eshell-virtual-targets 'risky-local-variable t) +(define-error 'eshell-pipe-broken "Pipe broken") ;;; Internal Variables: @@ -376,8 +377,6 @@ it defaults to `insert'." (error "Invalid redirection target: %s" (eshell-stringify target))))) -(defvar grep-null-device) - (defun eshell-set-output-handle (index mode &optional target) "Set handle INDEX, using MODE, to point to TARGET." (when target @@ -484,24 +483,31 @@ Returns what was actually sent, or nil if nothing was sent." (goto-char target)))))) ((eshell-processp target) - (when (eq (process-status target) 'run) - (unless (stringp object) - (setq object (eshell-stringify object))) - (process-send-string target object))) + (unless (stringp object) + (setq object (eshell-stringify object))) + (condition-case nil + (process-send-string target object) + ;; If `process-send-string' raises an error, treat it as a broken pipe. + (error (signal 'eshell-pipe-broken target)))) ((consp target) (apply (car target) object (cdr target)))) object) (defun eshell-output-object (object &optional handle-index handles) - "Insert OBJECT, using HANDLE-INDEX specifically)." + "Insert OBJECT, using HANDLE-INDEX specifically. +If HANDLE-INDEX is nil, output to `eshell-output-handle'. +HANDLES is the set of file handles to use; if nil, use +`eshell-current-handles'." (let ((target (car (aref (or handles eshell-current-handles) (or handle-index eshell-output-handle))))) - (if (and target (not (listp target))) - (eshell-output-object-to-target object target) - (while target - (eshell-output-object-to-target object (car target)) - (setq target (cdr target)))))) + (if (listp target) + (while target + (eshell-output-object-to-target object (car target)) + (setq target (cdr target))) + (eshell-output-object-to-target object target) + ;; Explicitly return nil to match the list case above. + nil))) (provide 'esh-io) ;;; esh-io.el ends here diff --git a/lisp/eshell/esh-mode.el b/lisp/eshell/esh-mode.el index a3d9d582e58..59c8f8034fe 100644 --- a/lisp/eshell/esh-mode.el +++ b/lisp/eshell/esh-mode.el @@ -260,31 +260,28 @@ This is used by `eshell-watch-for-password-prompt'." (standard-syntax-table)) st)) -(defvar eshell-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [(control ?c)] 'eshell-command-map) - (define-key map "\r" #'eshell-send-input) - (define-key map "\M-\r" #'eshell-queue-input) - (define-key map [(meta control ?l)] #'eshell-show-output) - (define-key map [(control ?a)] #'eshell-bol) - map)) - -(defvar eshell-command-map - (let ((map (define-prefix-command 'eshell-command-map))) - (define-key map [(meta ?o)] #'eshell-mark-output) - (define-key map [(meta ?d)] #'eshell-toggle-direct-send) - (define-key map [(control ?a)] #'eshell-bol) - (define-key map [(control ?b)] #'eshell-backward-argument) - (define-key map [(control ?e)] #'eshell-show-maximum-output) - (define-key map [(control ?f)] #'eshell-forward-argument) - (define-key map [(control ?m)] #'eshell-copy-old-input) - (define-key map [(control ?o)] #'eshell-kill-output) - (define-key map [(control ?r)] #'eshell-show-output) - (define-key map [(control ?t)] #'eshell-truncate-buffer) - (define-key map [(control ?u)] #'eshell-kill-input) - (define-key map [(control ?w)] #'backward-kill-word) - (define-key map [(control ?y)] #'eshell-repeat-argument) - map)) +(defvar-keymap eshell-mode-map + "C-c" 'eshell-command-map + "RET" #'eshell-send-input + "M-RET" #'eshell-queue-input + "C-M-l" #'eshell-show-output + "C-a" #'eshell-bol) + +(defvar-keymap eshell-command-map + :prefix 'eshell-command-map + "M-o" #'eshell-mark-output + "M-d" #'eshell-toggle-direct-send + "C-a" #'eshell-bol + "C-b" #'eshell-backward-argument + "C-e" #'eshell-show-maximum-output + "C-f" #'eshell-forward-argument + "C-m" #'eshell-copy-old-input + "C-o" #'eshell-kill-output + "C-r" #'eshell-show-output + "C-t" #'eshell-truncate-buffer + "C-u" #'eshell-kill-input + "C-w" #'backward-kill-word + "C-y" #'eshell-repeat-argument) ;;; User Functions: @@ -308,7 +305,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)))) @@ -426,13 +423,13 @@ and the hook `eshell-exit-hook'." (defun eshell-self-insert-command () (interactive) (process-send-string - (eshell-interactive-process) + (eshell-head-process) (char-to-string (if (symbolp last-command-event) (get last-command-event 'ascii-character) last-command-event)))) (defun eshell-intercept-commands () - (when (and (eshell-interactive-process) + (when (and (eshell-interactive-process-p) (not (and (integerp last-input-event) (memq last-input-event '(?\C-x ?\C-c))))) (let ((possible-events (where-is-internal this-command)) @@ -598,13 +595,13 @@ If NO-NEWLINE is non-nil, the input is sent without an implied final newline." (interactive "P") ;; Note that the input string does not include its terminal newline. - (let ((proc-running-p (and (eshell-interactive-process) + (let ((proc-running-p (and (eshell-head-process) (not queue-p))) (inhibit-point-motion-hooks t) (inhibit-modification-hooks t)) (unless (and proc-running-p (not (eq (process-status - (eshell-interactive-process)) + (eshell-head-process)) 'run))) (if (or proc-running-p (>= (point) eshell-last-output-end)) @@ -616,14 +613,22 @@ 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) (if (or eshell-send-direct-to-subprocesses (= eshell-last-input-start eshell-last-input-end)) (unless no-newline - (process-send-string (eshell-interactive-process) "\n")) - (process-send-region (eshell-interactive-process) + (process-send-string (eshell-head-process) "\n")) + (process-send-region (eshell-head-process) eshell-last-input-start eshell-last-input-end))) (if (= eshell-last-output-end (point)) @@ -660,6 +665,16 @@ newline." (run-hooks 'eshell-post-command-hook) (insert-and-inherit input))))))))) +(defun eshell-send-eof-to-process () + "Send EOF to the currently-running \"head\" process." + (interactive) + (require 'esh-mode) + (declare-function eshell-send-input "esh-mode" + (&optional use-region queue-p no-newline)) + (eshell-send-input nil nil t) + (when (eshell-head-process) + (process-send-eof (eshell-head-process)))) + (defsubst eshell-kill-new () "Add the last input text to the kill ring." (kill-ring-save eshell-last-input-start eshell-last-input-end)) @@ -919,9 +934,9 @@ Then send it to the process running in the current buffer." (interactive) ; Don't pass str as argument, to avoid snooping via C-x ESC ESC (let ((str (read-passwd (format "%s Password: " - (process-name (eshell-interactive-process)))))) + (process-name (eshell-head-process)))))) (if (stringp str) - (process-send-string (eshell-interactive-process) + (process-send-string (eshell-head-process) (concat str "\n")) (message "Warning: text will be echoed")))) @@ -932,14 +947,21 @@ buffer's process if STRING contains a password prompt defined by `eshell-password-prompt-regexp'. This function could be in the list `eshell-output-filter-functions'." - (when (eshell-interactive-process) + (when (eshell-interactive-process-p) (save-excursion (let ((case-fold-search t)) (goto-char eshell-last-output-block-begin) (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-module.el b/lisp/eshell/esh-module.el index ade151d7cd5..14e91912d11 100644 --- a/lisp/eshell/esh-module.el +++ b/lisp/eshell/esh-module.el @@ -54,6 +54,7 @@ customizing the variable `eshell-modules-list'." eshell-basic eshell-cmpl eshell-dirs + eshell-extpipe eshell-glob eshell-hist eshell-ls diff --git a/lisp/eshell/esh-opt.el b/lisp/eshell/esh-opt.el index d96b77ddd37..f52b70fe7a6 100644 --- a/lisp/eshell/esh-opt.el +++ b/lisp/eshell/esh-opt.el @@ -97,10 +97,10 @@ let-bound variable `args'." (declare (debug (form form sexp body))) `(let* ((temp-args ,(if (memq ':preserve-args (cadr options)) - macro-args + (list 'copy-tree macro-args) (list 'eshell-stringify-list (list 'flatten-tree macro-args)))) - (processed-args (eshell--do-opts ,name ,options temp-args)) + (processed-args (eshell--do-opts ,name ,options temp-args ,macro-args)) ,@(delete-dups (delq nil (mapcar (lambda (opt) (and (listp opt) (nth 3 opt) @@ -117,7 +117,7 @@ let-bound variable `args'." ;; Documented part of the interface; see eshell-eval-using-options. (defvar eshell--args) -(defun eshell--do-opts (name options args) +(defun eshell--do-opts (name options args orig-args) "Helper function for `eshell-eval-using-options'. This code doesn't really need to be macro expanded everywhere." (require 'esh-ext) @@ -135,7 +135,7 @@ This code doesn't really need to be macro expanded everywhere." (error "%s" usage-msg)))))) (if ext-command (throw 'eshell-external - (eshell-external-command ext-command args)) + (eshell-external-command ext-command orig-args)) args))) (defun eshell-show-usage (name options) @@ -187,49 +187,82 @@ passed to this command, the external version `%s' will be called instead." extcmd))))) (throw 'eshell-usage usage))) -(defun eshell--set-option (name ai opt options opt-vals) +(defun eshell--split-switch (switch kind) + "Split SWITCH into its option name and potential value, if any. +KIND should be the integer 0 if SWITCH is a short option, or 1 if it's +a long option." + (if (eq kind 0) + ;; Short option + (cons (aref switch 0) + (and (> (length switch) 1) (substring switch 1))) + ;; Long option + (save-match-data + (string-match "\\([^=]*\\)\\(?:=\\(.*\\)\\)?" switch) + (cons (match-string 1 switch) (match-string 2 switch))))) + +(defun eshell--set-option (name ai opt value options opt-vals) "Using NAME's remaining args (index AI), set the OPT within OPTIONS. -If the option consumes an argument for its value, the argument list -will be modified." +VALUE is the potential value of the OPT, coming from args like +\"-fVALUE\" or \"--foo=VALUE\", or nil if no value was supplied. If +OPT doesn't consume a value, return VALUE unchanged so that it can be +processed later; otherwise, return nil. + +If the OPT consumes an argument for its value and VALUE is nil, the +argument list will be modified." (if (not (nth 3 opt)) (eshell-show-usage name options) - (setcdr (assq (nth 3 opt) opt-vals) - (if (eq (nth 2 opt) t) - (if (> ai (length eshell--args)) - (error "%s: missing option argument" name) - (pop (nthcdr ai eshell--args))) - (or (nth 2 opt) t))))) + (if (eq (nth 2 opt) t) + (progn + (setcdr (assq (nth 3 opt) opt-vals) + (or value + (if (> ai (length eshell--args)) + (error "%s: missing option argument" name) + (pop (nthcdr ai eshell--args))))) + nil) + (setcdr (assq (nth 3 opt) opt-vals) + (or (nth 2 opt) t)) + value))) (defun eshell--process-option (name switch kind ai options opt-vals) "For NAME, process SWITCH (of type KIND), from args at index AI. The SWITCH will be looked up in the set of OPTIONS. -SWITCH should be either a string or character. KIND should be the -integer 0 if it's a character, or 1 if it's a string. - -The SWITCH is then be matched against OPTIONS. If no matching handler -is found, and an :external command is defined (and available), it will -be called; otherwise, an error will be triggered to say that the -switch is unrecognized." - (let* ((opts options) - found) +SWITCH should be a string starting with the option to process, +possibly followed by its value, e.g. \"u\" or \"uUSER\". KIND should +be the integer 0 if it's a short option, or 1 if it's a long option. + +The SWITCH is then be matched against OPTIONS. If KIND is 0 and the +SWITCH matches an option that doesn't take a value, return the +remaining characters in SWITCH to be processed later as further short +options. + +If no matching handler is found, and an :external command is defined +(and available), it will be called; otherwise, an error will be +triggered to say that the switch is unrecognized." + (let ((switch (eshell--split-switch switch kind)) + (opts options) + found remaining) (while opts (if (and (listp (car opts)) - (nth kind (car opts)) - (equal switch (nth kind (car opts)))) + (equal (car switch) (nth kind (car opts)))) (progn - (eshell--set-option name ai (car opts) options opt-vals) + (setq remaining (eshell--set-option name ai (car opts) + (cdr switch) options opt-vals)) + (when (and remaining (eq kind 1)) + (error "%s: option --%s doesn't allow an argument" + name (car switch))) (setq found t opts nil)) (setq opts (cdr opts)))) - (unless found + (if found + remaining (let ((extcmd (memq ':external options))) (when extcmd - (setq extcmd (eshell-search-path (cadr extcmd))) - (if extcmd - (throw 'eshell-ext-command extcmd) - (error (if (characterp switch) "%s: unrecognized option -%c" - "%s: unrecognized option --%s") - name switch))))))) + (setq extcmd (eshell-search-path (cadr extcmd)))) + (if extcmd + (throw 'eshell-ext-command extcmd) + (error (if (characterp (car switch)) "%s: unrecognized option -%c" + "%s: unrecognized option --%s") + name (car switch))))))) (defun eshell--process-args (name args options) "Process the given ARGS using OPTIONS." @@ -250,6 +283,9 @@ switch is unrecognized." (memq :parse-leading-options-only options)))) (setq arg (nth ai eshell--args)) (if (not (and (stringp arg) + ;; A string of length 1 can't be an option; (if + ;; it's "-", that generally means stdin). + (> (length arg) 1) (string-match "^-\\(-\\)?\\(.*\\)" arg))) ;; Positional argument found, skip (setq ai (1+ ai) @@ -262,12 +298,9 @@ switch is unrecognized." (if (> (length switch) 0) (eshell--process-option name switch 1 ai options opt-vals) (setq ai (length eshell--args))) - (let ((len (length switch)) - (index 0)) - (while (< index len) - (eshell--process-option name (aref switch index) - 0 ai options opt-vals) - (setq index (1+ index)))))))) + (while (> (length switch) 0) + (setq switch (eshell--process-option name switch 0 + ai options opt-vals))))))) (nconc (mapcar #'cdr opt-vals) eshell--args))) (provide 'esh-opt) diff --git a/lisp/eshell/esh-proc.el b/lisp/eshell/esh-proc.el index c4103fbafbb..70426ccaf2a 100644 --- a/lisp/eshell/esh-proc.el +++ b/lisp/eshell/esh-proc.el @@ -101,15 +101,16 @@ information, for example." (defvar eshell-process-list nil "A list of the current status of subprocesses.") -(defvar eshell-proc-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-c M-i") #'eshell-insert-process) - (define-key map (kbd "C-c C-c") #'eshell-interrupt-process) - (define-key map (kbd "C-c C-k") #'eshell-kill-process) - (define-key map (kbd "C-c C-d") #'eshell-send-eof-to-process) - (define-key map (kbd "C-c C-s") #'list-processes) - (define-key map (kbd "C-c C-\\") #'eshell-quit-process) - map)) +(declare-function eshell-send-eof-to-process "esh-mode") +(declare-function eshell-tail-process "esh-cmd") + +(defvar-keymap eshell-proc-mode-map + "C-c M-i" #'eshell-insert-process + "C-c C-c" #'eshell-interrupt-process + "C-c C-k" #'eshell-kill-process + "C-c C-d" #'eshell-send-eof-to-process + "C-c C-s" #'list-processes + "C-c C-\\" #'eshell-quit-process) ;;; Functions: @@ -119,7 +120,9 @@ Runs `eshell-reset-after-proc' and `eshell-kill-hook', passing arguments PROC and STATUS to functions on the latter." ;; Was there till 24.1, but it is not optional. (remove-hook 'eshell-kill-hook #'eshell-reset-after-proc) - (eshell-reset-after-proc status) + ;; Only reset the prompt if this process is running interactively. + (when (eq proc (eshell-tail-process)) + (eshell-reset-after-proc status)) (run-hook-with-args 'eshell-kill-hook proc status)) (define-minor-mode eshell-proc-mode @@ -386,8 +389,27 @@ output." (let ((data (nth 3 entry))) (setcar (nthcdr 3 entry) nil) (setcar (nthcdr 4 entry) t) - (eshell-output-object data nil (cadr entry)) - (setcar (nthcdr 4 entry) nil))))))))) + (unwind-protect + (condition-case nil + (eshell-output-object data nil (cadr entry)) + ;; FIXME: We want to send SIGPIPE to the process + ;; here. However, remote processes don't + ;; currently support that, and not all systems + ;; have SIGPIPE in the first place (e.g. MS + ;; Windows). In these cases, just delete the + ;; process; this is reasonably close to the + ;; right behavior, since the default action for + ;; SIGPIPE is to terminate the process. For use + ;; cases where SIGPIPE is truly needed, using an + ;; external pipe operator (`*|') may work + ;; instead (e.g. when working with remote + ;; processes). + (eshell-pipe-broken + (if (or (process-get proc 'remote-pid) + (eq system-type 'windows-nt)) + (delete-process proc) + (signal-process proc 'SIGPIPE)))) + (setcar (nthcdr 4 entry) nil)))))))))) (defun eshell-sentinel (proc string) "Generic sentinel for command processes. Reports only signals. @@ -395,7 +417,7 @@ PROC is the process that's exiting. STRING is the exit message." (when (buffer-live-p (process-buffer proc)) (with-current-buffer (process-buffer proc) (unwind-protect - (let* ((entry (assq proc eshell-process-list))) + (let ((entry (assq proc eshell-process-list))) ; (if (not entry) ; (error "Sentinel called for unowned process `%s'" ; (process-name proc)) @@ -403,8 +425,13 @@ PROC is the process that's exiting. STRING is the exit message." (unwind-protect (progn (unless (string= string "run") - (unless (string-match "^\\(finished\\|exited\\)" string) - (eshell-insertion-filter proc string)) + ;; Write the exit message if the status is + ;; abnormal and the process is already writing + ;; to the terminal. + (when (and (eq proc (eshell-tail-process)) + (not (string-match "^\\(finished\\|exited\\)" + string))) + (funcall (process-filter proc) proc string)) (let ((handles (nth 1 entry)) (str (prog1 (nth 3 entry) (setf (nth 3 entry) nil))) @@ -416,8 +443,12 @@ PROC is the process that's exiting. STRING is the exit message." (lambda () (if (nth 4 entry) (run-at-time 0 nil finish-io) - (when str (eshell-output-object str nil handles)) - (eshell-close-handles status 'nil handles))))) + (when str + (ignore-error 'eshell-pipe-broken + (eshell-output-object + str nil handles))) + (eshell-close-handles + status 'nil handles))))) (funcall finish-io))))) (eshell-remove-process-entry entry)))) (eshell-kill-process-function proc string))))) @@ -544,14 +575,5 @@ See the variable `eshell-kill-processes-on-exit'." ; ;; `eshell-resume-eval'. ; (eshell-kill-process-function nil "continue"))) -(defun eshell-send-eof-to-process () - "Send EOF to process." - (interactive) - (require 'esh-mode) - (declare-function eshell-send-input "esh-mode" - (&optional use-region queue-p no-newline)) - (eshell-send-input nil nil t) - (eshell-process-interact 'process-send-eof)) - (provide 'esh-proc) ;;; esh-proc.el ends here diff --git a/lisp/eshell/esh-util.el b/lisp/eshell/esh-util.el index bacb41eceff..b5a423f0237 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) @@ -151,67 +151,98 @@ Otherwise, evaluates FORM with no error handling." (defun eshell-find-delimiter (open close &optional bound reverse-p backslash-p) "From point, find the CLOSE delimiter corresponding to OPEN. -The matching is bounded by BOUND. -If REVERSE-P is non-nil, process the region backwards. -If BACKSLASH-P is non-nil, and OPEN and CLOSE are the same character, -then quoting is done by a backslash, rather than a doubled delimiter." +The matching is bounded by BOUND. If REVERSE-P is non-nil, +process the region backwards. + +If BACKSLASH-P is non-nil, or OPEN and CLOSE are different +characters, then a backslash can be used to escape a delimiter +(or another backslash). Otherwise, the delimiter is escaped by +doubling it up." (save-excursion (let ((depth 1) (bound (or bound (point-max)))) - (if (if reverse-p - (eq (char-before) close) - (eq (char-after) open)) - (forward-char (if reverse-p -1 1))) + (when (if reverse-p + (eq (char-before) close) + (eq (char-after) open)) + (forward-char (if reverse-p -1 1))) (while (and (> depth 0) - (funcall (if reverse-p '> '<) (point) bound)) - (let ((c (if reverse-p (char-before) (char-after))) nc) + (funcall (if reverse-p #'> #'<) (point) bound)) + (let ((c (if reverse-p (char-before) (char-after)))) (cond ((and (not reverse-p) (or (not (eq open close)) backslash-p) (eq c ?\\) - (setq nc (char-after (1+ (point)))) - (or (eq nc open) (eq nc close))) + (memq (char-after (1+ (point))) + (list open close ?\\))) (forward-char 1)) ((and reverse-p (or (not (eq open close)) backslash-p) - (or (eq c open) (eq c close)) - (eq (char-before (1- (point))) - ?\\)) + (eq (char-before (1- (point))) ?\\) + (memq c (list open close ?\\))) (forward-char -1)) ((eq open close) - (if (eq c open) - (if (and (not backslash-p) - (eq (if reverse-p - (char-before (1- (point))) - (char-after (1+ (point)))) open)) - (forward-char (if reverse-p -1 1)) - (setq depth (1- depth))))) + (when (eq c open) + (if (and (not backslash-p) + (eq (if reverse-p + (char-before (1- (point))) + (char-after (1+ (point)))) + open)) + (forward-char (if reverse-p -1 1)) + (setq depth (1- depth))))) ((= c open) (setq depth (+ depth (if reverse-p -1 1)))) ((= c close) (setq depth (+ depth (if reverse-p 1 -1)))))) (forward-char (if reverse-p -1 1))) - (if (= depth 0) - (if reverse-p (point) (1- (point))))))) - -(defun eshell-convert (string) - "Convert STRING into a more native looking Lisp object." - (if (not (stringp string)) - string - (let ((len (length string))) - (if (= len 0) - string - (if (eq (aref string (1- len)) ?\n) + (when (= depth 0) + (if reverse-p (point) (1- (point))))))) + +(defun eshell-convertible-to-number-p (string) + "Return non-nil if STRING can be converted to a number. +If `eshell-convert-numeric-aguments', always return nil." + (and eshell-convert-numeric-arguments + (string-match + (concat "\\`\\s-*" eshell-number-regexp "\\s-*\\'") + string))) + +(defun eshell-convert-to-number (string) + "Try to convert STRING to a number. +If STRING doesn't look like a number (or +`eshell-convert-numeric-aguments' is nil), just return STRING +unchanged." + (if (eshell-convertible-to-number-p string) + (string-to-number string) + string)) + +(defun eshell-convert (string &optional to-string) + "Convert STRING into a more-native Lisp object. +If TO-STRING is non-nil, always return a single string with +trailing newlines removed. Otherwise, this behaves as follows: + +* Return non-strings as-is. + +* Split multiline strings by line. + +* If `eshell-convert-numeric-aguments' is non-nil and every line + of output looks like a number, convert them to numbers." + (cond + ((not (stringp string)) + (if to-string + (eshell-stringify string) + string)) + (to-string (string-trim-right string "\n+")) + (t (let ((len (length string))) + (if (= len 0) + string + (when (eq (aref string (1- len)) ?\n) (setq string (substring string 0 (1- len)))) - (if (string-search "\n" string) - (split-string string "\n") - (if (and eshell-convert-numeric-arguments - (string-match - (concat "\\`\\s-*" eshell-number-regexp - "\\s-*\\'") string)) - (string-to-number string) - string)))))) + (if (string-search "\n" string) + (let ((lines (split-string string "\n"))) + (if (seq-every-p #'eshell-convertible-to-number-p lines) + (mapcar #'string-to-number lines) + lines)) + (eshell-convert-to-number string))))))) (defvar-local eshell-path-env (getenv "PATH") "Content of $PATH. @@ -262,6 +293,7 @@ Prepend remote identification of `default-directory', if any." (defun eshell-to-flat-string (value) "Make value a string. If separated by newlines change them to spaces." + (declare (obsolete nil "29.1")) (let ((text (eshell-stringify value))) (if (string-match "\n+\\'" text) (setq text (replace-match "" t t text))) @@ -589,11 +621,11 @@ list." The optional argument ID-FORMAT specifies the preferred uid and gid format. Valid values are `string' and `integer', defaulting to `integer'. See `file-attributes'." - (let* ((file (expand-file-name file)) + (let* ((expanded-file (expand-file-name file)) entry) - (if (string-equal (file-remote-p file 'method) "ftp") - (let ((base (file-name-nondirectory file)) - (dir (file-name-directory file))) + (if (string-equal (file-remote-p expanded-file 'method) "ftp") + (let ((base (file-name-nondirectory expanded-file)) + (dir (file-name-directory expanded-file))) (if (string-equal "" base) (setq base ".")) (unless entry (setq entry (eshell-parse-ange-ls dir)) @@ -609,6 +641,20 @@ gid format. Valid values are `string' and `integer', defaulting to "If the `processp' function does not exist, PROC is not a process." (and (fboundp 'processp) (processp proc))) +(defun eshell-process-pair-p (procs) + "Return non-nil if PROCS is a pair of process objects." + (and (consp procs) + (eshell-processp (car procs)) + (eshell-processp (cdr procs)))) + +(defun eshell-make-process-pair (procs) + "Make a pair of process objects from PROCS if possible. +This represents the head and tail of a pipeline of processes, +where the head and tail may be the same process." + (pcase procs + ((pred eshell-processp) (cons procs procs)) + ((pred eshell-process-pair-p) procs))) + ;; (defun eshell-copy-file ;; (file newname &optional ok-if-already-exists keep-date) ;; "Copy FILE to NEWNAME. See docs for `copy-file'." diff --git a/lisp/eshell/esh-var.el b/lisp/eshell/esh-var.el index 1d5d85debad..186f6358bca 100644 --- a/lisp/eshell/esh-var.el +++ b/lisp/eshell/esh-var.el @@ -39,11 +39,6 @@ ;; ;; Only "MYVAR" is part of the variable name in this case. ;; -;; $#VARIABLE -;; -;; Returns the length of the value of VARIABLE. This could also be -;; done using the `length' Lisp function. -;; ;; $(lisp) ;; ;; Returns result of Lisp evaluation. Note: Used alone like this, it @@ -61,38 +56,35 @@ ;; Evaluates an eshell subcommand, redirecting the output to a ;; temporary file, and returning the file name. ;; -;; $ANYVAR[10] +;; $EXPR[10] ;; -;; Return the 10th element of ANYVAR. If ANYVAR's value is a string, -;; it will be split in order to make it a list. The splitting will -;; occur at whitespace. +;; Return the 10th element of $EXPR, which can be any dollar +;; expression. If $EXPR's value is a string, it will be split in +;; order to make it a list. The splitting will occur at whitespace. ;; -;; $ANYVAR[: 10] +;; $EXPR[10 20] ;; -;; As above, except that splitting occurs at the colon now. +;; As above, but instead of returning a single element, it now returns a +;; list of two elements. ;; -;; $ANYVAR[: 10 20] +;; $EXPR[: 10] ;; -;; As above, but instead of returning just a string, it now returns a -;; list of two strings. If the result is being interpolated into a -;; larger string, this list will be flattened into one big string, -;; with each element separated by a space. +;; Like $EXPR[10], except that splitting occurs at the colon now. ;; -;; $ANYVAR["\\\\" 10] +;; $EXPR["\\\\" 10] ;; ;; Separate on backslash characters. Actually, the first argument -- -;; if it doesn't have the form of a number, or a plain variable name -;; -- can be any regular expression. So to split on numbers, use -;; '$ANYVAR["[0-9]+" 10 20]'. +;; if it doesn't have the form of a number -- can be any regular +;; expression. So to split on numbers, use '$EXPR["[0-9]+" 10 20]'. ;; -;; $ANYVAR[hello] +;; $EXPR[hello] ;; -;; Calls `assoc' on ANYVAR with 'hello', expecting it to be an alist. +;; Calls `assoc' on $EXPR with 'hello', expecting it to be an alist. ;; -;; $#ANYVAR[hello] +;; $#EXPR ;; -;; Returns the length of the cdr of the element of ANYVAR who car is -;; equal to "hello". +;; Returns the length of the value of $EXPR. This could also be +;; done using the `length' Lisp function. ;; ;; There are also a few special variables defined by Eshell. '$$' is ;; the value of the last command (t or nil, in the case of an external @@ -193,7 +185,7 @@ list of the indices that was used in the reference, and whether the user is requesting the length of the ultimate element. For example, a reference of `$NAME[10][20]' would result in the function for alias `NAME' being called (assuming it were aliased to a function), and the -arguments passed to this function would be the list '(10 20)', and +arguments passed to this function would be the list `(10 20)', and nil. If the value is a string, return the value for the variable with that @@ -211,14 +203,11 @@ Additionally, each member may specify if it should be copied to the environment of created subprocesses." :type '(repeat (list string sexp (choice (const :tag "Copy to environment" t) - (const :tag "Use only in Eshell" nil))))) - -(put 'eshell-variable-aliases-list 'risky-local-variable t) + (const :tag "Use only in Eshell" nil)))) + :risky t) -(defvar eshell-var-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-c M-v") #'eshell-insert-envvar) - map)) +(defvar-keymap eshell-var-mode-map + "C-c M-v" #'eshell-insert-envvar) ;;; Functions: @@ -413,27 +402,34 @@ process any indices that come after the variable reference." (let* ((get-len (when (eq (char-after) ?#) (forward-char) t)) value indices) - (setq value (eshell-parse-variable-ref) + (setq value (eshell-parse-variable-ref get-len) indices (and (not (eobp)) (eq (char-after) ?\[) (eshell-parse-indices)) ;; This is an expression that will be evaluated by `eshell-do-eval', ;; which only support let-binding of dynamically-scoped vars - value `(let ((indices ',indices)) ,value)) - (if get-len - `(length ,value) - value))) - -(defun eshell-parse-variable-ref () + value `(let ((indices (eshell-eval-indices ',indices))) ,value)) + (when get-len + (setq value `(length ,value))) + (when eshell-current-quoted + (setq value `(eshell-stringify ,value))) + value)) + +(defun eshell-parse-variable-ref (&optional modifier-p) "Eval a variable reference. Returns a Lisp form which, if evaluated, will return the value of the variable. -Possible options are: +If MODIFIER-P is non-nil, the value of the variable will be +modified by some function. If MODIFIER-P is nil, the value will be +used as-is; this allows optimization of some kinds of variable +references. + +Possible variable references are: NAME an environment or Lisp variable value \"LONG-NAME\" disambiguates the length of the name - 'LONG-NAME' as above + `LONG-NAME' as above {COMMAND} result of command is variable's value (LISP-FORM) result of Lisp form is variable's value <COMMAND> write the output of command to a temporary file; @@ -443,18 +439,26 @@ Possible options are: (let ((end (eshell-find-delimiter ?\{ ?\}))) (if (not end) (throw 'eshell-incomplete ?\{) + (forward-char) (prog1 - `(eshell-convert - (eshell-command-to-value - (eshell-as-subcommand - ,(eshell-parse-command (cons (1+ (point)) end))))) + `(eshell-apply-indices + (eshell-convert + (eshell-command-to-value + (eshell-as-subcommand + ,(let ((subcmd (or (eshell-unescape-inner-double-quote end) + (cons (point) end))) + (eshell-current-quoted nil)) + (eshell-parse-command subcmd)))) + ;; If this is a simple double-quoted form like + ;; "${COMMAND}" (i.e. no indices after the subcommand + ;; and no `#' modifier before), ensure we convert to a + ;; single string. This avoids unnecessary work + ;; (e.g. splitting the output by lines) when it would + ;; just be joined back together afterwards. + ,(when (and (not modifier-p) eshell-current-quoted) + '(not indices))) + indices ,eshell-current-quoted) (goto-char (1+ end)))))) - ((memq (char-after) '(?\' ?\")) - (let ((name (if (eq (char-after) ?\') - (eshell-parse-literal-quote) - (eshell-parse-double-quote)))) - (if name - `(eshell-get-variable ,(eval name) indices)))) ((eq (char-after) ?\<) (let ((end (eshell-find-delimiter ?\< ?\>))) (if (not end) @@ -466,7 +470,9 @@ Possible options are: `(let ((eshell-current-handles (eshell-create-handles ,temp 'overwrite))) (progn - (eshell-as-subcommand ,(eshell-parse-command cmd)) + (eshell-as-subcommand + ,(let ((eshell-current-quoted nil)) + (eshell-parse-command cmd))) (ignore (nconc eshell-this-command-hook ;; Quote this lambda; it will be evaluated @@ -475,22 +481,36 @@ Possible options are: ;; properly. See bug#54190. (list (function (lambda () (delete-file ,temp)))))) - (quote ,temp))) + (eshell-apply-indices ,temp indices ,eshell-current-quoted))) (goto-char (1+ end))))))) ((eq (char-after) ?\() (condition-case nil - `(eshell-command-to-value - (eshell-lisp-command - ',(read (current-buffer)))) + `(eshell-apply-indices + (eshell-command-to-value + (eshell-lisp-command + ',(read (or (eshell-unescape-inner-double-quote (point-max)) + (current-buffer))))) + indices ,eshell-current-quoted) (end-of-file (throw 'eshell-incomplete ?\()))) + ((looking-at (rx-to-string + `(or "'" ,(if eshell-current-quoted "\\\"" "\"")))) + (eshell-with-temp-command + (or (eshell-unescape-inner-double-quote (point-max)) + (cons (point) (point-max))) + (let ((name (if (eq (char-after) ?\') + (eshell-parse-literal-quote) + (eshell-parse-double-quote)))) + (when name + `(eshell-get-variable ,(eval name) indices ,eshell-current-quoted))))) ((assoc (char-to-string (char-after)) eshell-variable-aliases-list) (forward-char) - `(eshell-get-variable ,(char-to-string (char-before)) indices)) + `(eshell-get-variable ,(char-to-string (char-before)) indices + ,eshell-current-quoted)) ((looking-at eshell-variable-name-regexp) (prog1 - `(eshell-get-variable ,(match-string 0) indices) + `(eshell-get-variable ,(match-string 0) indices ,eshell-current-quoted) (goto-char (match-end 0)))) (t (error "Invalid variable reference")))) @@ -498,21 +518,33 @@ Possible options are: (defvar eshell-glob-function) (defun eshell-parse-indices () - "Parse and return a list of list of indices." + "Parse and return a list of index-lists. + +For example, \"[0 1][2]\" becomes: + ((\"0\" \"1\") (\"2\")." (let (indices) (while (eq (char-after) ?\[) (let ((end (eshell-find-delimiter ?\[ ?\]))) (if (not end) (throw 'eshell-incomplete ?\[) (forward-char) - (let (eshell-glob-function) - (setq indices (cons (eshell-parse-arguments (point) end) - indices))) + (eshell-with-temp-command (or (eshell-unescape-inner-double-quote end) + (cons (point) end)) + (let (eshell-glob-function (eshell-current-quoted nil)) + (setq indices (cons (eshell-parse-arguments + (point-min) (point-max)) + indices)))) (goto-char (1+ end))))) (nreverse indices))) -(defun eshell-get-variable (name &optional indices) - "Get the value for the variable NAME." +(defun eshell-eval-indices (indices) + "Evaluate INDICES, a list of index-lists generated by `eshell-parse-indices'." + (mapcar (lambda (i) (mapcar #'eval i)) indices)) + +(defun eshell-get-variable (name &optional indices quoted) + "Get the value for the variable NAME. +INDICES is a list of index-lists (see `eshell-parse-indices'). +If QUOTED is non-nil, this was invoked inside double-quotes." (let* ((alias (assoc name eshell-variable-aliases-list)) (var (if alias (cadr alias) @@ -533,9 +565,9 @@ Possible options are: (symbol-value var)) (t (error "Unknown variable `%s'" (eshell-stringify var)))) - indices)))) + indices quoted)))) -(defun eshell-apply-indices (value indices) +(defun eshell-apply-indices (value indices &optional quoted) "Apply to VALUE all of the given INDICES, returning the sub-result. The format of INDICES is: @@ -544,12 +576,17 @@ The format of INDICES is: Each member of INDICES represents a level of nesting. If the first member of a sublist is not an integer or name, and the value it's -reference is a string, that will be used as the regexp with which is -to divide the string into sub-parts. The default is whitespace. +referencing is a string, that will be used as the regexp with which +is to divide the string into sub-parts. The default is whitespace. Otherwise, each INT-OR-NAME refers to an element of the list value. Integers imply a direct index, and names, an associate lookup using `assoc'. +If QUOTED is non-nil, this was invoked inside double-quotes. This +affects the behavior of splitting strings: without quoting, the +split values are converted to Lisp forms via `eshell-convert'; with +quoting, they're left as strings. + For example, to retrieve the second element of a user's record in '/etc/passwd', the variable reference would look like: @@ -557,15 +594,13 @@ For example, to retrieve the second element of a user's record in (while indices (let ((refs (car indices))) (when (stringp value) - (let (separator) - (if (not (or (not (stringp (caar indices))) - (string-match - (concat "^" eshell-variable-name-regexp "$") - (caar indices)))) - (setq separator (caar indices) - refs (cdr refs))) + (let (separator (index (caar indices))) + (when (and (stringp index) + (not (get-text-property 0 'number index))) + (setq separator index + refs (cdr refs))) (setq value - (mapcar #'eshell-convert + (mapcar (lambda (i) (eshell-convert i quoted)) (split-string value separator))))) (cond ((< (length refs) 0) diff --git a/lisp/eshell/eshell.el b/lisp/eshell/eshell.el index fbf347e55a7..2c472a2afad 100644 --- a/lisp/eshell/eshell.el +++ b/lisp/eshell/eshell.el @@ -260,7 +260,7 @@ information on Eshell, see Info node `(eshell)Top'." (t (get-buffer-create eshell-buffer-name))))) (cl-assert (and buf (buffer-live-p buf))) - (pop-to-buffer-same-window buf) + (pop-to-buffer buf display-comint-buffer-action) (unless (derived-mode-p 'eshell-mode) (eshell-mode)) buf)) @@ -332,9 +332,9 @@ With prefix ARG, insert output into the current buffer at point." ;; make the output as attractive as possible, with no ;; extraneous newlines (when intr - (if (eshell-interactive-process) - (eshell-wait-for-process (eshell-interactive-process))) - (cl-assert (not (eshell-interactive-process))) + (if (eshell-interactive-process-p) + (eshell-wait-for-process (eshell-tail-process))) + (cl-assert (not (eshell-interactive-process-p))) (goto-char (point-max)) (while (and (bolp) (not (bobp))) (delete-char -1))) diff --git a/lisp/ezimage.el b/lisp/ezimage.el index f1d02fe77ea..9e5a08e682f 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/face-remap.el b/lisp/face-remap.el index 6221a0708c5..50306a5e8a0 100644 --- a/lisp/face-remap.el +++ b/lisp/face-remap.el @@ -70,9 +70,28 @@ :foreground :background :stipple :overline :strike-through :box :font :inherit :fontset :distant-foreground :extend :vector]) +(defun face-remap--copy-face (val) + "Return a copy of the `face' property value VAL." + ;; A `face' property can be either a face name (a symbol), or a face + ;; property list like (:foreground "red" :inherit default), + ;; or a list of such things. + ;; FIXME: This should probably be shared to some extent with + ;; `add-face-text-property'. + (if (or (not (listp val)) (keywordp (car val))) + val + (copy-sequence val))) + +(defun face-attrs--make-indirect-safe () + "Deep-copy the buffer's `face-remapping-alist' upon cloning the buffer." + (setq-local face-remapping-alist + (mapcar #'face-remap--copy-face face-remapping-alist))) + +(add-hook 'clone-indirect-buffer-hook #'face-attrs--make-indirect-safe) + (defun face-attrs-more-relative-p (attrs1 attrs2) - "Return true if ATTRS1 contains a greater number of relative -face-attributes than ATTRS2. A face attribute is considered + "Return non-nil if ATTRS1 is \"more relative\" than ATTRS2. +We define this as meaning that ATTRS1 contains a greater number of +relative face-attributes than ATTRS2. A face attribute is considered relative if `face-attribute-relative-p' returns non-nil. ATTRS1 and ATTRS2 may be any value suitable for a `face' text @@ -99,7 +118,7 @@ face lists so that more specific faces are located near the end." "Order ENTRY so that more relative face specs are near the beginning. The list structure of ENTRY may be destructively modified." (setq entry (nreverse entry)) - (setcdr entry (sort (cdr entry) 'face-attrs-more-relative-p)) + (setcdr entry (sort (cdr entry) #'face-attrs-more-relative-p)) (nreverse entry)) ;;;###autoload @@ -188,10 +207,12 @@ If SPECS is empty or a single face `eq' to FACE, call `face-remap-reset-base' to use the normal definition of FACE as the base remapping; note that this is different from SPECS containing a single value nil, which means not to inherit from the global definition of FACE at all." + ;; Simplify the specs in the case where it's just a single face (and + ;; it's not a list with just a nil). (while (and (consp specs) (not (null (car specs))) (null (cdr specs))) (setq specs (car specs))) (if (or (null specs) - (and (eq (car specs) face) (null (cdr specs)))) ; default + (eq specs face)) ; default ;; Set entry back to default (face-remap-reset-base face) ;; Set the base remapping @@ -388,7 +409,36 @@ a top-level keymap, `text-scale-increase' or (dolist (key '(?- ?+ ?= ?0)) ;; = is often unshifted +. (define-key map (vector (append mods (list key))) (lambda () (interactive) (text-scale-adjust (abs inc)))))) - map))))) ;; ) + map) + nil + ;; Clear the prompt after exiting. + (lambda () + (message "")))))) + +(defvar-local text-scale--pinch-start-scale 0 + "The text scale at the start of a pinch sequence.") + +;;;###autoload (define-key global-map [pinch] 'text-scale-pinch) +;;;###autoload +(defun text-scale-pinch (event) + "Adjust the height of the default face by the scale in the pinch event EVENT." + (interactive "e") + (when (not (eq (event-basic-type event) 'pinch)) + (error "`text-scale-pinch' bound to bad event type")) + (let ((window (posn-window (nth 1 event))) + (scale (nth 4 event)) + (dx (nth 2 event)) + (dy (nth 3 event)) + (angle (nth 5 event))) + (with-selected-window window + (when (and (zerop dx) + (zerop dy) + (zerop angle)) + (setq text-scale--pinch-start-scale + (if text-scale-mode text-scale-mode-amount 0))) + (text-scale-set + (+ text-scale--pinch-start-scale + (round (log scale text-scale-mode-step))))))) ;; ---------------------------------------------------------------- diff --git a/lisp/facemenu.el b/lisp/facemenu.el index 196bb9e4cd4..b3e01696325 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 e93d8c7af85..d92569e7cd1 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -46,7 +46,8 @@ the terminal-initialization file to be loaded." ("vt320" . "vt200") ("vt400" . "vt200") ("vt420" . "vt200") - ("alacritty" . "xterm")) + ("alacritty" . "xterm") + ("foot" . "xterm")) "Alist of terminal type aliases. Entries are of the form (TYPE . ALIAS), where both elements are strings. This means to treat a terminal of type TYPE as if it were of type ALIAS." @@ -88,9 +89,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 +141,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 +168,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))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -701,8 +702,10 @@ and `?' are allowed. VALUE specifies the relative proportionate width of the font to use. It must be one of the symbols `ultra-condensed', `extra-condensed', -`condensed', `semi-condensed', `normal', `semi-expanded', `expanded', -`extra-expanded', or `ultra-expanded'. +`condensed' (a.k.a. `compressed', a.k.a. `narrow'), +`semi-condensed' (a.k.a. `demi-condensed'), `normal' (a.k.a. `medium', +a.k.a. `regular'), `semi-expanded' (a.k.a. `demi-expanded'), +`expanded', `extra-expanded', or `ultra-expanded' (a.k.a. `wide'). `:height' @@ -717,9 +720,12 @@ 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' (a.k.a. `black'), +`ultra-bold' (a.k.a. `extra-bold'), `bold', +`semi-bold' (a.k.a. `demi-bold'), `medium', `normal' (a.k.a. `regular', +a.k.a. `book'), `semi-light' (a.k.a. `demi-light'), +`light', `extra-light' (a.k.a. `ultra-light'), or `thin'. `:slant' @@ -876,8 +882,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)) @@ -885,8 +891,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)) @@ -895,8 +901,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)) @@ -904,8 +910,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)) @@ -914,8 +920,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)) @@ -1075,6 +1081,9 @@ of the default face. Value is FACE." (defvar crm-separator) ; from crm.el +(defconst read-face-name-sample-text "SAMPLE" + "Text string to display as the sample text for `read-face-name'.") + (defun read-face-name (prompt &optional default multiple) "Read one or more face names, prompting with PROMPT. PROMPT should not end in a space or a colon. @@ -1091,54 +1100,72 @@ That is, if DEFAULT is a list and MULTIPLE is nil, the first element of DEFAULT is returned. If DEFAULT isn't a list, but MULTIPLE is non-nil, a one-element list containing DEFAULT is returned. Otherwise, DEFAULT is returned verbatim." - (unless (listp default) - (setq default (list default))) - (when default - (setq default - (if multiple - (mapconcat (lambda (f) (if (symbolp f) (symbol-name f) f)) - default ", ") - ;; If we only want one, and the default is more than one, - ;; discard the unwanted ones. - (setq default (car default)) - (if (symbolp default) - (symbol-name default) - default)))) - (when (and default (not multiple)) - (require 'crm) - ;; For compatibility with `completing-read-multiple' use `crm-separator' - ;; to define DEFAULT if MULTIPLE is nil. - (setq default (car (split-string default crm-separator t)))) - - ;; Older versions of `read-face-name' did not append ": " to the - ;; prompt, so there are third party libraries that have that in the - ;; prompt. If so, remove it. - (setq prompt (replace-regexp-in-string ": ?\\'" "" prompt)) - (let ((prompt (if default - (format-message "%s (default `%s'): " prompt default) - (format "%s: " prompt))) - aliasfaces nonaliasfaces faces) - ;; Build up the completion tables. - (mapatoms (lambda (s) - (if (facep s) - (if (get s 'face-alias) - (push (symbol-name s) aliasfaces) - (push (symbol-name s) nonaliasfaces))))) - (if multiple - (progn - (dolist (face (completing-read-multiple - prompt - (completion-table-in-turn nonaliasfaces aliasfaces) - nil t nil 'face-name-history default)) - ;; Ignore elements that are not faces - ;; (for example, because DEFAULT was "all faces") - (if (facep face) (push (intern face) faces))) - (nreverse faces)) - (let ((face (completing-read - prompt - (completion-table-in-turn nonaliasfaces aliasfaces) - nil t nil 'face-name-history default))) - (if (facep face) (intern face)))))) + (let (defaults) + (unless (listp default) + (setq default (list default))) + (when default + (setq default + (if multiple + (mapconcat (lambda (f) (if (symbolp f) (symbol-name f) f)) + default ", ") + ;; If we only want one, and the default is more than one, + ;; discard the unwanted ones and use them only in the + ;; "future history" retrieved via `M-n M-n ...'. + (setq defaults default default (car default)) + (if (symbolp default) + (symbol-name default) + default)))) + (when (and default (not multiple)) + (require 'crm) + ;; For compatibility with `completing-read-multiple' use `crm-separator' + ;; to define DEFAULT if MULTIPLE is nil. + (setq default (car (split-string default crm-separator t)))) + + ;; Older versions of `read-face-name' did not append ": " to the + ;; prompt, so there are third party libraries that have that in the + ;; prompt. If so, remove it. + (setq prompt (replace-regexp-in-string ": ?\\'" "" prompt)) + (let ((prompt (if default + (format-prompt prompt default) + (format "%s: " prompt))) + (completion-extra-properties + '(:affixation-function + (lambda (faces) + (mapcar + (lambda (face) + (list face + (concat (propertize read-face-name-sample-text + 'face face) + "\t") + "")) + faces)))) + aliasfaces nonaliasfaces faces) + ;; Build up the completion tables. + (mapatoms (lambda (s) + (if (facep s) + (if (get s 'face-alias) + (push (symbol-name s) aliasfaces) + (push (symbol-name s) nonaliasfaces))))) + (if multiple + (progn + (dolist (face (completing-read-multiple + prompt + (completion-table-in-turn nonaliasfaces aliasfaces) + nil t nil 'face-name-history default)) + ;; Ignore elements that are not faces + ;; (for example, because DEFAULT was "all faces") + (if (facep face) (push (if (stringp face) + (intern face) + face) + faces))) + (nreverse faces)) + (let ((face (completing-read + prompt + (completion-table-in-turn nonaliasfaces aliasfaces) + nil t nil 'face-name-history defaults))) + (when (facep face) (if (stringp face) + (intern face) + face))))))) ;; Not defined without X, but behind window-system test. (defvar x-bitmap-file-path) @@ -1161,42 +1188,43 @@ 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 - (mapcar #'list + (and (memq (window-system frame) '(x ns pgtk haiku)) ; No stipple on w32 + (mapcar (lambda (item) + (cons item item)) (apply #'nconc (mapcar (lambda (dir) (and (file-readable-p dir) (file-directory-p dir) - (directory-files dir))) + (directory-files dir 'full))) 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"))))) @@ -1530,7 +1558,7 @@ If FRAME is nil, the current FRAME is used." match (cond ((eq req 'type) (or (memq (window-system frame) options) (and (memq 'graphic options) - (memq (window-system frame) '(x w32 ns))) + (memq (window-system frame) '(x w32 ns pgtk))) ;; FIXME: This should be revisited to use ;; display-graphic-p, provided that the ;; color selection depends on the number @@ -1732,7 +1760,15 @@ The following sources are applied in this order: (and tail (face-spec-set-2 face frame (list :extend (cadr tail)))))) (setq face-attrs (face-spec-choose (get face 'face-override-spec) frame)) - (face-spec-set-2 face frame face-attrs))) + (face-spec-set-2 face frame face-attrs) + (when (and (fboundp 'set-frame-parameter) ; This isn't available + ; during loadup. + (eq face 'scroll-bar)) + ;; Set the `scroll-bar-foreground' and `scroll-bar-background' + ;; frame parameters, because the face is handled by setting + ;; those two parameters. (bug#13476) + (set-frame-parameter frame 'scroll-bar-foreground (face-foreground face)) + (set-frame-parameter frame 'scroll-bar-background (face-background face))))) (defun face-spec-set-2 (face frame face-attrs) "Set the face attributes of FACE on FRAME according to FACE-ATTRS. @@ -1838,8 +1874,8 @@ on which one provides better contrast with COLOR." "#ffffff" "black")) (defconst color-luminance-dark-limit 0.325 - "The relative luminance below which a color is considered 'dark'. -A 'dark' color in this sense provides better contrast with white + "The relative luminance below which a color is considered \"dark\". +A \"dark\" color in this sense provides better contrast with white than with black; see `color-dark-p'. This value was determined experimentally.") @@ -2306,19 +2342,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)) @@ -2401,6 +2437,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") @@ -2634,11 +2679,21 @@ non-nil." :background "grey75" :foreground "black") (t :inverse-video t)) - "Basic mode line face for selected window." + "Face for the mode lines as well as header lines. +See `mode-line-active' and `mode-line-inactive' for the faces +used on mode lines." :version "21.1" :group 'mode-line-faces :group 'basic-faces) +(defface mode-line-active + '((t :inherit mode-line)) + "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) @@ -2803,11 +2858,9 @@ used to display the prompt text." :group 'frames :group 'basic-faces) -(defface scroll-bar - '((((background light)) :foreground "black") - (((background dark)) :foreground "white")) +(defface scroll-bar '((t nil)) "Basic face for the scroll bar colors under X." - :version "28.1" + :version "21.1" :group 'frames :group 'basic-faces) @@ -2842,7 +2895,10 @@ 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 haiku)) + :foreground "B_MENU_ITEM_TEXT_COLOR" + :background "B_MENU_BACKGROUND_COLOR") + (((type x w32 ns pgtk) (class color)) :background "grey75") (((type x) (class mono)) :background "grey")) @@ -2898,14 +2954,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. @@ -2957,7 +3021,7 @@ It is used for characters of no fonts too." :group 'basic-faces) (defface read-multiple-choice-face - '((t (:inherit underline + '((t (:inherit (help-key-binding underline) :weight bold))) "Face for the symbol name in `read-multiple-choice' output." :group 'basic-faces diff --git a/lisp/ffap.el b/lisp/ffap.el index d7544bb5a49..ae86e554906 100644 --- a/lisp/ffap.el +++ b/lisp/ffap.el @@ -79,7 +79,7 @@ ;; (setq ffap-shell-prompt-regexp nil) ; disable shell prompt stripping ;; (setq ffap-gopher-regexp nil) ; disable gopher bookmark matching ;; -;; ffap uses `browse-url' (if found, else `w3-fetch') to fetch URL's. +;; ffap uses `browse-url' (if found, else `w3-fetch') to fetch URLs. ;; For a hairier `ffap-url-fetcher', try ffap-url.el (same ftp site). ;; Also, you can add `ffap-menu-rescan' to various hooks to fontify ;; the file and URL references within a buffer. @@ -282,7 +282,7 @@ For a fancy alternative, get `ffap-url.el'." :risky t) (defcustom ffap-next-regexp - ;; If you want ffap-next to find URL's only, try this: + ;; If you want ffap-next to find URLs only, try this: ;; (and ffap-url-regexp (string-match "\\\\`" ffap-url-regexp) ;; (concat "\\<" (substring ffap-url-regexp 2)))) ;; @@ -315,7 +315,7 @@ disable ffap most of the time." ;;; Find Next Thing in buffer (`ffap-next'): ;; -;; Original ffap-next-url (URL's only) from RPECK 30 Mar 1995. Since +;; Original ffap-next-url (URLs only) from RPECK 30 Mar 1995. Since ;; then, broke it up into ffap-next-guess (noninteractive) and ;; ffap-next (a command). It now work on files as well as url's. @@ -363,7 +363,7 @@ Actual search is done by the function `ffap-next-guess'." (sit-for 0) ; display point movement (find-file-at-point (ffap-prompter guess))) (goto-char pt) ; restore point - (message "No %sfiles or URL's found" + (message "No %sfiles or URLs found" (if wrap "" "more "))))) (defun ffap-next-url (&optional back wrap) @@ -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) @@ -1229,13 +1229,13 @@ If the region is active, return a string from the region. If the point is in a comment, ensure that the returned string does not contain the comment start characters (especially for major modes that -have '//' as comment start characters). +have \"//\" as comment start characters). Set the variables `ffap-string-at-point' and `ffap-string-at-point-region'. When the region is active and larger than `ffap-max-region-length', -return an empty string, and set `ffap-string-at-point-region' to '(1 1)." +return an empty string, and set `ffap-string-at-point-region' to `(1 1)'." (let* (dir-separator (args (cdr @@ -1449,10 +1449,13 @@ which may actually result in an URL rather than a filename." (ffap-file-exists-string (substring name 0 (match-beginning 0))))) ;; If it contains a colon, get rid of it (and return if exists) ((and (string-match path-separator name) - (setq name (ffap-string-at-point 'nocolon)) - (> (length name) 0) - (ffap-file-exists-string name))) - ;; File does not exist, try the alist: + (let ((this-name (ffap-string-at-point 'nocolon))) + ;; But don't interpret the first part if ":/bin" as + ;; the empty string. + (when (> (length this-name) 0) + (setq name this-name) + (ffap-file-exists-string name))))) + ;; File does not exist, try the alist: ((let ((alist ffap-alist) tem try case-fold-search) (while (and alist (not try)) (setq tem (car alist) alist (cdr alist)) diff --git a/lisp/filenotify.el b/lisp/filenotify.el index befd2ae437e..94e07289e32 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-x.el b/lisp/files-x.el index e86ba8f8d04..4db6fbd22cc 100644 --- a/lisp/files-x.el +++ b/lisp/files-x.el @@ -579,15 +579,22 @@ changed by the user.") (setq ignored-local-variables (cons 'connection-local-variables-alist ignored-local-variables)) -(defvar connection-local-profile-alist nil +(defcustom connection-local-profile-alist nil "Alist mapping connection profiles to variable lists. Each element in this list has the form (PROFILE VARIABLES). PROFILE is the name of a connection profile (a symbol). VARIABLES is a list that declares connection-local variables for PROFILE. An element in VARIABLES is an alist whose elements are -of the form (VAR . VALUE).") - -(defvar connection-local-criteria-alist nil +of the form (VAR . VALUE)." + :type '(repeat (cons (symbol :tag "Profile") + (repeat :tag "Variables" + (cons (symbol :tag "Variable") + (sexp :tag "Value"))))) + :group 'files + :group 'tramp + :version "29.1") + +(defcustom connection-local-criteria-alist nil "Alist mapping connection criteria to connection profiles. Each element in this list has the form (CRITERIA PROFILES). CRITERIA is a plist identifying a connection and the application @@ -596,7 +603,19 @@ using this connection. Property names might be `:application', `:application' is a symbol, all other property values are strings. All properties are optional; if CRITERIA is nil, it always applies. -PROFILES is a list of connection profiles (symbols).") +PROFILES is a list of connection profiles (symbols)." + :type '(repeat (cons (plist :tag "Criteria" + ;; Give the most common options as checkboxes. + :options (((const :format "%v " :application) + symbol) + ((const :format "%v " :protocol) string) + ((const :format "%v " :user) string) + ((const :format "%v " :machine) string))) + (repeat :tag "Profiles" + (symbol :tag "Profile")))) + :group 'files + :group 'tramp + :version "29.1") (defsubst connection-local-normalize-criteria (criteria) "Normalize plist CRITERIA according to properties. @@ -649,7 +668,9 @@ variables for a connection profile are defined using (setcdr slot (delete-dups (append (cdr slot) profiles))) (setq connection-local-criteria-alist (cons (cons criteria (delete-dups profiles)) - connection-local-criteria-alist))))) + connection-local-criteria-alist)))) + (customize-set-variable + 'connection-local-criteria-alist connection-local-criteria-alist)) (defsubst connection-local-get-profile-variables (profile) "Return the connection-local variable list for PROFILE." @@ -668,7 +689,9 @@ connection profile using `connection-local-set-profiles'. Then variables are set in the server's process buffer according to the VARIABLES list of the connection profile. The list is processed in order." - (setf (alist-get profile connection-local-profile-alist) variables)) + (setf (alist-get profile connection-local-profile-alist) variables) + (customize-set-variable + 'connection-local-profile-alist connection-local-profile-alist)) (defun hack-connection-local-variables (criteria) "Read connection-local variables according to CRITERIA. @@ -699,36 +722,46 @@ will not be changed." (copy-tree connection-local-variables-alist))) (hack-local-variables-apply))) +(defvar connection-local-default-application 'tramp + "Default application in connection-local functions, a symbol. +This variable must not be changed globally.") + (defsubst connection-local-criteria-for-default-directory (&optional application) "Return a connection-local criteria, which represents `default-directory'. -If APPLICATION is nil, the symbol `tramp' is used." +If APPLICATION is nil, `connection-local-default-application' is used." (when (file-remote-p default-directory) - `(:application ,(or application 'tramp) - :protocol ,(file-remote-p default-directory 'method) - :user ,(file-remote-p default-directory 'user) - :machine ,(file-remote-p default-directory 'host)))) + `(:application ,(or application connection-local-default-application) + :protocol ,(file-remote-p default-directory 'method) + :user ,(file-remote-p default-directory 'user) + :machine ,(file-remote-p default-directory 'host)))) ;;;###autoload (defmacro with-connection-local-variables (&rest body) "Apply connection-local variables according to `default-directory'. Execute BODY, and unwind connection-local variables." (declare (debug t)) - `(if (file-remote-p default-directory) - (let ((enable-connection-local-variables t) - (old-buffer-local-variables (buffer-local-variables)) - connection-local-variables-alist) - (hack-connection-local-variables-apply - (connection-local-criteria-for-default-directory)) - (unwind-protect - (progn ,@body) - ;; Cleanup. - (dolist (variable connection-local-variables-alist) - (let ((elt (assq (car variable) old-buffer-local-variables))) - (if elt - (set (make-local-variable (car elt)) (cdr elt)) - (kill-local-variable (car variable))))))) - ;; No connection-local variables to apply. - ,@body)) + `(with-connection-local-variables-1 (lambda () ,@body))) + +;;;###autoload +(defun with-connection-local-variables-1 (body-fun) + "Apply connection-local variables according to `default-directory'. +Call BODY-FUN with no args, and then unwind connection-local variables." + (if (file-remote-p default-directory) + (let ((enable-connection-local-variables t) + (old-buffer-local-variables (buffer-local-variables)) + connection-local-variables-alist) + (hack-connection-local-variables-apply + (connection-local-criteria-for-default-directory)) + (unwind-protect + (funcall body-fun) + ;; Cleanup. + (dolist (variable connection-local-variables-alist) + (let ((elt (assq (car variable) old-buffer-local-variables))) + (if elt + (set (make-local-variable (car elt)) (cdr elt)) + (kill-local-variable (car variable))))))) + ;; No connection-local variables to apply. + (funcall body-fun))) ;;;###autoload (defun path-separator () diff --git a/lisp/files.el b/lisp/files.el index 292c05b58e4..b5da0ea5c52 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. @@ -962,10 +987,7 @@ one or more of those symbols." (logior (if (memq 'executable predicate) 1 0) (if (memq 'writable predicate) 2 0) (if (memq 'readable predicate) 4 0)))) - (let ((file (locate-file-internal filename path suffixes predicate))) - (if (and file (string-match "\\.eln\\'" file)) - (gethash (file-name-nondirectory file) comp-eln-to-el-h) - file))) + (locate-file-internal filename path suffixes predicate)) (defun locate-file-completion-table (dirs suffixes string pred action) "Do completion for file names passed to `locate-file'." @@ -1468,8 +1490,13 @@ in all cases, since that is the standard symbol for byte." (if (string= prefix "") "" "i") (or unit "B")) (concat prefix unit)))) - (format (if (and (>= (mod file-size 1.0) 0.05) + ;; Mimic what GNU "ls -lh" does: + ;; If the formatted size will have just one digit before the decimal... + (format (if (and (< file-size 10) + ;; ...and its fractional part is not too small... + (>= (mod file-size 1.0) 0.05) (< (mod file-size 1.0) 0.95)) + ;; ...then emit one digit after the decimal. "%.1f%s%s" "%.0f%s%s") file-size @@ -1990,12 +2017,14 @@ otherwise a string <2> or <3> or ... is appended to get an unused name. Emacs treats buffers whose names begin with a space as internal buffers. To avoid confusion when visiting a file whose name begins with a space, this function prepends a \"|\" to the final result if necessary." - (let ((lastname (file-name-nondirectory filename))) - (if (string= lastname "") - (setq lastname filename)) - (generate-new-buffer (if (string-prefix-p " " lastname) - (concat "|" lastname) - lastname)))) + (let* ((lastname (file-name-nondirectory filename)) + (lastname (if (string= lastname "") + filename lastname)) + (buf (generate-new-buffer (if (string-prefix-p " " lastname) + (concat "|" lastname) + lastname)))) + (uniquify--create-file-buffer-advice buf filename) + buf)) (defcustom automount-dir-prefix (purecopy "^/tmp_mnt/") "Regexp to match the automounter prefix in a directory name." @@ -2020,73 +2049,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). @@ -2750,8 +2760,7 @@ since only a single case-insensitive search through the alist is made." (defvar auto-mode-alist ;; Note: The entries for the modes defined in cc-mode.el (c-mode, ;; c++-mode, java-mode and more) are added through autoload - ;; directives in that file. That way is discouraged since it - ;; spreads out the definition of the initial value. + ;; directives in that file. (mapcar (lambda (elt) (cons (purecopy (car elt)) (cdr elt))) @@ -2766,6 +2775,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. @@ -2891,6 +2901,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) @@ -2920,7 +2931,7 @@ ARC\\|ZIP\\|LZH\\|LHA\\|ZOO\\|[JEW]AR\\|XPI\\|RAR\\|CBR\\|7Z\\|SQUASHFS\\)\\'" . ("\\.\\(diffs?\\|patch\\|rej\\)\\'" . diff-mode) ("\\.\\(dif\\|pat\\)\\'" . diff-mode) ; for MS-DOS ("\\.[eE]?[pP][sS]\\'" . ps-mode) - ("\\.\\(?:PDF\\|DVI\\|OD[FGPST]\\|DOCX\\|XLSX?\\|PPTX?\\|pdf\\|djvu\\|dvi\\|od[fgpst]\\|docx\\|xlsx?\\|pptx?\\)\\'" . doc-view-mode-maybe) + ("\\.\\(?:PDF\\|EPUB\\|CBZ\\|FB2\\|O?XPS\\|DVI\\|OD[FGPST]\\|DOCX\\|XLSX?\\|PPTX?\\|pdf\\|epub\\|cbz\\|fb2\\|o?xps\\|djvu\\|dvi\\|od[fgpst]\\|docx\\|xlsx?\\|pptx?\\)\\'" . doc-view-mode-maybe) ("configure\\.\\(ac\\|in\\)\\'" . autoconf-mode) ("\\.s\\(v\\|iv\\|ieve\\)\\'" . sieve-mode) ("BROWSE\\'" . ebrowse-tree-mode) @@ -2983,6 +2994,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) @@ -3046,8 +3058,7 @@ and `magic-mode-alist', which determines modes based on file contents.") (defvar interpreter-mode-alist ;; Note: The entries for the modes defined in cc-mode.el (awk-mode ;; and pike-mode) are added through autoload directives in that - ;; file. That way is discouraged since it spreads out the - ;; definition of the initial value. + ;; file. (mapcar (lambda (l) (cons (purecopy (car l)) (cdr l))) @@ -3239,6 +3250,7 @@ extra checks should be done." (let ((case-fold-search t)) (assoc-default name alist 'string-match)))))) (if (and mode + (not (functionp mode)) (consp mode) (cadr mode)) (setq mode (car mode) @@ -3631,7 +3643,7 @@ DIR-NAME is the name of the associated directory. Otherwise it is nil." (cond (unsafe-vars (insert "The local variables list in " name - "\ncontains values that may not be safe (*)" + "\nor .dir-locals.el contains values that may not be safe (*)" (if risky-vars ", and variables that are risky (**)." "."))) @@ -3730,8 +3742,8 @@ return as the symbol specifying the mode." (while (not (or (and (eq handle-mode t) result) (>= (point) end))) (unless (looking-at hack-local-variable-regexp) - (message "Malformed mode-line: %S" - (buffer-substring-no-properties (point) end)) + (message "Malformed mode-line: %S in buffer %S" + (buffer-substring-no-properties (point) end) (buffer-name)) (throw 'malformed-line nil)) (goto-char (match-end 0)) ;; There used to be a downcase here, @@ -3958,22 +3970,21 @@ major-mode." ;; Discard the prefix. (if (looking-at prefix) (delete-region (point) (match-end 0)) - (error "Local variables entry is missing the prefix")) + (user-error "Local variables entry is missing the prefix")) (end-of-line) ;; Discard the suffix. (if (looking-back suffix (line-beginning-position)) (delete-region (match-beginning 0) (point)) - (error "Local variables entry is missing the suffix")) + (user-error "Local variables entry is missing the suffix")) (forward-line 1)) (goto-char (point-min)) - (while (not (or (eobp) - (and (eq handle-mode t) result))) + (while (not (eobp)) ;; Find the variable name; (unless (looking-at hack-local-variable-regexp) - (error "Malformed local variable line: %S" - (buffer-substring-no-properties - (point) (line-end-position)))) + (user-error "Malformed local variable line: %S" + (buffer-substring-no-properties + (point) (line-end-position)))) (goto-char (match-end 1)) (let* ((str (match-string 1)) (var (intern str)) @@ -3994,7 +4005,8 @@ major-mode." (not (string-match "-minor\\'" (setq val2 (downcase (symbol-name val))))) - (setq result (intern (concat val2 "-mode")))) + ;; Allow several mode: elements. + (push (intern (concat val2 "-mode")) result)) (cond ((eq var 'coding)) ((eq var 'lexical-binding) (unless hack-local-variables--warned-lexical @@ -4018,7 +4030,10 @@ major-mode." val) result)))))) (forward-line 1))))))) - result)) + (if (eq handle-mode t) + ;; Return the final mode: setting that's defined. + (car (seq-filter #'fboundp result)) + result))) (defun hack-local-variables-apply () "Apply the elements of `file-local-variables-alist'. @@ -4052,7 +4067,8 @@ It is safe if any of these conditions are met: (and (functionp safep) ;; If the function signals an error, that means it ;; can't assure us that the value is safe. - (with-demoted-errors (funcall safep val)))))) + (with-demoted-errors "Local variable error: %S" + (funcall safep val)))))) (defun risky-local-variable-p (sym &optional _ignored) "Non-nil if SYM could be dangerous as a file-local variable. @@ -4077,11 +4093,8 @@ It is dangerous if either of these conditions are met: (defun hack-one-local-variable-quotep (exp) (and (consp exp) (eq (car exp) 'quote) (consp (cdr exp)))) -(defun hack-one-local-variable-constantp (exp) - (or (and (not (symbolp exp)) (not (consp exp))) - (memq exp '(t nil)) - (keywordp exp) - (hack-one-local-variable-quotep exp))) +(define-obsolete-function-alias 'hack-one-local-variable-constantp + #'macroexp-const-p "29.1") (defun hack-one-local-variable-eval-safep (exp) "Return non-nil if it is safe to eval EXP when it is found in a file." @@ -4119,7 +4132,7 @@ It is dangerous if either of these conditions are met: (cond ((eq prop t) (let ((ok t)) (dolist (arg (cdr exp)) - (unless (hack-one-local-variable-constantp arg) + (unless (macroexp-const-p arg) (setq ok nil))) ok)) ((functionp prop) @@ -4741,7 +4754,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: " @@ -4752,33 +4764,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. @@ -4921,7 +4944,7 @@ BACKUPNAME is the backup file name, which is the old file renamed." nil))) ;; If set-file-extended-attributes fails, fall back on set-file-modes. (unless (and extended-attributes - (with-demoted-errors + (with-demoted-errors "Error setting attributes: %S" (set-file-extended-attributes to-name extended-attributes))) (and modes (set-file-modes to-name (logand modes #o1777) nofollow-flag))))) @@ -5053,6 +5076,33 @@ 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 (if (equal dir "") "" + ;; On Windows, the first component might be "c:" or + ;; the like. + (substring dir 0 -1)) + 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. @@ -5519,7 +5569,8 @@ Before and after saving the buffer, this function runs (goto-char (point-max)) (insert ?\n)))) ;; Don't let errors prevent saving the buffer. - (with-demoted-errors (run-hooks 'before-save-hook)) + (with-demoted-errors "Before-save hook error: %S" + (run-hooks 'before-save-hook)) ;; Give `write-contents-functions' a chance to ;; short-circuit the whole process. (unless (run-hook-with-args-until-success 'write-contents-functions) @@ -5567,7 +5618,7 @@ Before and after saving the buffer, this function runs (condition-case () (progn (unless - (with-demoted-errors + (with-demoted-errors "Error setting file modes: %S" (set-file-modes buffer-file-name (car setmodes))) (set-file-extended-attributes buffer-file-name (nth 1 setmodes)))) @@ -5682,7 +5733,7 @@ Before and after saving the buffer, this function runs ;; If set-file-extended-attributes fails, fall back on ;; set-file-modes. (unless - (with-demoted-errors + (with-demoted-errors "Error setting attributes: %s" (set-file-extended-attributes buffer-file-name (nth 1 setmodes))) (set-file-modes buffer-file-name @@ -5777,15 +5828,50 @@ of the directory that was default during command invocation." (lambda () (file-in-directory-p default-directory root)))) (put 'save-some-buffers-root 'save-some-buffers-function t) +(defun files--buffers-needing-to-be-saved (pred) + "Return a list of buffers to save according to PRED. +See `save-some-buffers' for PRED values." + (let ((buffers + (mapcar (lambda (buffer) + (if + ;; Note that killing some buffers may kill others via + ;; hooks (e.g. Rmail and its viewing buffer). + (and (buffer-live-p buffer) + (buffer-modified-p buffer) + (not (buffer-base-buffer buffer)) + (or + (buffer-file-name buffer) + (with-current-buffer buffer + (or (eq buffer-offer-save 'always) + (and pred buffer-offer-save + (> (buffer-size) 0))))) + (or (not (functionp pred)) + (with-current-buffer buffer + (funcall pred)))) + buffer)) + (buffer-list)))) + (delq nil buffers))) + +(defvar save-some-buffers-functions nil + "Functions to be run by `save-some-buffers' after saving the buffers. +The functions can be called in two \"modes\", depending on the +first argument. If the first argument is `query', then the +function should return non-nil if there is something to be +saved (but it should not actually save anything). + +If the first argument is something else, then the function should +save according to the value of the second argument, which is the +ARG argument from `save-some-buffers'.") + (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 @@ -5801,7 +5887,10 @@ should return non-nil if that buffer should be considered. PRED defaults to the value of `save-some-buffers-default-predicate'. See `save-some-buffers-action-alist' if you want to -change the additional actions you can take on files." +change the additional actions you can take on files. + +The functions in `save-some-buffers-functions' will be called +after saving the buffers." (interactive "P") (unless pred (setq pred @@ -5817,7 +5906,7 @@ change the additional actions you can take on files." (lambda (buffer) (setq switched-buffer buffer))) queried autosaved-buffers - files-done abbrevs-done) + files-done inhibit-message) (unwind-protect (save-window-excursion (dolist (buffer (buffer-list)) @@ -5833,64 +5922,42 @@ change the additional actions you can take on files." (setq files-done (map-y-or-n-p (lambda (buffer) - ;; Note that killing some buffers may kill others via - ;; hooks (e.g. Rmail and its viewing buffer). - (and (buffer-live-p buffer) - (buffer-modified-p buffer) - (not (buffer-base-buffer buffer)) - (or - (buffer-file-name buffer) - (with-current-buffer buffer - (or (eq buffer-offer-save 'always) - (and pred buffer-offer-save - (> (buffer-size) 0))))) - (or (not (functionp pred)) - (with-current-buffer buffer (funcall pred))) - (if arg - t - (setq queried t) - (if (buffer-file-name buffer) - (if (or - (equal (buffer-name buffer) - (file-name-nondirectory - (buffer-file-name buffer))) - (string-match - (concat "\\<" - (regexp-quote - (file-name-nondirectory - (buffer-file-name buffer))) - "<[^>]*>\\'") - (buffer-name buffer))) - ;; The buffer name is similar to the - ;; file name. - (format "Save file %s? " - (buffer-file-name buffer)) - ;; The buffer and file names are - ;; dissimilar; display both. - (format "Save file %s (buffer %s)? " - (buffer-file-name buffer) - (buffer-name buffer))) - ;; No file name - (format "Save buffer %s? " (buffer-name buffer)))))) + (if arg + t + (setq queried t) + (if (buffer-file-name buffer) + (if (or + (equal (buffer-name buffer) + (file-name-nondirectory + (buffer-file-name buffer))) + (string-match + (concat "\\<" + (regexp-quote + (file-name-nondirectory + (buffer-file-name buffer))) + "<[^>]*>\\'") + (buffer-name buffer))) + ;; The buffer name is similar to the file + ;; name. + (format "Save file %s? " + (buffer-file-name buffer)) + ;; The buffer and file names are dissimilar; + ;; display both. + (format "Save file %s (buffer %s)? " + (buffer-file-name buffer) + (buffer-name buffer))) + ;; No file name. + (format "Save buffer %s? " (buffer-name buffer))))) (lambda (buffer) (with-current-buffer buffer (save-buffer))) - (buffer-list) + (files--buffers-needing-to-be-saved pred) '("buffer" "buffers" "save") save-some-buffers-action-alist)) - ;; Maybe to save abbrevs, and record whether - ;; we either saved them or asked to. - (and save-abbrevs abbrevs-changed - (progn - (if (or arg - (eq save-abbrevs 'silently) - (y-or-n-p (format "Save abbrevs in %s? " - abbrev-file-name))) - (write-abbrev-file nil)) - ;; Don't keep bothering user if he says no. - (setq abbrevs-changed nil) - (setq abbrevs-done t))) - (or queried (> files-done 0) abbrevs-done + ;; Allow other things to be saved at this time, like abbrevs. + (dolist (func save-some-buffers-functions) + (setq inhibit-message (or (funcall func nil arg) inhibit-message))) + (or queried (> files-done 0) inhibit-message (cond ((null autosaved-buffers) (when (called-interactively-p 'any) @@ -6186,6 +6253,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 @@ -7138,16 +7228,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))))) @@ -7162,11 +7252,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) @@ -7619,21 +7716,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. @@ -7688,18 +7771,34 @@ prompt the user before killing them." :group 'convenience :version "26.1") -(defun save-buffers-kill-emacs (&optional arg) +(defun save-buffers-kill-emacs (&optional arg restart) "Offer to save each buffer, then kill this Emacs process. With prefix ARG, silently save all file-visiting buffers without asking. If there are active processes where `process-query-on-exit-flag' returns non-nil and `confirm-kill-processes' is non-nil, asks whether processes should be killed. + Runs the members of `kill-emacs-query-functions' in turn and stops -if any returns nil. If `confirm-kill-emacs' is non-nil, calls it." +if any returns nil. If `confirm-kill-emacs' is non-nil, calls it. + +If RESTART, restart Emacs after killing the current Emacs process." (interactive "P") ;; Don't use save-some-buffers-default-predicate, because we want ;; to ask about all the buffers before killing Emacs. - (save-some-buffers arg t) + (when (or (files--buffers-needing-to-be-saved t) + (catch 'need-save + (dolist (func save-some-buffers-functions) + (when (funcall func 'query) + (throw 'need-save t))))) + (if (use-dialog-box-p) + (pcase (x-popup-dialog + t `("Unsaved Buffers" + ("Close Without Saving" . no-save) + ("Save All" . save-all) + ("Cancel" . cancel))) + ('cancel (user-error "Exit cancelled")) + ('save-all (save-some-buffers t))) + (save-some-buffers arg t))) (let ((confirm confirm-kill-emacs)) (and (or (not (memq t (mapcar (lambda (buf) @@ -7740,7 +7839,7 @@ if any returns nil. If `confirm-kill-emacs' is non-nil, calls it." (run-hook-with-args-until-failure 'kill-emacs-query-functions) (or (null confirm) (funcall confirm "Really exit Emacs? ")) - (kill-emacs)))) + (kill-emacs nil restart)))) (defun save-buffers-kill-terminal (&optional arg) "Offer to save each buffer, then kill the current connection. @@ -7755,6 +7854,16 @@ only these files will be asked to be saved." (if (frame-parameter nil 'client) (server-save-buffers-kill-terminal arg) (save-buffers-kill-emacs arg))) + +(defun restart-emacs () + "Kill the current Emacs process and start a new one. +This goes through the same shutdown procedure as +`save-buffers-kill-emacs', but instead of killing Emacs and +exiting, it re-executes Emacs (using the same command line +arguments as the running Emacs)." + (interactive) + (save-buffers-kill-emacs nil t)) + ;; We use /: as a prefix to "quote" a file name ;; so that magic file name handlers will not apply to it. @@ -7794,10 +7903,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/find-dired.el b/lisp/find-dired.el index c67138a8006..c04545e44e9 100644 --- a/lisp/find-dired.el +++ b/lisp/find-dired.el @@ -234,8 +234,8 @@ it finishes, type \\[kill-find]." (dired-simple-subdir-alist) ;; else we have an ancient tree dired (or classic dired, where ;; this does no harm) - (setq-local dired-subdir-alist - (list (cons default-directory (point-min-marker))))) + (setq dired-subdir-alist + (list (cons default-directory (point-min-marker))))) (setq-local dired-subdir-switches find-ls-subdir-switches) (setq buffer-read-only nil) ;; Subdir headlerline must come first because the first marker in diff --git a/lisp/find-lisp.el b/lisp/find-lisp.el index d4d899aced7..0a712c0b811 100644 --- a/lisp/find-lisp.el +++ b/lisp/find-lisp.el @@ -231,8 +231,8 @@ It is a function which takes two arguments, the directory and its parent." (dired-simple-subdir-alist) ;; else we have an ancient tree dired (or classic dired, where ;; this does no harm) - (setq-local dired-subdir-alist - (list (cons default-directory (point-min-marker))))) + (setq dired-subdir-alist + (list (cons default-directory (point-min-marker))))) (find-lisp-insert-directory dir file-predicate directory-predicate 'ignore) (goto-char (point-min)) diff --git a/lisp/finder.el b/lisp/finder.el index 382bc2023f5..a2a27ea061d 100644 --- a/lisp/finder.el +++ b/lisp/finder.el @@ -1,7 +1,6 @@ ;;; finder.el --- topic & keyword-based code finder -*- lexical-binding: t -*- -;; Copyright (C) 1992, 1997-1999, 2001-2022 Free Software Foundation, -;; Inc. +;; Copyright (C) 1992-2022 Free Software Foundation, Inc. ;; Author: Eric S. Raymond <esr@snark.thyrsus.com> ;; Created: 16 Jun 1992 @@ -76,20 +75,18 @@ "Association list of the standard \"Keywords:\" headers. Each element has the form (KEYWORD . DESCRIPTION).") -(defvar finder-mode-map - (let ((map (make-sparse-keymap))) - (define-key map " " 'finder-select) - (define-key map "f" 'finder-select) - (define-key map [follow-link] 'mouse-face) - (define-key map [mouse-2] 'finder-mouse-select) - (define-key map "\C-m" 'finder-select) - (define-key map "?" 'finder-summary) - (define-key map "n" 'next-line) - (define-key map "p" 'previous-line) - (define-key map "q" 'finder-exit) - (define-key map "d" 'finder-list-keywords) - map) - "Keymap used in `finder-mode'.") +(defvar-keymap finder-mode-map + :doc "Keymap used in `finder-mode'." + "SPC" #'finder-select + "f" #'finder-select + "<follow-link>" 'mouse-face + "<mouse-2>" #'finder-mouse-select + "C-m" #'finder-select + "?" #'finder-summary + "n" #'next-line + "p" #'previous-line + "q" #'finder-exit + "d" #'finder-list-keywords) (easy-menu-define finder-mode-menu finder-mode-map "Menu for `finder-mode'." @@ -362,19 +359,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 URLs and is in a proper help + ;; buffer with navigation forward and backward, etc. (interactive (list (completing-read "Library name: " @@ -391,12 +382,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) @@ -465,10 +451,14 @@ Quit the window and kill all Finder-related buffers." (defun finder-unload-function () "Unload the Finder library." - (with-demoted-errors (unload-feature 'finder-inf t)) + (with-demoted-errors "Error unloading finder: %S" + (unload-feature 'finder-inf t)) ;; continue standard unloading nil) +(define-obsolete-function-alias 'finder-goto-xref + #'package--finder-goto-xref "29.1") + (provide 'finder) diff --git a/lisp/foldout.el b/lisp/foldout.el index 4b192a7b6aa..e00fb40e3ca 100644 --- a/lisp/foldout.el +++ b/lisp/foldout.el @@ -473,7 +473,7 @@ What happens depends on the number of mouse clicks:- "Swallow intervening mouse events so we only get the final click-count. Signal an error if the final event isn't the same type as the first one." (let ((initial-event-type (event-basic-type event))) - (while (null (sit-for (/ double-click-time 1000.0) 'nodisplay)) + (while (null (sit-for (/ (mouse-double-click-time) 1000.0) 'nodisplay)) (setq event (read--potential-mouse-event))) (or (eq initial-event-type (event-basic-type event)) (error ""))) diff --git a/lisp/follow.el b/lisp/follow.el index 6c721899d45..adf1c1b762d 100644 --- a/lisp/follow.el +++ b/lisp/follow.el @@ -1552,7 +1552,7 @@ non-first windows in Follow mode." (declare-function scroll-bar-drag "scroll-bar" (event)) (declare-function scroll-bar-scroll-up "scroll-bar" (event)) (declare-function scroll-bar-scroll-down "scroll-bar" (event)) -(declare-function mwheel-scroll "mwheel" (event)) +(declare-function mwheel-scroll "mwheel" (event &optional arg)) (defun follow-scroll-bar-toolkit-scroll (event) (interactive "e") diff --git a/lisp/font-core.el b/lisp/font-core.el index 21d6f514ab6..2b75309ff3f 100644 --- a/lisp/font-core.el +++ b/lisp/font-core.el @@ -66,7 +66,6 @@ Other variables include that for syntactic keyword fontification, functions, `font-lock-fontify-buffer-function', `font-lock-unfontify-buffer-function', `font-lock-fontify-region-function', `font-lock-unfontify-region-function', and `font-lock-inhibit-thing-lock'.") -;;;###autoload (put 'font-lock-defaults 'risky-local-variable t) (defvar font-lock-function 'font-lock-default-function diff --git a/lisp/font-lock.el b/lisp/font-lock.el index c9c390840ff..488874a1755 100644 --- a/lisp/font-lock.el +++ b/lisp/font-lock.el @@ -208,6 +208,7 @@ (require 'syntax) (eval-when-compile (require 'cl-lib)) +(eval-when-compile (require 'subr-x)) ;; Define core `font-lock' group. (defgroup font-lock '((jit-lock custom-group)) @@ -279,6 +280,47 @@ decoration for buffers in C++ mode, and level 1 decoration otherwise." (integer :tag "level" 1))))) :group 'font-lock) +(defcustom font-lock-ignore nil + "Rules to selectively disable fontifications due to `font-lock-keywords'. +If non-nil, the value should be a list of condition sets of the form + + (SYMBOL CONDITION ...) + +where: + + - SYMBOL is a symbol, usually a major or minor mode. The subsequent + CONDITIONs apply if SYMBOL is bound as variable and its value is non-nil. + If SYMBOL is a symbol of a mode, that means the buffer has that mode + enabled (for major modes, it means the buffer's major mode is derived + from SYMBOL's mode). + + - Each CONDITION can be one of the following: + - A symbol, typically a face. It matches any element of + `font-lock-keywords' that references the symbol. The symbol is + interpreted as a glob pattern; in particular, `*' matches + everything, `?' matches any single character, and `[abcd]' + matches one character from the set. + - A string. It matches any element of `font-lock-keywords' whose + MATCHER is a regexp that matches the string. This can be used to + disable fontification of a particular programming keyword. + - A form (pred FUNCTION). It matches an element of `font-lock-keywords' + if FUNCTION, when called with the element as the argument, returns + non-nil. + - A form (not CONDITION). It matches if CONDITION doesn't. + - A form (and CONDITION ...). It matches if all the provided + CONDITIONs match. + - A form (or CONDITION ...). It matches if at least one of the + provided CONDITIONs matches. + - A form (except CONDITIONs ...). This can be used only at top level + or inside an `or' clause. It undoes the effect of previous + matching CONDITIONs on the same level. + +In each buffer, fontifications due to the elements of `font-lock-keywords' +that match at least one applicable CONDITION are disabled." + :type '(alist :key-type symbol :value-type sexp) + :group 'font-lock + :version "29.1") + (defcustom font-lock-verbose nil "If non-nil, means show status messages for buffer fontification. If a number, only buffers greater than this size have fontification messages." @@ -1810,9 +1852,8 @@ If SYNTACTIC-KEYWORDS is non-nil, it means these keywords are used for (error "Font-lock trying to use keywords before setting them up")) (if (eq (car-safe keywords) t) keywords - (setq keywords - (cons t (cons keywords - (mapcar #'font-lock-compile-keyword keywords)))) + (let ((compiled (mapcar #'font-lock-compile-keyword keywords))) + (setq keywords `(t ,keywords ,@(font-lock--filter-keywords compiled)))) (if (and (not syntactic-keywords) (let ((beg-function (with-no-warnings syntax-begin-function))) (or (eq beg-function #'beginning-of-defun) @@ -1883,6 +1924,50 @@ A LEVEL of nil is equal to a LEVEL of 0, a LEVEL of t is equal to (t (car keywords)))) +(defun font-lock--match-keyword (rule keyword) + "Return non-nil if font-lock KEYWORD matches RULE. +See `font-lock-ignore' for the possible rules." + (pcase-exhaustive rule + ('* t) + ((pred symbolp) + (let ((regexp (when (string-match-p "[*?]" (symbol-name rule)) + (wildcard-to-regexp (symbol-name rule))))) + (named-let search ((obj keyword)) + (cond + ((consp obj) (or (search (car obj)) (search (cdr obj)))) + ((not regexp) (eq rule obj)) + ((symbolp obj) (string-match-p regexp (symbol-name obj))))))) + ((pred stringp) (when (stringp (car keyword)) + (string-match-p (concat "\\`\\(?:" (car keyword) "\\)") + rule))) + (`(or . ,rules) (let ((match nil)) + (while rules + (pcase-exhaustive (pop rules) + (`(except ,rule) + (when match + (setq match (not (font-lock--match-keyword rule keyword))))) + (rule + (unless match + (setq match (font-lock--match-keyword rule keyword)))))) + match)) + (`(not ,rule) (not (font-lock--match-keyword rule keyword))) + (`(and . ,rules) (seq-every-p (lambda (rule) + (font-lock--match-keyword rule keyword)) + rules)) + (`(pred ,fun) (funcall fun keyword)))) + +(defun font-lock--filter-keywords (keywords) + "Filter a list of KEYWORDS using `font-lock-ignore'." + (if-let ((rules (mapcan (pcase-lambda (`(,mode . ,rules)) + (when (or (and (boundp mode) mode) + (derived-mode-p mode)) + (copy-sequence rules))) + font-lock-ignore))) + (seq-filter (lambda (keyword) (not (font-lock--match-keyword + `(or ,@rules) keyword))) + keywords) + keywords)) + (defun font-lock-refresh-defaults () "Restart fontification in current buffer after recomputing from defaults. Recompute fontification variables using `font-lock-defaults' and @@ -1906,8 +1991,9 @@ preserve `hi-lock-mode' highlighting patterns." Sets various variables using `font-lock-defaults' and `font-lock-maximum-decoration'." ;; Set fontification defaults if not previously set for correct major mode. - (unless (and font-lock-set-defaults - (eq font-lock-major-mode major-mode)) + (when (or (not font-lock-set-defaults) + (not font-lock-major-mode) + (not (derived-mode-p font-lock-major-mode))) (setq font-lock-major-mode major-mode) (setq font-lock-set-defaults t) (let* ((defaults font-lock-defaults) @@ -2075,7 +2161,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 39aa5c5457d..6c7524891e4 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/forms.el b/lisp/forms.el index 8bfeaad1c1a..fdc44b5214f 100644 --- a/lisp/forms.el +++ b/lisp/forms.el @@ -2009,7 +2009,7 @@ It returns the highest number. Usage: (setq forms-number-of-fields (forms-enumerate - '(field1 field2 field2 ...)))" + \\='(field1 field2 field2 ...)))" (let ((the-index 0)) (while the-fields diff --git a/lisp/frame.el b/lisp/frame.el index 69119b4c24f..27f99fb7d21 100644 --- a/lisp/frame.el +++ b/lisp/frame.el @@ -702,7 +702,9 @@ Return nil if we don't know how to interpret DISPLAY." The optional argument PARAMETERS specifies additional frame parameters." (interactive (if (fboundp 'x-display-list) (list (completing-read "Make frame on display: " - (x-display-list))) + (x-display-list) nil + nil (car (x-display-list)) + nil (car (x-display-list)))) (user-error "This Emacs build does not support X displays"))) (make-frame (cons (cons 'display display) parameters))) @@ -799,7 +801,7 @@ also select the new frame." (window-state-get (frame-root-window frame)))) (default-frame-alist (seq-remove (lambda (elem) - (memq (car elem) '(name parent-id))) + (memq (car elem) frame-internal-parameters)) (frame-parameters frame))) (new-frame (make-frame))) (when windows @@ -809,12 +811,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.") @@ -879,7 +885,6 @@ the new frame according to its own rules." (error "Don't know how to interpret display %S" display))) (t window-system))) - (oldframe (selected-frame)) (params parameters) frame child-frame) @@ -897,8 +902,12 @@ the new frame according to its own rules." (dolist (p default-frame-alist) (unless (assq (car p) params) (push p params))) - -;; (setq frame-size-history '(1000)) + ;; Add parameters from `frame-inherited-parameters' unless they are + ;; overridden by explicit parameters. + (dolist (param frame-inherited-parameters) + (unless (assq param parameters) + (let ((val (frame-parameter nil param))) + (when val (push (cons param val) params))))) (when (eq (cdr (or (assq 'minibuffer params) '(minibuffer . t))) 'child-frame) @@ -931,12 +940,6 @@ the new frame according to its own rules." frame 'minibuffer (frame-root-window child-frame)))) (normal-erase-is-backspace-setup-frame frame) - ;; Inherit original frame's parameters unless they are overridden - ;; by explicit parameters. - (dolist (param frame-inherited-parameters) - (unless (assq param parameters) - (let ((val (frame-parameter oldframe param))) - (when val (set-frame-parameter frame param val))))) ;; We can run `window-configuration-change-hook' for this frame now. (frame-after-make-frame frame t) @@ -1586,6 +1589,11 @@ acquires focus to be automatically raised. Note that this minor mode controls Emacs's own auto-raise feature. Window managers that switch focus on mouse movement often have their own auto-raise feature." + ;; This isn't really a global minor mode; rather, it's local to the + ;; selected frame, but declaring it as global prevents a misleading + ;; "Auto-Raise mode enabled in current buffer" message from being + ;; displayed when it is turned on. + :global t :variable (frame-parameter nil 'auto-raise) (if (frame-parameter nil 'auto-raise) (raise-frame))) @@ -1634,6 +1642,8 @@ 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 pgtk-frame-geometry "pgtkfns.c" (&optional frame)) +(declare-function haiku-frame-geometry "haikufns.c" (&optional frame)) (defun frame-geometry (&optional frame) "Return geometric attributes of FRAME. @@ -1683,6 +1693,10 @@ and width values are in pixels. (w32-frame-geometry frame)) ((eq frame-type 'ns) (ns-frame-geometry frame)) + ((eq frame-type 'pgtk) + (pgtk-frame-geometry frame)) + ((eq frame-type 'haiku) + (haiku-frame-geometry frame)) (t (list '(outer-position 0 . 0) @@ -1713,7 +1727,7 @@ to the selected frame. Storing information about resize operations is off by default. If you set the variable `frame-size-history' like this -(setq frame-size-history '(100)) +(setq frame-size-history \\='(100)) then Emacs will save information about the next 100 significant operations affecting any frame's size in that variable. This @@ -1807,6 +1821,8 @@ 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 pgtk-frame-edges "pgtkfns.c" (&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. @@ -1830,12 +1846,18 @@ FRAME." (w32-frame-edges frame type)) ((eq frame-type 'ns) (ns-frame-edges frame type)) + ((eq frame-type 'pgtk) + (pgtk-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 pgtk-mouse-absolute-pixel-position "pgtkfns.c") +(declare-function haiku-mouse-absolute-pixel-position "haikufns.c") (defun mouse-absolute-pixel-position () "Return absolute position of mouse cursor in pixels. @@ -1850,12 +1872,18 @@ 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 'pgtk) + (pgtk-mouse-absolute-pixel-position)) + ((eq frame-type 'haiku) + (haiku-mouse-absolute-pixel-position)) (t (cons 0 0))))) +(declare-function pgtk-set-mouse-absolute-pixel-position "pgtkfns.c" (x y)) (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). @@ -1863,12 +1891,16 @@ The coordinates X and Y are interpreted in pixels relative to a position (0, 0) of the selected frame's terminal." (let ((frame-type (framep-on-display))) (cond + ((eq frame-type 'pgtk) + (pgtk-set-mouse-absolute-pixel-position x y)) ((eq frame-type 'ns) (ns-set-mouse-absolute-pixel-position x y)) ((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. @@ -1961,6 +1993,9 @@ 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)) +;; TODO: implement this on PGTK. +;; (declare-function pgtk-frame-list-z-order "pgtkfns.c" (&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. @@ -1980,11 +2015,19 @@ 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 'pgtk) + ;; This is currently not supported on PGTK. + ;; (pgtk-frame-list-z-order display) + nil) + ((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)) (declare-function ns-frame-restack "nsfns.m" (frame1 frame2 &optional above)) +(declare-function pgtk-frame-restack "pgtkfns.c" (frame1 frame2 &optional above)) +(declare-function haiku-frame-restack "haikufns.c" (frame1 frame2 &optional above)) (defun frame-restack (frame1 frame2 &optional above) "Restack FRAME1 below FRAME2. @@ -2014,7 +2057,11 @@ Some window managers may refuse to restack windows." ((eq frame-type 'w32) (w32-frame-restack frame1 frame2 above)) ((eq frame-type 'ns) - (ns-frame-restack frame1 frame2 above)))) + (ns-frame-restack frame1 frame2 above)) + ((eq frame-type 'haiku) + (haiku-frame-restack frame1 frame2 above)) + ((eq frame-type 'pgtk) + (pgtk-frame-restack frame1 frame2 above)))) (error "Cannot restack frames"))) (defun frame-size-changed-p (&optional frame) @@ -2061,8 +2108,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 pgtk)) + t) ;; We assume X, NeXTstep, GTK, and Haiku *always* have a pointing device (t (or (and (featurep 'xt-mouse) xterm-mouse-mode) @@ -2087,7 +2134,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 pgtk haiku))))) (defun display-images-p (&optional display) "Return non-nil if DISPLAY can display images. @@ -2115,7 +2162,7 @@ frame's display)." ;; a Windows DOS Box. (with-no-warnings (not (null dos-windows-version)))) - ((memq frame-type '(x w32 ns)) + ((memq frame-type '(x w32 ns pgtk)) t) (t nil)))) @@ -2125,7 +2172,7 @@ frame's display)." This means that, for example, DISPLAY can differentiate between the keybinding RET and [return]." (let ((frame-type (framep-on-display display))) - (or (memq frame-type '(x w32 ns pc)) + (or (memq frame-type '(x w32 ns pc pgtk)) ;; MS-DOS and MS-Windows terminals have built-in support for ;; function (symbol) keys (memq system-type '(ms-dos windows-nt))))) @@ -2138,7 +2185,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 pgtk)) (x-display-screens display)) (t 1)))) @@ -2158,7 +2205,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 pgtk)) (x-display-pixel-height display)) (t (frame-height (if (framep display) display (selected-frame))))))) @@ -2178,7 +2225,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 pgtk)) (x-display-pixel-width display)) (t (frame-width (if (framep display) display (selected-frame))))))) @@ -2216,7 +2263,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 pgtk)) (or (cddr (assoc (or display (frame-parameter nil 'display)) display-mm-dimensions-alist)) (cddr (assoc t display-mm-dimensions-alist)) @@ -2237,7 +2284,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 pgtk)) (or (cadr (assoc (or display (frame-parameter nil 'display)) display-mm-dimensions-alist)) (cadr (assoc t display-mm-dimensions-alist)) @@ -2255,7 +2302,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 pgtk)) (x-display-backing-store display)) (t 'not-useful)))) @@ -2268,7 +2315,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 pgtk)) (x-display-save-under display)) (t 'not-useful)))) @@ -2281,7 +2328,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 pgtk)) (x-display-planes display)) ((eq frame-type 'pc) 4) @@ -2296,7 +2343,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 pgtk)) (x-display-color-cells display)) ((eq frame-type 'pc) 16) @@ -2313,7 +2360,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 pgtk)) (x-display-visual-class display)) ((and (memq frame-type '(pc t)) (tty-display-color-p display)) @@ -2327,6 +2374,10 @@ If DISPLAY is omitted or nil, it defaults to the selected frame's display." (&optional display)) (declare-function ns-display-monitor-attributes-list "nsfns.m" (&optional terminal)) +(declare-function pgtk-display-monitor-attributes-list "pgtkfns.c" + (&optional terminal)) +(declare-function haiku-display-monitor-attributes-list "haikufns.c" + (&optional terminal)) (defun display-monitor-attributes-list (&optional display) "Return a list of physical monitor attributes on DISPLAY. @@ -2344,6 +2395,7 @@ of attribute keys and values as follows: mm-size -- Width and height in millimeters in the form of (WIDTH HEIGHT) frames -- List of frames dominated by the physical monitor + scale-factor (*) -- Scale factor (float) name (*) -- Name of the physical monitor as a string source (*) -- Source of multi-monitor information as a string @@ -2375,6 +2427,10 @@ monitors." (w32-display-monitor-attributes-list display)) ((eq frame-type 'ns) (ns-display-monitor-attributes-list display)) + ((eq frame-type 'pgtk) + (pgtk-display-monitor-attributes-list display)) + ((eq frame-type 'haiku) + (haiku-display-monitor-attributes-list display)) (t (let ((geometry (list 0 0 (display-pixel-width display) (display-pixel-height display)))) @@ -2384,6 +2440,70 @@ monitors." ,(display-mm-height display))) (frames . ,(frames-on-display-list display))))))))) +(declare-function x-device-class "term/x-win.el" (name)) +(declare-function pgtk-device-class "term/pgtk-win.el" (name)) + +(defun device-class (frame name) + "Return the class of the device NAME for an event generated on FRAME. +NAME is a string that can be the value of `last-event-device', or +nil. FRAME is a window system frame, typically the value of +`last-event-frame' when `last-event-device' was set. On some +window systems, it can also be a display name or a terminal. + +The class of a device is one of the following symbols: + + `core-keyboard' means the device is a keyboard-like device, but + any other characteristics are unknown. + + `core-pointer' means the device is a pointing device, but any + other characteristics are unknown. + + `mouse' means the device is a computer mouse. + + `trackpoint' means the device is a joystick or trackpoint. + + `eraser' means the device is an eraser, which is typically the + other end of a stylus on a graphics tablet. + + `pen' means the device is a stylus or some other similar + device. + + `puck' means the device is a device similar to a mouse, but + reports absolute coordinates. + + `power-button' means the device is a power button, volume + button, or some similar control. + + `keyboard' means the device is a keyboard. + + `touchscreen' means the device is a touchscreen. + + `pad' means the device is a collection of buttons and rings and + strips commonly found in drawing tablets. + + `touchpad' means the device is an indirect touch device, such + as a touchpad. + + `piano' means the device is a piano, or some other kind of + musical instrument. + + `test' means the device is used by the XTEST extension to + report input. + +It can also be nil, which means the class of the device could not +be determined. Individual window systems may also return other +symbols." + (let ((frame-type (framep-on-display frame))) + (cond ((eq frame-type 'x) + (x-device-class name)) + ((eq frame-type 'pgtk) + (pgtk-device-class name)) + (t (cond + ((string= name "Virtual core pointer") + 'core-pointer) + ((string= name "Virtual core keyboard") + 'core-keyboard)))))) + ;;;; Frame geometry values @@ -2485,6 +2605,77 @@ deleting them." (if iconify (iconify-frame this) (delete-frame this))) (setq this next)))) +(defvar undelete-frame--deleted-frames nil + "Internal variable used by `undelete-frame--save-deleted-frame'.") + +(defun undelete-frame--save-deleted-frame (frame) + "Save the configuration of frames deleted with `delete-frame'. +Only the 16 most recently deleted frames are saved." + (when (and after-init-time (frame-live-p frame)) + (setq undelete-frame--deleted-frames + (cons + (list + (display-graphic-p) + (seq-remove + (lambda (elem) + (or (memq (car elem) frame-internal-parameters) + ;; When the daemon is started from a graphical + ;; environment, TTY frames have a 'display' parameter set + ;; to the value of $DISPLAY (see the note in + ;; `server--on-display-p'). Do not store that parameter + ;; in the frame data, otherwise `undelete-frame' attempts + ;; to restore a graphical frame. + (and (eq (car elem) 'display) (not (display-graphic-p))))) + (frame-parameters frame)) + (window-state-get (frame-root-window frame))) + undelete-frame--deleted-frames)) + (if (> (length undelete-frame--deleted-frames) 16) + (setq undelete-frame--deleted-frames + (butlast undelete-frame--deleted-frames))))) + +(define-minor-mode undelete-frame-mode + "Enable the `undelete-frame' command." + :group 'frames + :global t + (if undelete-frame-mode + (add-hook 'delete-frame-functions + #'undelete-frame--save-deleted-frame -75) + (remove-hook 'delete-frame-functions + #'undelete-frame--save-deleted-frame) + (setq undelete-frame--deleted-frames nil))) + +(defun undelete-frame (&optional arg) + "Undelete a frame deleted with `delete-frame'. +Without a prefix argument, undelete the most recently deleted +frame. +With a numerical prefix argument ARG between 1 and 16, where 1 is +most recently deleted frame, undelete the ARGth deleted frame. +When called from Lisp, returns the new frame." + (interactive "P") + (if (not undelete-frame-mode) + (user-error "Undelete-Frame mode is disabled") + (if (consp arg) + (user-error "Missing deleted frame number argument") + (let* ((number (pcase arg ('nil 1) ('- -1) (_ arg))) + (frame-data (nth (1- number) undelete-frame--deleted-frames)) + (graphic (display-graphic-p))) + (if (not (<= 1 number 16)) + (user-error "%d is not a valid deleted frame number argument" + number) + (if (not frame-data) + (user-error "No deleted frame with number %d" number) + (if (not (eq graphic (nth 0 frame-data))) + (user-error + "Cannot undelete a %s display frame on a %s display" + (if graphic "non-graphic" "graphic") + (if graphic "graphic" "non-graphic")) + (setq undelete-frame--deleted-frames + (delq frame-data undelete-frame--deleted-frames)) + (let* ((default-frame-alist (nth 1 frame-data)) + (frame (make-frame))) + (window-state-put (nth 2 frame-data) (frame-root-window frame) 'safe) + (select-frame-set-input-focus frame) + frame)))))))) ;;; Window dividers. (defgroup window-divider nil @@ -2776,6 +2967,12 @@ If the frame is in fullscreen state, don't change its state, but set the frame's `fullscreen-restore' parameter to `maximized', so the frame will be maximized after disabling fullscreen state. +If you wish to hide the title bar when the frame is maximized, you +can add something like the following to your init file: + + (add-hook \\='window-size-change-functions + #\\='frame-hide-title-bar-when-maximized) + Note that with some window managers you may have to set `frame-resize-pixelwise' to non-nil in order to make a frame appear truly maximized. In addition, you may have to set @@ -2829,6 +3026,7 @@ See also `toggle-frame-maximized'." (define-key ctl-x-5-map "o" #'other-frame) (define-key ctl-x-5-map "5" #'other-frame-prefix) (define-key ctl-x-5-map "c" #'clone-frame) +(define-key ctl-x-5-map "u" #'undelete-frame) (define-key global-map [f11] #'toggle-frame-fullscreen) (define-key global-map [(meta f10)] #'toggle-frame-maximized) (define-key esc-map [f10] #'toggle-frame-maximized) @@ -2890,6 +3088,13 @@ Offer NUMBER as default value, if it is a natural number." bidi-display-reordering bidi-inhibit-bpa)) +(defun frame-hide-title-bar-when-maximized (frame) + "Hide the title bar if FRAME is maximized. +If FRAME isn't maximized, show the title bar." + (set-frame-parameter + frame 'undecorated + (eq (alist-get 'fullscreen (frame-parameters frame)) 'maximized))) + (provide 'frame) ;;; frame.el ends here diff --git a/lisp/frameset.el b/lisp/frameset.el index 10714af1fa5..a589f7b5d96 100644 --- a/lisp/frameset.el +++ b/lisp/frameset.el @@ -436,10 +436,11 @@ Properties can be set with ;;;###autoload (defvar frameset-session-filter-alist - '((name . :never) - (left . frameset-filter-iconified) - (minibuffer . frameset-filter-minibuffer) - (top . frameset-filter-iconified)) + (append + '((left . frameset-filter-iconified) + (minibuffer . frameset-filter-minibuffer) + (top . frameset-filter-iconified)) + (mapcar (lambda (p) (cons p :never)) frame-internal-parameters)) "Minimum set of parameters to filter for live (on-session) framesets. DO NOT MODIFY. See `frameset-filter-alist' for a full description.") @@ -447,6 +448,7 @@ DO NOT MODIFY. See `frameset-filter-alist' for a full description.") (defvar frameset-persistent-filter-alist (append '((background-color . frameset-filter-sanitize-color) + (bottom . frameset-filter-shelve-param) (buffer-list . :never) (buffer-predicate . :never) (buried-buffer-list . :never) @@ -463,19 +465,23 @@ DO NOT MODIFY. See `frameset-filter-alist' for a full description.") (frameset--text-pixel-height . :save) (frameset--text-pixel-width . :save) (fullscreen . frameset-filter-shelve-param) + (GUI:bottom . frameset-filter-unshelve-param) (GUI:font . frameset-filter-unshelve-param) (GUI:fullscreen . frameset-filter-unshelve-param) (GUI:height . frameset-filter-unshelve-param) + (GUI:left . frameset-filter-unshelve-param) + (GUI:right . frameset-filter-unshelve-param) + (GUI:top . frameset-filter-unshelve-param) (GUI:width . frameset-filter-unshelve-param) (height . frameset-filter-shelve-param) - (outer-window-id . :never) + (left . frameset-filter-shelve-param) (parent-frame . :never) - (parent-id . :never) (mouse-wheel-frame . :never) + (right . frameset-filter-shelve-param) + (top . frameset-filter-shelve-param) (tty . frameset-filter-tty-to-GUI) (tty-type . frameset-filter-tty-to-GUI) (width . frameset-filter-shelve-param) - (window-id . :never) (window-system . :never)) frameset-session-filter-alist) "Parameters to filter for persistent framesets. @@ -1012,13 +1018,15 @@ not be changed once the frame has been created. Internal use only." (cl-loop for param in '(left top width height border-width minibuffer) when (assq param parameters) collect it)) -(defun frameset--restore-frame (parameters window-state filters force-onscreen) +(defun frameset--restore-frame (parameters window-state filters force-onscreen + &optional dx dy) "Set up and return a frame according to its saved state. That means either reusing an existing frame or creating one anew. PARAMETERS is the frame's parameter alist; WINDOW-STATE is its window state. For the meaning of FILTERS and FORCE-ONSCREEN, see `frameset-restore'. Internal use only." (let* ((fullscreen (cdr (assq 'fullscreen parameters))) + (tty-to-GUI (frameset-switch-to-gui-p parameters)) (filtered-cfg (frameset-filter-params parameters filters nil)) (display (cdr (assq 'display filtered-cfg))) ;; post-filtering alt-cfg frame) @@ -1095,6 +1103,14 @@ Internal use only." (not (eq (frame-parameter frame 'visibility) 'icon))) (frameset-move-onscreen frame force-onscreen)) + ;; Frames saved on TTY shall be all considered visible when + ;; restoring on GUI display. Also, offset each new such frame + ;; relative to the previous one, to make it more visible. + (when tty-to-GUI + (push '(visibility . t) alt-cfg) + (when (and (numberp dx) (numberp dy)) + (push (cons 'left (+ (frame-parameter frame 'left) dx)) alt-cfg) + (push (cons 'top (+ (frame-parameter frame 'top) dy)) alt-cfg))) ;; Let's give the finishing touches (visibility, maximization). (when alt-cfg (modify-frame-parameters frame alt-cfg)) ;; Now restore window state. @@ -1218,7 +1234,9 @@ All keyword parameters default to nil." ((pred functionp) (cl-remove-if-not reuse-frames frames)) (_ - (error "Invalid arg :reuse-frames %s" reuse-frames))))) + (error "Invalid arg :reuse-frames %s" reuse-frames)))) + (dx 0) + (dy 0)) ;; Mark existing frames in the map; candidates to reuse are marked as :ignored; ;; they will be reassigned later, if chosen. @@ -1291,11 +1309,21 @@ All keyword parameters default to nil." (setq mb-window nil))) (when mb-window (push (cons 'minibuffer mb-window) frame-cfg)))))) + ;; Apply small offsets to each frame that came from + ;; a TTY-saved desktop, so that they don't obscure + ;; each other, but only if we don't have real frame + ;; position info from a GUI session in some, + ;; possibly distant, past. + (when (and (frameset-switch-to-gui-p frame-cfg) + (null (cdr (assq 'GUI:top frame-cfg))) + (null (cdr (assq 'GUI:left frame-cfg)))) + (setq dx (+ dx 20) + dy (+ dy 10))) ;; OK, we're ready at last to create (or reuse) a frame and ;; restore the window config. (setq frame (frameset--restore-frame frame-cfg window-cfg (or filters frameset-filter-alist) - force-onscreen)) + force-onscreen dx dy)) ;; Now reset any duplicate frameset--id (when (and duplicate (not (eq frame duplicate))) (set-frame-parameter duplicate 'frameset--id nil)) diff --git a/lisp/fringe.el b/lisp/fringe.el index 8c833f02429..657a73772d5 100644 --- a/lisp/fringe.el +++ b/lisp/fringe.el @@ -244,10 +244,18 @@ When used in a Lisp program, MODE should be one of these: nil (meaning the default width). - a single integer, which specifies the pixel widths of both fringes. + This command may round up the left and right width specifications to ensure that their sum is a multiple of the character width of a frame. It never rounds up a fringe width of 0. +Note that removing a right or left fringe (by setting the width +to zero) makes Emacs reserve one column of the window body to +display a line continuation marker. (This happens for both the +left and right fringe, since Emacs can display both left-to-right +and right-to-left text.) You can use `window-max-chars-per-line' +to check the effective width. + Fringe widths set by `set-window-fringes' override the default fringe widths set by this command. This command applies to all frames that exist and frames to be created in the future. If you @@ -306,7 +314,7 @@ BITMAP is a symbol identifying the new fringe bitmap. BITS is either a string or a vector of integers. HEIGHT is height of bitmap. If HEIGHT is nil, use length of BITS. WIDTH must be an integer between 1 and 16, or nil which defaults to 8. -Optional fifth arg ALIGN may be one of ‘top’, ‘center’, or ‘bottom’, +Optional fifth arg ALIGN may be one of `top', `center', or `bottom', indicating the positioning of the bitmap relative to the rows where it is used; the default is to center the bitmap. Fifth arg may also be a list (ALIGN PERIODIC) where PERIODIC non-nil specifies that the bitmap diff --git a/lisp/generic-x.el b/lisp/generic-x.el index ecfa8aab845..2c9d1b316e1 100644 --- a/lisp/generic-x.el +++ b/lisp/generic-x.el @@ -1847,4 +1847,8 @@ like an INI file. You can add this hook to `find-file-hook'." (provide 'generic-x) +;; Local Variables: +;; autoload-compute-prefixes: nil +;; End: + ;;; generic-x.el ends here diff --git a/lisp/gnus/deuglify.el b/lisp/gnus/deuglify.el index d2edfdf09f4..732c6062b8b 100644 --- a/lisp/gnus/deuglify.el +++ b/lisp/gnus/deuglify.el @@ -439,6 +439,7 @@ If NODISPLAY is non-nil, don't redisplay the article buffer." (unless nodisplay (gnus-outlook-display-article-buffer)) attrib-start)) +;;;###autoload (defun gnus-article-outlook-rearrange-citation (&optional nodisplay) "Repair broken citations. If NODISPLAY is non-nil, don't redisplay the article buffer." diff --git a/lisp/gnus/gmm-utils.el b/lisp/gnus/gmm-utils.el index e93ebb0cd38..fc18d8a1c51 100644 --- a/lisp/gnus/gmm-utils.el +++ b/lisp/gnus/gmm-utils.el @@ -134,47 +134,8 @@ ARGS are passed to `message'." (const :tag "No map") (plist :inline t :tag "Properties")))) -(define-widget 'gmm-tool-bar-zap-list 'lazy - "Tool bar zap list." - :tag "Tool bar zap list" - :type '(choice (const :tag "Zap all" t) - (const :tag "Keep all" nil) - (list - ;; :value - ;; Work around (bug in customize?), see - ;; <news:v9is48jrj1.fsf@marauder.physik.uni-ulm.de> - ;; (new-file open-file dired kill-buffer write-file - ;; print-buffer customize help) - (set :inline t - (const new-file) - (const open-file) - (const dired) - (const kill-buffer) - (const save-buffer) - (const write-file) - (const undo) - (const cut) - (const copy) - (const paste) - (const search-forward) - (const print-buffer) - (const customize) - (const help)) - (repeat :inline t - :tag "Other" - (symbol :tag "Icon item"))))) - -(defcustom gmm-tool-bar-style - (if (and (boundp 'tool-bar-mode) - tool-bar-mode - (not (memq (display-visual-class) - (list 'static-gray 'gray-scale - 'static-color 'pseudo-color)))) - 'gnome - 'retro) - "Preferred tool bar style." - :type '(choice (const :tag "GNOME style" gnome) - (const :tag "Retro look" retro))) +(defvar gmm-tool-bar-style 'gnome) +(make-obsolete-variable 'gmm-tool-bar-style nil "29.1") (defvar tool-bar-map) @@ -239,6 +200,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 86a4f80483d..e4704b35c8d 100644 --- a/lisp/gnus/gnus-agent.el +++ b/lisp/gnus/gnus-agent.el @@ -31,6 +31,7 @@ (require 'gnus-srvr) (require 'gnus-util) (require 'timer) +(require 'range) (eval-when-compile (require 'cl-lib)) (autoload 'gnus-server-update-server "gnus-srvr") @@ -475,17 +476,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 +504,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 +526,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) @@ -1222,8 +1220,8 @@ This can be added to `gnus-select-article-hook' or (cond ((eq mark 'read) (setf (gnus-info-read info) (funcall (if (eq what 'add) - #'gnus-range-add - #'gnus-remove-from-range) + #'range-concat + #'range-remove) (gnus-info-read info) range)) (gnus-get-unread-articles-in-group @@ -1236,8 +1234,8 @@ This can be added to `gnus-select-article-hook' or (gnus-info-marks info))) (setcdr info-marks (funcall (if (eq what 'add) - #'gnus-range-add - #'gnus-remove-from-range) + #'range-concat + #'range-remove) (cdr info-marks) range)))))))) @@ -1310,7 +1308,7 @@ downloaded into the agent." (let ((read (gnus-info-read info))) (setf (gnus-info-read info) - (gnus-range-add + (range-concat read (list (cons (1+ agent-max) (1- active-min)))))) @@ -1799,13 +1797,13 @@ article numbers will be returned." (articles (if fetch-all (if gnus-newsgroup-maximum-articles (let ((active (gnus-active group))) - (gnus-uncompress-range + (range-uncompress (cons (max (car active) (- (cdr active) gnus-newsgroup-maximum-articles -1)) (cdr active)))) - (gnus-uncompress-range (gnus-active group))) + (range-uncompress (gnus-active group))) (gnus-list-of-unread-articles group))) (gnus-decode-encoded-word-function 'identity) (gnus-decode-encoded-address-function 'identity) @@ -1820,7 +1818,7 @@ article numbers will be returned." ;; because otherwise the agent will remove their marks.) (dolist (arts (gnus-info-marks (gnus-get-info group))) (unless (memq (car arts) '(seen recent killed cache)) - (setq articles (gnus-range-add articles (cdr arts))))) + (setq articles (range-concat articles (cdr arts))))) (setq articles (sort (gnus-uncompress-sequence articles) #'<))) ;; At this point, I have the list of articles to consider for @@ -1854,15 +1852,15 @@ article numbers will be returned." ;; gnus-agent-article-alist) equals (cdr (gnus-active ;; group))}. The addition of one(the 1+ above) then ;; forces Low to be greater than High. When this happens, - ;; gnus-list-range-intersection returns nil which + ;; range-list-intersection returns nil which ;; indicates that no headers need to be fetched. -- Kevin - (setq articles (gnus-list-range-intersection + (setq articles (range-list-intersection articles (list (cons low high))))))) (when articles (gnus-message 10 "gnus-agent-fetch-headers: undownloaded articles are `%s'" - (gnus-compress-sequence articles t))) + (range-compress-list articles))) (with-current-buffer nntp-server-buffer (if articles @@ -2063,7 +2061,7 @@ doesn't exist, to valid the overview buffer." (let (state sequence uncomp) (while alist (setq state (caar alist) - sequence (inline (gnus-uncompress-range (cdar alist))) + sequence (inline (range-uncompress (cdar alist))) alist (cdr alist)) (while sequence (push (cons (pop sequence) state) uncomp))) @@ -2407,7 +2405,7 @@ contents, they are first saved to their own file." (let ((arts (cdr (assq mark (gnus-info-marks (setq info (gnus-get-info group))))))) (when arts - (setq marked-articles (nconc (gnus-uncompress-range arts) + (setq marked-articles (nconc (range-uncompress arts) marked-articles)) )))) (setq marked-articles (sort marked-articles #'<)) @@ -2547,7 +2545,7 @@ contents, they are first saved to their own file." (let ((read (gnus-info-read (or info (setq info (gnus-get-info group)))))) (setf (gnus-info-read info) - (gnus-add-to-range read unfetched-articles))) + (range-add-list read unfetched-articles))) (gnus-group-update-group group t) (sit-for 0) @@ -2597,25 +2595,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." @@ -2906,8 +2899,8 @@ The following commands are available: (defun gnus-agent-read-p () "Say whether an article is read or not." - (gnus-member-of-range (mail-header-number gnus-headers) - (gnus-info-read (gnus-get-info gnus-newsgroup-name)))) + (range-member-p (mail-header-number gnus-headers) + (gnus-info-read (gnus-get-info gnus-newsgroup-name)))) (defun gnus-category-make-function (predicate) "Make a function from PREDICATE." @@ -3123,7 +3116,7 @@ FORCE is equivalent to setting the expiration predicates to true." ;; All articles EXCEPT those named by the caller ;; are protected from expiration (gnus-sorted-difference - (gnus-uncompress-range + (range-uncompress (cons (caar alist) (caar (last alist)))) (sort articles #'<))))) @@ -3145,9 +3138,9 @@ FORCE is equivalent to setting the expiration predicates to true." ;; Ticked and/or dormant articles are excluded ;; from expiration (nconc - (gnus-uncompress-range + (range-uncompress (cdr (assq 'tick (gnus-info-marks info)))) - (gnus-uncompress-range + (range-uncompress (cdr (assq 'dormant (gnus-info-marks info)))))))) (nov-file (concat dir ".overview")) @@ -3646,7 +3639,7 @@ has been fetched." (file-name-directory file) t)) (when fetch-old - (setq articles (gnus-uncompress-range + (setq articles (range-uncompress (cons (if (numberp fetch-old) (max 1 (- (car articles) fetch-old)) 1) @@ -3702,7 +3695,7 @@ has been fetched." ;; Clip this list to the headers that will ;; actually be returned - (setq fetched-articles (gnus-list-range-intersection + (setq fetched-articles (range-list-intersection (cdr fetched-articles) (cons min max))) @@ -3711,7 +3704,7 @@ has been fetched." ;; excluded IDs may be fetchable using HEAD. (if (car tail-fetched-articles) (setq uncached-articles - (gnus-list-range-intersection + (range-list-intersection uncached-articles (cons (car uncached-articles) (car tail-fetched-articles))))) diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 5b5343f5bcd..59c3bbc76ed 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -42,6 +42,7 @@ (require 'message) (require 'mouse) (require 'seq) +(require 'range) (autoload 'gnus-msg-mail "gnus-msg" nil t) (autoload 'gnus-button-mailto "gnus-msg") @@ -768,28 +769,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 +807,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 +822,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 +835,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) @@ -1149,13 +1160,15 @@ predicate. See Info node `(gnus)Customizing Articles'." :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-head-custom) -(defcustom gnus-treat-emphasize 50000 +(defcustom gnus-treat-emphasize '(and 50000 + (not (typep "text/html"))) "Emphasize text. Valid values are nil, t, `head', `first', `last', an integer or a predicate. See Info node `(gnus)Customizing Articles'." :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") - :type gnus-article-treat-custom) + :type gnus-article-treat-custom + :version "29.1") (put 'gnus-treat-emphasize 'highlight t) (defcustom gnus-treat-strip-cr nil @@ -1167,6 +1180,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 +1386,20 @@ 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) + +(defcustom gnus-treat-suspicious-headers 'head + "Mark headers that are suspicious. +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) @@ -1650,6 +1685,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) @@ -1685,6 +1721,7 @@ regexp." (gnus-treat-unfold-headers gnus-article-treat-unfold-headers) (gnus-treat-fold-newsgroups gnus-article-treat-fold-newsgroups) (gnus-treat-fold-headers gnus-article-treat-fold-headers) + (gnus-treat-suspicious-headers gnus-article-treat-suspicious-headers) (gnus-treat-buttonize-head gnus-article-add-buttons-to-head) (gnus-treat-display-smileys gnus-treat-smiley) (gnus-treat-capitalize-sentences gnus-article-capitalize-sentences) @@ -2188,6 +2225,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,9 +2240,26 @@ 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-article-treat-suspicious-headers () + "Mark suspicious headers." + (interactive nil gnus-article-mode gnus-summary-mode) + (gnus-with-article-headers + (let (match) + (while (setq match (text-property-search-forward 'textsec-suspicious)) + (add-text-properties (prop-match-beginning match) + (prop-match-end match) + (list 'help-echo (prop-match-value match) + 'face 'textsec-suspicious)) + (overlay-put (make-overlay (prop-match-end match) + (prop-match-end match)) + 'after-string "⚠️"))))) + (defun gnus-treat-smiley () "Toggle display of textual emoticons (\"smileys\") as small graphical icons." (interactive nil gnus-article-mode gnus-summary-mode) @@ -2264,9 +2326,7 @@ This only works if the article in question is HTML." (goto-char (point-max)))))) (defcustom gnus-article-truncate-lines (default-value 'truncate-lines) - "Value of `truncate-lines' in Gnus Article buffer. -Valid values are nil, t, `head', `first', `last', an integer or a -predicate. See Info node `(gnus)Customizing Articles'." + "Value of `truncate-lines' in Gnus Article buffer." :version "23.1" ;; No Gnus :group 'gnus-article ;; :link '(custom-manual "(gnus)Customizing Articles") @@ -2360,6 +2420,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) @@ -2560,17 +2634,37 @@ If PROMPT (the prefix), prompt for a coding system to use." (forward-line -1)) (setq end (point)) (while (not (bobp)) - (while (progn - (forward-line -1) - (and (not (bobp)) - (memq (char-after) '(?\t ? ))))) - (setq start (point)) - (if (looking-at "\ + (let (addresses) + (while (progn + (forward-line -1) + (and (not (bobp)) + (memq (char-after) '(?\t ? ))))) + (setq start (point)) + (save-restriction + (narrow-to-region start end) + (if (looking-at "\ \\(?:Resent-\\)?\\(?:From\\|Cc\\|To\\|Bcc\\|\\(?:In-\\)?Reply-To\\|Sender\ \\|Mail-Followup-To\\|Mail-Copies-To\\|Approved\\):") - (funcall gnus-decode-address-function start end) - (funcall gnus-decode-header-function start end)) - (goto-char (setq end start))))) + (progn + (setq addresses (buffer-string)) + (funcall gnus-decode-address-function (point-min) (point-max))) + (funcall gnus-decode-header-function (point-min) (point-max)))) + (when addresses + (article--check-suspicious-addresses addresses)) + (goto-char (point-max)) + (goto-char (setq end start)))))) + +(defun article--check-suspicious-addresses (addresses) + (setq addresses (replace-regexp-in-string "\\`[^:]+:[ \t\n]*" "" addresses)) + (dolist (header (mail-header-parse-addresses addresses t)) + (when-let* ((address (car (ignore-errors + (mail-header-parse-address header)))) + (warning (and (string-match "@" address) + (textsec-suspicious-p address 'email-address)))) + (goto-char (point-min)) + (while (search-forward address nil t) + (put-text-property (match-beginning 0) (match-end 0) + 'textsec-suspicious warning))))) (defun article-decode-group-name () "Decode group names in Newsgroups, Followup-To and Xref headers." @@ -3933,8 +4027,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 +4037,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 +4050,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 +4435,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 +4481,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 +4543,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 +4604,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 +4645,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 +4670,7 @@ commands: (current-buffer)))))) (defun gnus-article-stop-animations () + (declare (obsolete nil "29.1")) (cancel-function-timers 'image-animate-timeout)) (defun gnus-stop-downloads () @@ -6033,6 +6129,34 @@ If nil, don't show those extra buttons." ((equal (car handle) "multipart/encrypted") (gnus-add-wash-type 'encrypted) (gnus-mime-display-security handle)) + ;; pkcs7-mime handling: + ;; + ;; although not really multipart these are structured internally by + ;; mm-dissect-buffer like multipart to not discard the decryption + ;; and verification results + ;; + ;; application/pkcs7-mime + ((and (equal (car handle) "application/pkcs7-mime") + (equal (mm-handle-multipart-ctl-parameter handle 'protocol) + "application/pkcs7-mime_signed-data")) + (gnus-add-wash-type 'signed) + (gnus-mime-display-security handle)) + ((and (equal (car handle) "application/pkcs7-mime") + (equal (mm-handle-multipart-ctl-parameter handle 'protocol) + "application/pkcs7-mime_enveloped-data")) + (gnus-add-wash-type 'encrypted) + (gnus-mime-display-security handle)) + ;; application/x-pkcs7-mime + ((and (equal (car handle) "application/x-pkcs7-mime") + (equal (mm-handle-multipart-ctl-parameter handle 'protocol) + "application/x-pkcs7-mime_signed-data")) + (gnus-add-wash-type 'signed) + (gnus-mime-display-security handle)) + ((and (equal (car handle) "application/x-pkcs7-mime") + (equal (mm-handle-multipart-ctl-parameter handle 'protocol) + "application/x-pkcs7-mime_enveloped-data")) + (gnus-add-wash-type 'encrypted) + (gnus-mime-display-security handle)) ;; Other multiparts are handled like multipart/mixed. (t (gnus-mime-display-mixed (cdr handle))))) @@ -6045,7 +6169,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 @@ -6938,7 +7062,7 @@ then we display only bindings that start with that prefix." (setq sumkeys (append (mapcar #'vector - (nreverse (gnus-uncompress-range def))) + (nreverse (range-uncompress def))) sumkeys)))) ((setq def (key-binding key)) (unless (eq def 'undefined) @@ -7222,50 +7346,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 "" @@ -7864,8 +7980,8 @@ variable is the real callback function." (function :tag "Callback") (repeat :tag "Par" :inline t - (integer :tag "Regexp group"))))) -(put 'gnus-button-alist 'risky-local-variable t) + (integer :tag "Regexp group")))) + :risky t) (defcustom gnus-header-button-alist '(("^\\(References\\|Message-I[Dd]\\|^In-Reply-To\\):" "<[^<>]+>" @@ -7904,8 +8020,8 @@ HEADER is a regexp to match a header. For a fuller explanation, see (function :tag "Callback") (repeat :tag "Par" :inline t - (integer :tag "Regexp group"))))) -(put 'gnus-header-button-alist 'risky-local-variable t) + (integer :tag "Regexp group")))) + :risky t) ;;; Commands: @@ -8790,11 +8906,19 @@ For example: (setq point (point)) (with-current-buffer (mm-handle-multipart-original-buffer handle) (let* ((mm-verify-option 'known) - (mm-decrypt-option 'known) - (nparts (mm-possibly-verify-or-decrypt (cdr handle) handle))) - (unless (eq nparts (cdr handle)) - (mm-destroy-parts (cdr handle)) - (setcdr handle nparts)))) + (mm-decrypt-option 'known) + (pkcs7-mime-p (or (equal (car handle) "application/pkcs7-mime") + (equal (car handle) "application/x-pkcs7-mime"))) + (nparts (if pkcs7-mime-p + (list (mm-possibly-verify-or-decrypt + (cadr handle) (cadadr handle))) + (mm-possibly-verify-or-decrypt (cdr handle) handle)))) + (unless (eq nparts (cdr handle)) + ;; if pkcs7-mime don't destroy the parts as the buffer in + ;; the cdr still needs to be accessible + (when (not pkcs7-mime-p) + (mm-destroy-parts (cdr handle))) + (setcdr handle nparts)))) (gnus-mime-display-security handle) (when region (delete-region (point) (cdr region)) @@ -8848,14 +8972,35 @@ For example: (let* ((protocol (mm-handle-multipart-ctl-parameter handle 'protocol)) (gnus-tmp-type (concat - (or (nth 2 (assoc protocol mm-verify-function-alist)) - (nth 2 (assoc protocol mm-decrypt-function-alist)) - "Unknown") - (if (equal (car handle) "multipart/signed") - " Signed" " Encrypted") - " Part")) - (gnus-tmp-info - (or (mm-handle-multipart-ctl-parameter handle 'gnus-info) + (or (nth 2 (assoc protocol mm-verify-function-alist)) + (nth 2 (assoc protocol mm-decrypt-function-alist)) + "Unknown") + (cond ((equal (car handle) "multipart/signed") " Signed") + ((equal (car handle) "multipart/encrypted") " Encrypted") + ((and (equal (car handle) "application/pkcs7-mime") + (equal + (mm-handle-multipart-ctl-parameter handle 'protocol) + "application/pkcs7-mime_signed-data")) + " Signed") + ((and (equal (car handle) "application/pkcs7-mime") + (equal + (mm-handle-multipart-ctl-parameter handle 'protocol) + "application/pkcs7-mime_enveloped-data")) + " Encrypted") + ;; application/x-pkcs7-mime + ((and (equal (car handle) "application/x-pkcs7-mime") + (equal + (mm-handle-multipart-ctl-parameter handle 'protocol) + "application/x-pkcs7-mime_signed-data")) + " Signed") + ((and (equal (car handle) "application/x-pkcs7-mime") + (equal + (mm-handle-multipart-ctl-parameter handle 'protocol) + "application/x-pkcs7-mime_enveloped-data")) + " Encrypted")) + " Part")) + (gnus-tmp-info + (or (mm-handle-multipart-ctl-parameter handle 'gnus-info) "Undecided")) (gnus-tmp-details (mm-handle-multipart-ctl-parameter handle 'gnus-details)) diff --git a/lisp/gnus/gnus-bookmark.el b/lisp/gnus/gnus-bookmark.el index 98e9bb996bc..4f5b9bd3422 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-cloud.el b/lisp/gnus/gnus-cloud.el index 6ed9e32c919..9bd9f2155f7 100644 --- a/lisp/gnus/gnus-cloud.el +++ b/lisp/gnus/gnus-cloud.el @@ -30,6 +30,7 @@ (require 'parse-time) (require 'nnimap) +(require 'range) (eval-when-compile (require 'epg)) ;; setf-method for `epg-context-armor' (autoload 'epg-make-context "epg") @@ -404,7 +405,7 @@ When FULL is t, upload everything, not just a difference from the last full." (let* ((group (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method)) (active (gnus-active group)) headers head) - (when (gnus-retrieve-headers (gnus-uncompress-range active) group) + (when (gnus-retrieve-headers (range-uncompress active) group) (with-current-buffer nntp-server-buffer (goto-char (point-min)) (while (setq head (nnheader-parse-head)) diff --git a/lisp/gnus/gnus-dired.el b/lisp/gnus/gnus-dired.el index 2953b61f04e..3d8882b1a55 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 1228d74cb51..56d498cc4d3 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) @@ -203,7 +200,7 @@ Obeys the standard process/prefix convention." (gnus-activate-group "nndraft:queue") (save-excursion (let* ((articles (nndraft-articles)) - (unsendable (gnus-uncompress-range + (unsendable (range-uncompress (cdr (assq 'unsend (gnus-info-marks (gnus-get-info "nndraft:queue")))))) diff --git a/lisp/gnus/gnus-eform.el b/lisp/gnus/gnus-eform.el index dc10e3cbce0..300532de286 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 8e12b1cb4bd..04d19e29a3a 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -35,6 +35,7 @@ (require 'gnus-undo) (require 'gmm-utils) (require 'time-date) +(require 'range) (eval-when-compile (require 'mm-url) @@ -62,7 +63,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. @@ -380,8 +381,8 @@ variables in the Lisp expression: `group-age': Time in seconds since the group was last read (see info node `(gnus)Group Timestamp')." :group 'gnus-group-visual - :type '(repeat (cons (sexp :tag "Form") face))) -(put 'gnus-group-highlight 'risky-local-variable t) + :type '(repeat (cons (sexp :tag "Form") face)) + :risky t) (defcustom gnus-new-mail-mark ?% "Mark used for groups with new mail." @@ -409,8 +410,8 @@ requires an understanding of Lisp expressions. Hopefully this will change in a future release. For now, you can use the same variables in the Lisp expression as in `gnus-group-highlight'." :group 'gnus-group-icons - :type '(repeat (cons (sexp :tag "Form") file))) -(put 'gnus-group-icon-list 'risky-local-variable t) + :type '(repeat (cons (sexp :tag "Form") file)) + :risky t) (defcustom gnus-group-name-charset-method-alist nil "Alist of method and the charset for group names. @@ -512,8 +513,8 @@ simple manner." ((numberp number) (int-to-string (+ number - (gnus-range-length (cdr (assq 'dormant gnus-tmp-marked))) - (gnus-range-length (cdr (assq 'tick gnus-tmp-marked)))))) + (range-length (cdr (assq 'dormant gnus-tmp-marked))) + (range-length (cdr (assq 'tick gnus-tmp-marked)))))) (t number)) ?s) (?R gnus-tmp-number-of-read ?s) @@ -523,10 +524,10 @@ simple manner." ?s) (?t gnus-tmp-number-total ?d) (?y gnus-tmp-number-of-unread ?s) - (?I (gnus-range-length (cdr (assq 'dormant gnus-tmp-marked))) ?d) - (?T (gnus-range-length (cdr (assq 'tick gnus-tmp-marked))) ?d) - (?i (+ (gnus-range-length (cdr (assq 'dormant gnus-tmp-marked))) - (gnus-range-length (cdr (assq 'tick gnus-tmp-marked)))) + (?I (range-length (cdr (assq 'dormant gnus-tmp-marked))) ?d) + (?T (range-length (cdr (assq 'tick gnus-tmp-marked))) ?d) + (?i (+ (range-length (cdr (assq 'dormant gnus-tmp-marked))) + (range-length (cdr (assq 'tick gnus-tmp-marked)))) ?d) (?g gnus-tmp-group ?s) (?G gnus-tmp-qualified-group ?s) @@ -573,209 +574,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'." @@ -982,66 +983,36 @@ simple manner." (gnus-run-hooks 'gnus-group-menu-hook))) - (defvar gnus-group-tool-bar-map nil) -(defun gnus-group-tool-bar-update (&optional symbol value) - "Update group buffer toolbar. -Setter function for custom variables." - (when symbol - (set-default symbol value)) - ;; (setq-default gnus-group-tool-bar-map nil) - ;; (use-local-map gnus-group-mode-map) - (when (gnus-alive-p) - (with-current-buffer gnus-group-buffer - (gnus-group-make-tool-bar t)))) - -(defcustom gnus-group-tool-bar (if (eq gmm-tool-bar-style 'gnome) - 'gnus-group-tool-bar-gnome - 'gnus-group-tool-bar-retro) - "Specifies the Gnus group tool bar. - -It can be either a list or a symbol referring to a list. See -`gmm-tool-bar-from-list' for the format of the list. The -default key map is `gnus-group-mode-map'. - -Pre-defined symbols include `gnus-group-tool-bar-gnome' and -`gnus-group-tool-bar-retro'." - :type '(choice (const :tag "GNOME style" gnus-group-tool-bar-gnome) - (const :tag "Retro look" gnus-group-tool-bar-retro) - (repeat :tag "User defined list" gmm-tool-bar-item) - (symbol)) - :version "23.1" ;; No Gnus - :initialize 'custom-initialize-default - :set 'gnus-group-tool-bar-update - :group 'gnus-group) - -(defcustom gnus-group-tool-bar-gnome +(defcustom gnus-group-tool-bar '((gnus-group-post-news "mail/compose") ;; Some useful agent icons? I don't use the agent so agent users should ;; suggest useful commands: - (gnus-agent-toggle-plugged "unplugged" t - :help "Gnus is currently unplugged. Click to work online." - :visible (and gnus-agent (not gnus-plugged))) - (gnus-agent-toggle-plugged "plugged" t - :help "Gnus is currently plugged. Click to work offline." - :visible (and gnus-agent gnus-plugged)) - ;; FIXME: gnus-agent-toggle-plugged (in gnus-agent-group-make-menu-bar) - ;; should have a better help text. - (gnus-group-send-queue "mail/outbox" t - :visible (and gnus-agent gnus-plugged) - :help "Send articles from the queue group") - (gnus-group-get-new-news "mail/inbox" nil - :visible (or (not gnus-agent) - gnus-plugged)) - ;; FIXME: gnus-*-read-group should have a better help text. - (gnus-topic-read-group "open" nil - :visible (and (boundp 'gnus-topic-mode) - gnus-topic-mode)) - (gnus-group-read-group "open" nil - :visible (not (and (boundp 'gnus-topic-mode) - gnus-topic-mode))) - ;; (gnus-group-find-new-groups "???" nil) + (gnus-agent-toggle-plugged + "unplugged" t + :help "Gnus is currently unplugged. Click to work online." + :visible (and gnus-agent (not gnus-plugged))) + (gnus-agent-toggle-plugged + "plugged" t + :help "Gnus is currently plugged. Click to work offline." + :visible (and gnus-agent gnus-plugged)) + (gnus-group-send-queue + "mail/outbox" t + :visible (and gnus-agent gnus-plugged) + :help "Send articles from the queue group") + (gnus-group-get-new-news + "mail/inbox" nil + :visible (or (not gnus-agent) + gnus-plugged)) + (gnus-topic-read-group + "open" nil + :visible (and (boundp 'gnus-topic-mode) + gnus-topic-mode)) + (gnus-group-read-group + "open" nil + :visible (not (and (boundp 'gnus-topic-mode) + gnus-topic-mode))) (gnus-group-save-newsrc "save") (gnus-group-describe-group "describe") (gnus-group-toggle-subscription-at-point "gnus/toggle-subscription") @@ -1050,44 +1021,22 @@ Pre-defined symbols include `gnus-group-tool-bar-gnome' and (gnus-group-exit "exit") (gmm-customize-mode "preferences" t :help "Edit mode preferences") (gnus-info-find-node "help")) - "List of functions for the group tool bar (GNOME style). - -See `gmm-tool-bar-from-list' for the format of the list." - :type '(repeat gmm-tool-bar-item) - :version "23.1" ;; No Gnus - :initialize 'custom-initialize-default - :set 'gnus-group-tool-bar-update - :group 'gnus-group) + "Specifies the Gnus group tool bar. -(defcustom gnus-group-tool-bar-retro - '((gnus-group-get-new-news "gnus/get-news") - (gnus-group-get-new-news-this-group "gnus/gnntg") - (gnus-group-catchup-current "gnus/catchup") - (gnus-group-describe-group "gnus/describe-group") - (gnus-group-subscribe "gnus/subscribe" t - :help "Subscribe to the current group") - (gnus-group-unsubscribe "gnus/unsubscribe" t - :help "Unsubscribe from the current group") - (gnus-group-exit "gnus/exit-gnus" gnus-group-mode-map)) - "List of functions for the group tool bar (retro look). - -See `gmm-tool-bar-from-list' for the format of the list." - :type '(repeat gmm-tool-bar-item) - :version "23.1" ;; No Gnus - :initialize 'custom-initialize-default - :set 'gnus-group-tool-bar-update +It can be either a list or a symbol referring to a list. See +`gmm-tool-bar-from-list' for the format of the list. The +default key map is `gnus-group-mode-map'." + :type '(choice (repeat :tag "User defined list" gmm-tool-bar-item) + (symbol)) + :version "29.1" :group 'gnus-group) -(defcustom gnus-group-tool-bar-zap-list t - "List of icon items from the global tool bar. -These items are not displayed in the Gnus group mode tool bar. - -See `gmm-tool-bar-from-list' for the format of the list." - :type 'gmm-tool-bar-zap-list - :version "23.1" ;; No Gnus - :initialize 'custom-initialize-default - :set 'gnus-group-tool-bar-update - :group 'gnus-group) +(defvar gnus-group-tool-bar-gnome nil) +(make-obsolete-variable 'gnus-group-tool-bar-gnome nil "29.1") +(defvar gnus-group-tool-bar-retro nil) +(make-obsolete-variable 'gnus-group-tool-bar-retro nil "29.1") +(defvar gnus-group-tool-bar-zap-list t) +(make-obsolete-variable 'gnus-group-tool-bar-zap-list nil "29.1") (defvar image-load-path) (defvar tool-bar-map) @@ -1482,9 +1431,9 @@ if it is a string, only list groups matching REGEXP." (active (gnus-active group))) (if (not active) 0 - (length (gnus-uncompress-range - (gnus-range-difference - (gnus-range-difference (list active) (gnus-info-read info)) + (length (range-uncompress + (range-difference + (range-difference (list active) (gnus-info-read info)) seen)))))) ;; Moving through the Group buffer (in topic mode) e.g. with C-n doesn't @@ -1642,7 +1591,7 @@ Some value are bound so the form can use them." '(mail post-mail)))) (cons 'level (or (gnus-info-level info) gnus-level-killed)) (cons 'score (or (gnus-info-score info) 0)) - (cons 'ticked (gnus-range-length (cdr (assq 'tick marked)))) + (cons 'ticked (range-length (cdr (assq 'tick marked)))) (cons 'group-age (gnus-group-timestamp-delta group))))) (while (and list (not (eval (caar list) env))) @@ -2065,9 +2014,9 @@ that group." (- (1+ (cdr active)) (car active))))) (gnus-summary-read-group group (or all (and (numberp number) - (zerop (+ number (gnus-range-length + (zerop (+ number (range-length (cdr (assq 'tick marked))) - (gnus-range-length + (range-length (cdr (assq 'dormant marked))))))) no-article nil no-display nil select-articles))) @@ -2832,7 +2781,7 @@ according to the expiry settings. Note that this will delete old not-expirable articles, too." (interactive (list (gnus-group-group-name) current-prefix-arg) gnus-group-mode) - (let ((articles (gnus-uncompress-range (gnus-active group)))) + (let ((articles (range-uncompress (gnus-active group)))) (when (gnus-yes-or-no-p (format "Do you really want to delete these %d articles forever? " (length articles))) @@ -3134,9 +3083,9 @@ If SOLID (the prefix), create a solid group." (if (derived-mode-p 'gnus-summary-mode) 'summary 'group)))))) (defvar nnrss-group-alist) -(eval-when-compile - (defun nnrss-discover-feed (_arg)) - (defun nnrss-save-server-data (_arg))) +(declare-function nnrss-discover-feed "nnrss" (url)) +(declare-function nnrss-save-server-data "nnrss" (server)) + (defun gnus-group-make-rss-group (&optional url) "Given a URL, discover if there is an RSS feed. If there is, use Gnus to create an nnrss group" @@ -3225,7 +3174,11 @@ non-nil SPECS arg must be an alist with `search-query-spec' and (if (gnus-server-server-name) (list (list (gnus-server-server-name))) (seq-group-by - (lambda (elt) (gnus-group-server elt)) + (lambda (elt) + (if (gnus-group-native-p elt) + (gnus-group-server elt) + (gnus-method-to-server + (gnus-find-method-for-group elt)))) (or gnus-group-marked (if (gnus-group-group-name) (list (gnus-group-group-name)) @@ -3276,7 +3229,11 @@ non-nil SPECS arg must be an alist with `search-query-spec' and (if (gnus-server-server-name) (list (list (gnus-server-server-name))) (seq-group-by - (lambda (elt) (gnus-group-server elt)) + (lambda (elt) + (if (gnus-group-native-p elt) + (gnus-group-server elt) + (gnus-method-to-server + (gnus-find-method-for-group elt)))) (or gnus-group-marked (if (gnus-group-group-name) (list (gnus-group-group-name)) @@ -3755,15 +3712,15 @@ or nil if no action could be taken." 'del '(tick)) (list (cdr (assq 'dormant marks)) 'del '(dormant)))) - (setq unread (gnus-range-add (gnus-range-add - unread (cdr (assq 'dormant marks))) - (cdr (assq 'tick marks)))) + (setq unread (range-concat (range-concat + unread (cdr (assq 'dormant marks))) + (cdr (assq 'tick marks)))) (gnus-add-marked-articles group 'tick nil nil 'force) (gnus-add-marked-articles group 'dormant nil nil 'force)) ;; Do auto-expirable marks if that's required. (when (and (gnus-group-auto-expirable-p group) (not (gnus-group-read-only-p group))) - (gnus-range-map + (range-map (lambda (article) (gnus-add-marked-articles group 'expire (list article)) (gnus-request-set-mark group (list (list (list article) @@ -3795,7 +3752,7 @@ Uses the process/prefix convention." (cons nil (gnus-list-of-read-articles group)) (assq 'expire (gnus-info-marks info)))) (articles-to-expire - (gnus-list-range-difference + (range-list-difference (gnus-uncompress-sequence (cdr expirable)) (cdr (assq 'unexist (gnus-info-marks info))))) (expiry-wait (gnus-group-find-parameter group 'expiry-wait)) @@ -4671,23 +4628,22 @@ and the second element is the address." (and (not (setq marked (nthcdr 3 info))) (or (null articles) (setcdr (nthcdr 2 info) - (list (list (cons type (gnus-compress-sequence - articles t))))))) + (list (list (cons type (range-compress-list + articles))))))) (and (not (setq m (assq type (car marked)))) (or (null articles) (setcar marked - (cons (cons type (gnus-compress-sequence articles t) ) + (cons (cons type (range-compress-list articles)) (car marked))))) (if force (if (null articles) (setcar (nthcdr 3 info) (assq-delete-all type (car marked))) - (setcdr m (gnus-compress-sequence articles t))) - (setcdr m (gnus-compress-sequence - (sort (nconc (gnus-uncompress-range (cdr m)) + (setcdr m (range-compress-list articles))) + (setcdr m (range-compress-list + (sort (nconc (range-uncompress (cdr m)) (copy-sequence articles)) - #'<) - t)))))) + #'<))))))) (declare-function gnus-summary-add-mark "gnus-sum" (article type)) diff --git a/lisp/gnus/gnus-html.el b/lisp/gnus/gnus-html.el index e259d9ae18b..87f3ee63623 100644 --- a/lisp/gnus/gnus-html.el +++ b/lisp/gnus/gnus-html.el @@ -40,14 +40,11 @@ (require 'help-fns) (require 'url-queue) -(defcustom gnus-html-image-cache-ttl (days-to-time 7) - "Time used to determine if we should use images from the cache." - :version "24.1" +(defcustom gnus-html-image-cache-ttl (time-convert (days-to-time 7) 'integer) + "Number of seconds used to determine if we should use images from the cache." + :version "29.1" :group 'gnus-art - ;; FIXME hardly the friendliest type. The allowed value is actually - ;; any time value, but we are assuming no-one cares about USEC and - ;; PSEC here. It would be better to eg make it a number of minutes. - :type '(list integer integer)) + :type 'number) (defcustom gnus-html-image-automatic-caching t "Whether automatically cache retrieve images." @@ -71,21 +68,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 d35b0ebb1d9..1bffdf3513a 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) @@ -817,11 +830,12 @@ These will be used to retrieve the RSVP information from ical events." (defmacro gnus-icalendar-with-decoded-handle (handle &rest body) "Execute BODY in buffer containing the decoded contents of HANDLE." (let ((charset (make-symbol "charset"))) - `(let ((,charset (cdr (assoc 'charset (mm-handle-type ,handle))))) + `(let ((,charset (downcase + (or (cdr (assoc 'charset (mm-handle-type ,handle))) + "utf-8")))) (with-temp-buffer (mm-insert-part ,handle) - (when (and ,charset (string= (downcase ,charset) "utf-8")) - (decode-coding-region (point-min) (point-max) 'utf-8)) + (decode-coding-region (point-min) (point-max) (intern ,charset)) ,@body)))) @@ -847,10 +861,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 +884,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 +902,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 +916,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 +1063,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-int.el b/lisp/gnus/gnus-int.el index 5a619e8f07b..f00f2a0d04e 100644 --- a/lisp/gnus/gnus-int.el +++ b/lisp/gnus/gnus-int.el @@ -802,7 +802,7 @@ If GROUP is nil, all groups on COMMAND-METHOD are scanned." (when (> min 1) (let* ((range (if (= min 2) 1 (cons 1 (1- min)))) (read (gnus-info-read info)) - (new-read (gnus-range-add read (list range)))) + (new-read (range-concat read (list range)))) (setf (gnus-info-read info) new-read))) info)))))) diff --git a/lisp/gnus/gnus-kill.el b/lisp/gnus/gnus-kill.el index 57b4444d577..bc49f8385ea 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. @@ -352,7 +349,7 @@ Returns the number of articles marked as read." (setq gnus-newsgroup-kill-headers (mapcar #'mail-header-number headers)) (while headers - (unless (gnus-member-of-range + (unless (range-member-p (mail-header-number (car headers)) gnus-newsgroup-killed) (push (mail-header-number (car headers)) diff --git a/lisp/gnus/gnus-ml.el b/lisp/gnus/gnus-ml.el index 077ea3b6b8c..211980aa9e3 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 f7eecece26b..17a87134be0 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") @@ -1571,8 +1571,9 @@ this is a reply." (when gcc (message-remove-header "gcc") (widen) - (setq groups (message-unquote-tokens - (message-tokenize-header gcc " ,\n\t"))) + (setq groups (mapcar #'string-trim + (message-unquote-tokens + (message-tokenize-header gcc)))) ;; Copy the article over to some group(s). (while (setq group (pop groups)) (setq method (gnus-inews-group-method group)) @@ -1593,9 +1594,10 @@ this is a reply." (nnheader-set-temp-buffer " *acc*") (setq message-options (with-current-buffer cur message-options)) (insert-buffer-substring cur) + (restore-buffer-modified-p nil) (run-hooks 'gnus-gcc-pre-body-encode-hook) ;; Avoid re-doing things like GPG-encoding secret parts. - (if (not encoded-cache) + (if (or (buffer-modified-p) (not encoded-cache)) (message-encode-message-body) (erase-buffer) (insert encoded-cache)) @@ -1748,7 +1750,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-range.el b/lisp/gnus/gnus-range.el index da3ff473725..23a71bda209 100644 --- a/lisp/gnus/gnus-range.el +++ b/lisp/gnus/gnus-range.el @@ -26,10 +26,8 @@ ;;; List and range functions -(defsubst gnus-range-normalize (range) - "Normalize RANGE. -If RANGE is a single range, return (RANGE). Otherwise, return RANGE." - (if (listp (cdr-safe range)) range (list range))) +(require 'range) +(define-obsolete-function-alias 'gnus-range-normalize #'range-normalize "29.1") (defun gnus-last-element (list) "Return last element of LIST." @@ -56,10 +54,10 @@ If RANGE is a single range, return (RANGE). Otherwise, return RANGE." "Return a range comprising all the RANGES, which are pre-sorted. RANGES will be destructively altered." (setq ranges (delete nil ranges)) - (let* ((result (gnus-range-normalize (pop ranges))) + (let* ((result (range-normalize (pop ranges))) (last (last result))) (dolist (range ranges) - (setq range (gnus-range-normalize range)) + (setq range (range-normalize range)) ;; Normalize the single-number case, so that we don't need to ;; special-case that so much. (when (numberp (car last)) @@ -82,47 +80,8 @@ RANGES will be destructively altered." (car result) result))) -(defun gnus-range-difference (range1 range2) - "Return the range of elements in RANGE1 that do not appear in RANGE2. -Both ranges must be in ascending order." - (setq range1 (gnus-range-normalize range1)) - (setq range2 (gnus-range-normalize range2)) - (let* ((new-range (cons nil (copy-sequence range1))) - (r new-range) - ) ;; (safe t) - (while (cdr r) - (let* ((r1 (cadr r)) - (r2 (car range2)) - (min1 (if (numberp r1) r1 (car r1))) - (max1 (if (numberp r1) r1 (cdr r1))) - (min2 (if (numberp r2) r2 (car r2))) - (max2 (if (numberp r2) r2 (cdr r2)))) - - (cond ((> min1 max1) - ;; Invalid range: may result from overlap condition (below) - ;; remove Invalid range - (setcdr r (cddr r))) - ((and (= min1 max1) - (listp r1)) - ;; Inefficient representation: may result from overlap condition (below) - (setcar (cdr r) min1)) - ((not min2) - ;; All done with range2 - (setq r nil)) - ((< max1 min2) - ;; No overlap: range1 precedes range2 - (pop r)) - ((< max2 min1) - ;; No overlap: range2 precedes range1 - (pop range2)) - ((and (<= min2 min1) (<= max1 max2)) - ;; Complete overlap: range1 removed - (setcdr r (cddr r))) - (t - (setcdr r (nconc (list (cons min1 (1- min2)) (cons (1+ max2) max1)) (cddr r))))))) - (cdr new-range))) - - +(define-obsolete-function-alias 'gnus-range-difference + #'range-difference "29.1") ;;;###autoload (defun gnus-sorted-difference (list1 list2) @@ -200,57 +159,8 @@ LIST1 and LIST2 have to be sorted over <." (setq list2 (cdr list2))))) (nreverse out))) -;;;###autoload -(defun gnus-sorted-range-intersection (range1 range2) - "Return intersection of RANGE1 and RANGE2. -RANGE1 and RANGE2 have to be sorted over <." - (let* (out - (min1 (car range1)) - (max1 (if (numberp min1) - (if (numberp (cdr range1)) - (prog1 (cdr range1) - (setq range1 nil)) min1) - (prog1 (cdr min1) - (setq min1 (car min1))))) - (min2 (car range2)) - (max2 (if (numberp min2) - (if (numberp (cdr range2)) - (prog1 (cdr range2) - (setq range2 nil)) min2) - (prog1 (cdr min2) - (setq min2 (car min2)))))) - (setq range1 (cdr range1) - range2 (cdr range2)) - (while (and min1 min2) - (cond ((< max1 min2) ; range1 precedes range2 - (setq range1 (cdr range1) - min1 nil)) - ((< max2 min1) ; range2 precedes range1 - (setq range2 (cdr range2) - min2 nil)) - (t ; some sort of overlap is occurring - (let ((min (max min1 min2)) - (max (min max1 max2))) - (setq out (if (= min max) - (cons min out) - (cons (cons min max) out)))) - (if (< max1 max2) ; range1 ends before range2 - (setq min1 nil) ; incr range1 - (setq min2 nil)))) ; incr range2 - (unless min1 - (setq min1 (car range1) - max1 (if (numberp min1) min1 (prog1 (cdr min1) (setq min1 (car min1)))) - range1 (cdr range1))) - (unless min2 - (setq min2 (car range2) - max2 (if (numberp min2) min2 (prog1 (cdr min2) (setq min2 (car min2)))) - range2 (cdr range2)))) - (cond ((cdr out) - (nreverse out)) - ((numberp (car out)) - out) - (t - (car out))))) +(define-obsolete-function-alias 'gnus-sorted-range-intersection + #'range-intersection "29.1") ;;;###autoload (defalias 'gnus-set-sorted-intersection 'gnus-sorted-nintersection) @@ -327,315 +237,33 @@ LIST1 and LIST2 have to be sorted over <." "Convert sorted list of numbers to a list of ranges or a single range. If ALWAYS-LIST is non-nil, this function will always release a list of ranges." - (let* ((first (car numbers)) - (last (car numbers)) - result) - (if (null numbers) - nil - (if (not (listp (cdr numbers))) - numbers - (while numbers - (cond ((= last (car numbers)) nil) ;Omit duplicated number - ((= (1+ last) (car numbers)) ;Still in sequence - (setq last (car numbers))) - (t ;End of one sequence - (setq result - (cons (if (= first last) first - (cons first last)) - result)) - (setq first (car numbers)) - (setq last (car numbers)))) - (setq numbers (cdr numbers))) - (if (and (not always-list) (null result)) - (if (= first last) (list first) (cons first last)) - (nreverse (cons (if (= first last) first (cons first last)) - result))))))) + (if always-list + (range-compress-list numbers) + (range-denormalize (range-compress-list numbers)))) (defalias 'gnus-uncompress-sequence 'gnus-uncompress-range) -(defun gnus-uncompress-range (ranges) - "Expand a list of ranges into a list of numbers. -RANGES is either a single range on the form `(num . num)' or a list of -these ranges." - (let (first last result) - (cond - ((null ranges) - nil) - ((not (listp (cdr ranges))) - (setq first (car ranges)) - (setq last (cdr ranges)) - (while (<= first last) - (setq result (cons first result)) - (setq first (1+ first))) - (nreverse result)) - (t - (while ranges - (if (atom (car ranges)) - (when (numberp (car ranges)) - (setq result (cons (car ranges) result))) - (setq first (caar ranges)) - (setq last (cdar ranges)) - (while (<= first last) - (setq result (cons first result)) - (setq first (1+ first)))) - (setq ranges (cdr ranges))) - (nreverse result))))) - -(defun gnus-add-to-range (ranges list) - "Return a list of ranges that has all articles from both RANGES and LIST. -Note: LIST has to be sorted over `<'." - (if (not ranges) - (gnus-compress-sequence list t) - (setq list (copy-sequence list)) - (unless (listp (cdr ranges)) - (setq ranges (list ranges))) - (let ((out ranges) - ilist lowest highest temp) - (while (and ranges list) - (setq ilist list) - (setq lowest (or (and (atom (car ranges)) (car ranges)) - (caar ranges))) - (while (and list (cdr list) (< (cadr list) lowest)) - (setq list (cdr list))) - (when (< (car ilist) lowest) - (setq temp list) - (setq list (cdr list)) - (setcdr temp nil) - (setq out (nconc (gnus-compress-sequence ilist t) out))) - (setq highest (or (and (atom (car ranges)) (car ranges)) - (cdar ranges))) - (while (and list (<= (car list) highest)) - (setq list (cdr list))) - (setq ranges (cdr ranges))) - (when list - (setq out (nconc (gnus-compress-sequence list t) out))) - (setq out (sort out (lambda (r1 r2) - (< (or (and (atom r1) r1) (car r1)) - (or (and (atom r2) r2) (car r2)))))) - (setq ranges out) - (while ranges - (if (atom (car ranges)) - (when (cdr ranges) - (if (atom (cadr ranges)) - (when (= (1+ (car ranges)) (cadr ranges)) - (setcar ranges (cons (car ranges) - (cadr ranges))) - (setcdr ranges (cddr ranges))) - (when (= (1+ (car ranges)) (caadr ranges)) - (setcar (cadr ranges) (car ranges)) - (setcar ranges (cadr ranges)) - (setcdr ranges (cddr ranges))))) - (when (cdr ranges) - (if (atom (cadr ranges)) - (when (= (1+ (cdar ranges)) (cadr ranges)) - (setcdr (car ranges) (cadr ranges)) - (setcdr ranges (cddr ranges))) - (when (= (1+ (cdar ranges)) (caadr ranges)) - (setcdr (car ranges) (cdadr ranges)) - (setcdr ranges (cddr ranges)))))) - (setq ranges (cdr ranges))) - out))) - -(defun gnus-remove-from-range (range1 range2) - "Return a range that has all articles from RANGE2 removed from RANGE1. -The returned range is always a list. RANGE2 can also be a unsorted -list of articles. RANGE1 is modified by side effects, RANGE2 is not -modified." - (if (or (null range1) (null range2)) - range1 - (let (out r1 r2 r1_min r1_max r2_min r2_max - (range2 (copy-tree range2))) - (setq range1 (if (listp (cdr range1)) range1 (list range1)) - range2 (sort (if (listp (cdr range2)) range2 (list range2)) - (lambda (e1 e2) - (< (if (consp e1) (car e1) e1) - (if (consp e2) (car e2) e2)))) - r1 (car range1) - r2 (car range2) - r1_min (if (consp r1) (car r1) r1) - r1_max (if (consp r1) (cdr r1) r1) - r2_min (if (consp r2) (car r2) r2) - r2_max (if (consp r2) (cdr r2) r2)) - (while (and range1 range2) - (cond ((< r2_max r1_min) ; r2 < r1 - (pop range2) - (setq r2 (car range2) - r2_min (if (consp r2) (car r2) r2) - r2_max (if (consp r2) (cdr r2) r2))) - ((and (<= r2_min r1_min) (<= r1_max r2_max)) ; r2 overlap r1 - (pop range1) - (setq r1 (car range1) - r1_min (if (consp r1) (car r1) r1) - r1_max (if (consp r1) (cdr r1) r1))) - ((and (<= r2_min r1_min) (<= r2_max r1_max)) ; r2 overlap min r1 - (pop range2) - (setq r1_min (1+ r2_max) - r2 (car range2) - r2_min (if (consp r2) (car r2) r2) - r2_max (if (consp r2) (cdr r2) r2))) - ((and (<= r1_min r2_min) (<= r2_max r1_max)) ; r2 contained in r1 - (if (eq r1_min (1- r2_min)) - (push r1_min out) - (push (cons r1_min (1- r2_min)) out)) - (pop range2) - (if (< r2_max r1_max) ; finished with r1? - (setq r1_min (1+ r2_max)) - (pop range1) - (setq r1 (car range1) - r1_min (if (consp r1) (car r1) r1) - r1_max (if (consp r1) (cdr r1) r1))) - (setq r2 (car range2) - r2_min (if (consp r2) (car r2) r2) - r2_max (if (consp r2) (cdr r2) r2))) - ((and (<= r2_min r1_max) (<= r1_max r2_max)) ; r2 overlap max r1 - (if (eq r1_min (1- r2_min)) - (push r1_min out) - (push (cons r1_min (1- r2_min)) out)) - (pop range1) - (setq r1 (car range1) - r1_min (if (consp r1) (car r1) r1) - r1_max (if (consp r1) (cdr r1) r1))) - ((< r1_max r2_min) ; r2 > r1 - (pop range1) - (if (eq r1_min r1_max) - (push r1_min out) - (push (cons r1_min r1_max) out)) - (setq r1 (car range1) - r1_min (if (consp r1) (car r1) r1) - r1_max (if (consp r1) (cdr r1) r1))))) - (when r1 - (if (eq r1_min r1_max) - (push r1_min out) - (push (cons r1_min r1_max) out)) - (pop range1)) - (while range1 - (push (pop range1) out)) - (nreverse out)))) - -(defun gnus-member-of-range (number ranges) - (if (not (listp (cdr ranges))) - (and (>= number (car ranges)) - (<= number (cdr ranges))) - (let ((not-stop t)) - (while (and ranges - (if (numberp (car ranges)) - (>= number (car ranges)) - (>= number (caar ranges))) - not-stop) - (when (if (numberp (car ranges)) - (= number (car ranges)) - (and (>= number (caar ranges)) - (<= number (cdar ranges)))) - (setq not-stop nil)) - (setq ranges (cdr ranges))) - (not not-stop)))) - -(defun gnus-list-range-intersection (list ranges) - "Return a list of numbers in LIST that are members of RANGES. -LIST is a sorted list." - (setq ranges (gnus-range-normalize ranges)) - (let (number result) - (while (setq number (pop list)) - (while (and ranges - (if (numberp (car ranges)) - (< (car ranges) number) - (< (cdar ranges) number))) - (setq ranges (cdr ranges))) - (when (and ranges - (if (numberp (car ranges)) - (= (car ranges) number) - ;; (caar ranges) <= number <= (cdar ranges) - (>= number (caar ranges)))) - (push number result))) - (nreverse result))) +(define-obsolete-function-alias 'gnus-uncompress-range + #'range-uncompress "29.1") + +(define-obsolete-function-alias 'gnus-add-to-range + #'range-add-list "29.1") + +(define-obsolete-function-alias 'gnus-remove-from-range + #'range-remove "29.1") + +(define-obsolete-function-alias 'gnus-member-of-range #'range-member-p "29.1") + +(define-obsolete-function-alias 'gnus-list-range-intersection + #'range-list-intersection "29.1") (defalias 'gnus-inverse-list-range-intersection 'gnus-list-range-difference) -(defun gnus-list-range-difference (list ranges) - "Return a list of numbers in LIST that are not members of RANGES. -LIST is a sorted list." - (setq ranges (gnus-range-normalize ranges)) - (let (number result) - (while (setq number (pop list)) - (while (and ranges - (if (numberp (car ranges)) - (< (car ranges) number) - (< (cdar ranges) number))) - (setq ranges (cdr ranges))) - (when (or (not ranges) - (if (numberp (car ranges)) - (not (= (car ranges) number)) - ;; not ((caar ranges) <= number <= (cdar ranges)) - (< number (caar ranges)))) - (push number result))) - (nreverse result))) +(define-obsolete-function-alias 'gnus-list-range-difference + #'range-list-difference "29.1") + +(define-obsolete-function-alias 'gnus-range-length #'range-length "29.1") -(defun gnus-range-length (range) - "Return the length RANGE would have if uncompressed." - (cond - ((null range) - 0) - ((not (listp (cdr range))) - (- (cdr range) (car range) -1)) - (t - (let ((sum 0)) - (dolist (x range sum) - (setq sum - (+ sum (if (consp x) (- (cdr x) (car x) -1) 1)))))))) - -(defun gnus-range-add (range1 range2) - "Add RANGE2 to RANGE1 (nondestructively)." - (unless (listp (cdr range1)) - (setq range1 (list range1))) - (unless (listp (cdr range2)) - (setq range2 (list range2))) - (let ((item1 (pop range1)) - (item2 (pop range2)) - range item selector) - (while (or item1 item2) - (setq selector - (cond - ((null item1) nil) - ((null item2) t) - ((and (numberp item1) (numberp item2)) (< item1 item2)) - ((numberp item1) (< item1 (car item2))) - ((numberp item2) (< (car item1) item2)) - (t (< (car item1) (car item2))))) - (setq item - (or - (let ((tmp1 item) (tmp2 (if selector item1 item2))) - (cond - ((null tmp1) tmp2) - ((null tmp2) tmp1) - ((and (numberp tmp1) (numberp tmp2)) - (cond - ((eq tmp1 tmp2) tmp1) - ((eq (1+ tmp1) tmp2) (cons tmp1 tmp2)) - ((eq (1+ tmp2) tmp1) (cons tmp2 tmp1)) - (t nil))) - ((numberp tmp1) - (cond - ((and (>= tmp1 (car tmp2)) (<= tmp1 (cdr tmp2))) tmp2) - ((eq (1+ tmp1) (car tmp2)) (cons tmp1 (cdr tmp2))) - ((eq (1- tmp1) (cdr tmp2)) (cons (car tmp2) tmp1)) - (t nil))) - ((numberp tmp2) - (cond - ((and (>= tmp2 (car tmp1)) (<= tmp2 (cdr tmp1))) tmp1) - ((eq (1+ tmp2) (car tmp1)) (cons tmp2 (cdr tmp1))) - ((eq (1- tmp2) (cdr tmp1)) (cons (car tmp1) tmp2)) - (t nil))) - ((< (1+ (cdr tmp1)) (car tmp2)) nil) - ((< (1+ (cdr tmp2)) (car tmp1)) nil) - (t (cons (min (car tmp1) (car tmp2)) - (max (cdr tmp1) (cdr tmp2)))))) - (progn - (if item (push item range)) - (if selector item1 item2)))) - (if selector - (setq item1 (pop range1)) - (setq item2 (pop range2)))) - (if item (push item range)) - (reverse range))) +(define-obsolete-function-alias 'gnus-range-add #'range-concat "29.1") ;;;###autoload (defun gnus-add-to-sorted-list (list num) @@ -649,18 +277,7 @@ LIST is a sorted list." (setcdr prev (cons num list))) (cdr top))) -(defun gnus-range-map (func range) - "Apply FUNC to each value contained by RANGE." - (setq range (gnus-range-normalize range)) - (while range - (let ((span (pop range))) - (if (numberp span) - (funcall func span) - (let ((first (car span)) - (last (cdr span))) - (while (<= first last) - (funcall func first) - (setq first (1+ first)))))))) +(define-obsolete-function-alias 'gnus-range-map #'range-map "29.1") (provide 'gnus-range) diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el index e41b74fbd92..8cefb09b66a 100644 --- a/lisp/gnus/gnus-registry.el +++ b/lisp/gnus/gnus-registry.el @@ -163,7 +163,9 @@ nnmairix groups are specifically excluded because they are ephemeral." :type 'boolean :version "28.1") -(defvar gnus-registry-enabled nil) +(make-obsolete-variable + 'gnus-registry-enabled + "Check for non-nil value of `gnus-registry-db'" "29.1") (defvar gnus-summary-misc-menu) ;; Avoid byte compiler warning. @@ -355,8 +357,12 @@ This is not required after changing `gnus-registry-cache-file'." "Load the registry from the cache file." (interactive) (let ((file gnus-registry-cache-file)) + (gnus-message 5 "Initializing the registry") (condition-case nil - (gnus-registry-read file) + (progn + (gnus-registry-read file) + (gnus-registry-install-hooks) + (gnus-registry-install-shortcuts)) (file-error ;; Fix previous mis-naming of the registry file. (let ((old-file-name @@ -846,8 +852,9 @@ 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)) + (unless (or (null gnus-registry-db) + (null gnus-registry-register-all) + (gnus-parameter-registry-ignore gnus-newsgroup-name)) (dolist (article gnus-newsgroup-articles) (let* ((id (gnus-registry-fetch-message-id-fast article)) (groups (gnus-registry-get-id-key id 'group))) @@ -948,13 +955,12 @@ FUNCTION should take two parameters, a mark symbol and the cell value." (defun gnus-registry-install-shortcuts () "Install the keyboard shortcuts and menus for the registry. Uses `gnus-registry-marks' to find what shortcuts to install." - (let (keys-plist) - (setq gnus-registry-misc-menus nil) - (gnus-registry-do-marks - :char - (lambda (mark data) - (let ((function-format - (format "gnus-registry-%%s-article-%s-mark" mark))) + (setq gnus-registry-misc-menus nil) + (gnus-registry-do-marks + :char + (lambda (mark data) + (let ((function-format + (format "gnus-registry-%%s-article-%s-mark" mark))) ;;; The following generates these functions: ;;; (defun gnus-registry-set-article-Important-mark (&rest articles) @@ -966,39 +972,37 @@ Uses `gnus-registry-marks' to find what shortcuts to install." ;;; (interactive (gnus-summary-work-articles current-prefix-arg)) ;;; (gnus-registry-set-article-mark-internal 'Important articles t t)) - (dolist (remove '(t nil)) - (let* ((variant-name (if remove "remove" "set")) - (function-name - (intern (format function-format variant-name))) - (shortcut (format "%c" (if remove (upcase data) data)))) - (defalias function-name - (lambda (&rest articles) - (:documentation - (format - "%s the %s mark over process-marked ARTICLES." - (upcase-initials variant-name) - mark)) - (interactive - (gnus-summary-work-articles current-prefix-arg)) - (gnus-registry--set/remove-mark mark remove articles))) - (push function-name keys-plist) - (push shortcut keys-plist) - (push (vector (format "%s %s" - (upcase-initials variant-name) - (symbol-name mark)) - function-name t) - 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) - (add-hook 'gnus-summary-menu-hook - (lambda () - (easy-menu-add-item - gnus-summary-misc-menu - nil - (cons "Registry Marks" gnus-registry-misc-menus)))))) + (dolist (remove '(t nil)) + (let* ((variant-name (if remove "remove" "set")) + (function-name + (intern (format function-format variant-name))) + (shortcut (format "%c" (if remove (upcase data) data)))) + (defalias function-name + (lambda (&rest articles) + (:documentation + (format + "%s the %s mark over process-marked ARTICLES." + (upcase-initials variant-name) + mark)) + (interactive + (gnus-summary-work-articles current-prefix-arg)) + (gnus-registry--set/remove-mark mark remove articles))) + (keymap-set gnus-summary-mark-map + (concat "M " shortcut) + function-name) + (push (vector (format "%s %s" + (upcase-initials variant-name) + (symbol-name mark)) + function-name t) + gnus-registry-misc-menus) + (gnus-message 9 "Defined mark handling function %s" + function-name)))))) + (add-hook 'gnus-summary-menu-hook + (lambda () + (easy-menu-add-item + gnus-summary-misc-menu + nil + (cons "Registry Marks" gnus-registry-misc-menus))))) (define-obsolete-function-alias 'gnus-registry-user-format-function-M #'gnus-registry-article-marks-to-chars "24.1") @@ -1007,7 +1011,7 @@ Uses `gnus-registry-marks' to find what shortcuts to install." ;; (defalias 'gnus-user-format-function-M #'gnus-registry-article-marks-to-chars) (defun gnus-registry-article-marks-to-chars (headers) "Show the marks for an article by the :char property." - (if gnus-registry-enabled + (if gnus-registry-db (let* ((id (mail-header-message-id headers)) (marks (when id (gnus-registry-get-id-key id 'mark)))) (concat (delq nil @@ -1023,7 +1027,7 @@ Uses `gnus-registry-marks' to find what shortcuts to install." ;; (defalias 'gnus-user-format-function-M #'gnus-registry-article-marks-to-names) (defun gnus-registry-article-marks-to-names (headers) "Show the marks for an article by name." - (if gnus-registry-enabled + (if gnus-registry-db (let* ((id (mail-header-message-id headers)) (marks (when id (gnus-registry-get-id-key id 'mark)))) (mapconcat #'symbol-name marks ",")) @@ -1142,7 +1146,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%%)" @@ -1182,16 +1186,12 @@ non-nil." (defun gnus-registry-initialize () "Initialize the Gnus registry." (interactive) - (gnus-message 5 "Initializing the registry") - (gnus-registry-install-hooks) - (gnus-registry-install-shortcuts) (if (gnus-alive-p) (gnus-registry-load) (add-hook 'gnus-read-newsrc-el-hook #'gnus-registry-load))) (defun gnus-registry-install-hooks () "Install the registry hooks." - (setq gnus-registry-enabled t) (add-hook 'gnus-summary-article-move-hook #'gnus-registry-action) (add-hook 'gnus-summary-article-delete-hook #'gnus-registry-action) (add-hook 'gnus-summary-article-expire-hook #'gnus-registry-action) @@ -1211,17 +1211,16 @@ non-nil." (remove-hook 'gnus-save-newsrc-hook #'gnus-registry-save) (remove-hook 'gnus-read-newsrc-el-hook #'gnus-registry-load) - (remove-hook 'gnus-summary-prepare-hook #'gnus-registry-register-message-ids) - (setq gnus-registry-enabled nil)) + (remove-hook 'gnus-summary-prepare-hook #'gnus-registry-register-message-ids)) -(add-hook 'gnus-registry-unload-hook #'gnus-registry-unload-hook) +(add-hook 'gnus-registry-unload-hook #'gnus-registry-clear) (defun gnus-registry-install-p () "Return non-nil if the registry is enabled (and maybe enable it first). If the registry is not already enabled, then if `gnus-registry-install' is `ask', ask the user; or if `gnus-registry-install' is non-nil, enable it." (interactive) - (unless gnus-registry-enabled + (unless gnus-registry-db (when (if (eq gnus-registry-install 'ask) (gnus-y-or-n-p (concat "Enable the Gnus registry? " @@ -1229,7 +1228,7 @@ is `ask', ask the user; or if `gnus-registry-install' is non-nil, enable it." "to get rid of this query permanently. ")) gnus-registry-install) (gnus-registry-initialize))) - gnus-registry-enabled) + (null (null gnus-registry-db))) ;; largely based on nnselect-warp-to-article (defun gnus-try-warping-via-registry () diff --git a/lisp/gnus/gnus-rmail.el b/lisp/gnus/gnus-rmail.el new file mode 100644 index 00000000000..15ead1add41 --- /dev/null +++ b/lisp/gnus/gnus-rmail.el @@ -0,0 +1,142 @@ +;;; gnus-rmail.el --- Saving to rmail/babyl files -*- lexical-binding: t; -*- + +;; Copyright (C) 2021-2022 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: + +;;; Functions for saving to babyl/mail files. + +(require 'rmail) +(require 'rmailsum) +(require 'nnmail) + +(defun gnus-output-to-rmail (filename &optional ask) + "Append the current article to an Rmail file named FILENAME. +In Emacs 22 this writes Babyl format; in Emacs 23 it writes mbox unless +FILENAME exists and is Babyl format." + ;; Some of this codes is borrowed from rmailout.el. + (setq filename (expand-file-name filename)) + ;; FIXME should we really be messing with this defcustom? + ;; It is not needed for the operation of this function. + (if (boundp 'rmail-default-rmail-file) + (setq rmail-default-rmail-file filename) ; 22 + (setq rmail-default-file filename)) ; 23 + (let ((artbuf (current-buffer)) + (tmpbuf (gnus-get-buffer-create " *Gnus-output*")) + ;; Babyl rmail.el defines this, mbox does not. + (babyl (fboundp 'rmail-insert-rmail-file-header))) + (save-excursion + ;; Note that we ignore the possibility of visiting a Babyl + ;; format buffer in Emacs 23, since Rmail no longer supports that. + (or (get-file-buffer filename) + (progn + ;; In case someone wants to write to a Babyl file from Emacs 23. + (when (file-exists-p filename) + (setq babyl (mail-file-babyl-p filename)) + t)) + (if (or (not ask) + (gnus-yes-or-no-p + (concat "\"" filename "\" does not exist, create it? "))) + (let ((file-buffer (create-file-buffer filename))) + (with-current-buffer file-buffer + (if (fboundp 'rmail-insert-rmail-file-header) + (rmail-insert-rmail-file-header)) + (let ((require-final-newline nil) + (coding-system-for-write mm-text-coding-system)) + (gnus-write-buffer filename))) + (kill-buffer file-buffer)) + (error "Output file does not exist"))) + (set-buffer tmpbuf) + (erase-buffer) + (insert-buffer-substring artbuf) + (if babyl + (gnus-convert-article-to-rmail) + ;; Non-Babyl case copied from gnus-output-to-mail. + (goto-char (point-min)) + (if (looking-at "From ") + (forward-line 1) + (insert "From nobody " (current-time-string) "\n")) + (let (case-fold-search) + (while (re-search-forward "^From " nil t) + (beginning-of-line) + (insert ">")))) + ;; Decide whether to append to a file or to an Emacs buffer. + (let ((outbuf (get-file-buffer filename))) + (if (not outbuf) + (progn + (unless babyl ; from gnus-output-to-mail + (let ((buffer-read-only nil)) + (goto-char (point-max)) + (forward-char -2) + (unless (looking-at "\n\n") + (goto-char (point-max)) + (unless (bolp) + (insert "\n")) + (insert "\n")))) + (let ((file-name-coding-system nnmail-pathname-coding-system)) + (mm-append-to-file (point-min) (point-max) filename))) + ;; File has been visited, in buffer OUTBUF. + (set-buffer outbuf) + (let ((buffer-read-only nil) + (msg (and (boundp 'rmail-current-message) + (symbol-value 'rmail-current-message)))) + ;; If MSG is non-nil, buffer is in RMAIL mode. + ;; Compare this with rmail-output-to-rmail-buffer in Emacs 23. + (when msg + (unless babyl + (rmail-swap-buffers-maybe) + (rmail-maybe-set-message-counters)) + (widen) + (unless babyl + (goto-char (point-max)) + ;; Ensure we have a blank line before the next message. + (unless (bolp) + (insert "\n")) + (insert "\n")) + (narrow-to-region (point-max) (point-max))) + (insert-buffer-substring tmpbuf) + (when msg + (when babyl + (goto-char (point-min)) + (widen) + (search-backward "\n\^_") + (narrow-to-region (point) (point-max))) + (rmail-count-new-messages t) + (when (rmail-summary-exists) + (rmail-select-summary + (rmail-update-summary))) + (rmail-show-message msg)) + (save-buffer))))) + (kill-buffer tmpbuf))) + +(defun gnus-convert-article-to-rmail () + "Convert article in current buffer to Rmail message format." + (let ((buffer-read-only nil)) + ;; Convert article directly into Babyl format. + (goto-char (point-min)) + (insert "\^L\n0, unseen,,\n*** EOOH ***\n") + (while (search-forward "\n\^_" nil t) ;single char + (replace-match "\n^_" t t)) ;2 chars: "^" and "_" + (goto-char (point-max)) + (insert "\^_"))) + +;;; gnus-rmail.el ends here diff --git a/lisp/gnus/gnus-salt.el b/lisp/gnus/gnus-salt.el index b39ee32f118..3189655c8ad 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 3b78a405fdb..c852986ae61 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 424f11a6b96..369df81d9bd 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: @@ -163,10 +167,9 @@ Instead, use this: This variable can also be set per-server." :type '(repeat string)) -(defcustom gnus-search-swish++-remove-prefix (concat (getenv "HOME") "/Mail/") +(defcustom gnus-search-swish++-remove-prefix (expand-file-name "Mail/" "~") "The prefix to remove from each file name returned by swish++ -in order to get a group name (albeit with / instead of .). This is a -regular expression. +in order to get a group name (albeit with / instead of .). This variable can also be set per-server." :type 'regexp) @@ -200,10 +203,9 @@ This variable can also be set per-server." :type '(repeat string) :version "28.1") -(defcustom gnus-search-swish-e-remove-prefix (concat (getenv "HOME") "/Mail/") +(defcustom gnus-search-swish-e-remove-prefix (expand-file-name "Mail/" "~") "The prefix to remove from each file name returned by swish-e -in order to get a group name (albeit with / instead of .). This is a -regular expression. +in order to get a group name (albeit with / instead of .). This variable can also be set per-server." :type 'regexp @@ -248,7 +250,7 @@ This variable can also be set per-server." :type '(repeat string) :version "28.1") -(defcustom gnus-search-namazu-remove-prefix (concat (getenv "HOME") "/Mail/") +(defcustom gnus-search-namazu-remove-prefix (expand-file-name "Mail/" "~") "The prefix to remove from each file name returned by Namazu in order to get a group name (albeit with / instead of .). @@ -292,10 +294,9 @@ This variable can also be set per-server." :type '(repeat string) :version "28.1") -(defcustom gnus-search-notmuch-remove-prefix (concat (getenv "HOME") "/Mail/") +(defcustom gnus-search-notmuch-remove-prefix (expand-file-name "Mail/" "~") "The prefix to remove from each file name returned by notmuch -in order to get a group name (albeit with / instead of .). This is a -regular expression. +in order to get a group name (albeit with / instead of .). This variable can also be set per-server." :type 'regexp @@ -335,10 +336,9 @@ This variable can also be set per-server." :version "28.1" :type '(repeat string)) -(defcustom gnus-search-mairix-remove-prefix (concat (getenv "HOME") "/Mail/") +(defcustom gnus-search-mairix-remove-prefix (expand-file-name "Mail/" "~") "The prefix to remove from each file name returned by mairix -in order to get a group name (albeit with / instead of .). This is a -regular expression. +in order to get a group name (albeit with / instead of .). This variable can also be set per-server." :version "28.1" @@ -349,6 +349,41 @@ This variable can also be set per-server." :version "28.1" :type 'boolean) +(defcustom gnus-search-mu-program "mu" + "Name of the mu search executable. +This can also be set per-server." + :version "29.1" + :type 'string) + +(defcustom gnus-search-mu-switches nil + "A list of strings, to be given as additional arguments to mu. +Note that this should be a list. I.e., do NOT use the following: + (setq gnus-search-mu-switches \"-u -r\") +Instead, use this: + (setq gnus-search-mu-switches \\='(\"-u\" \"-r\")) +This can also be set per-server." + :version "29.1" + :type '(repeat string)) + +(defcustom gnus-search-mu-remove-prefix (expand-file-name "~/Mail/") + "A prefix to remove from the mu results to get a group name. +Usually this will be set to the path to your mail directory. This +can also be set per-server." + :version "29.1" + :type 'directory) + +(defcustom gnus-search-mu-config-directory (expand-file-name "~/.cache/mu") + "Configuration directory for mu. +This can also be set per-server." + :version "29.1" + :type 'file) + +(defcustom gnus-search-mu-raw-queries-p nil + "If t, all mu engines will only accept raw search query strings. +This can also be set per-server." + :version "29.1" + :type 'boolean) + ;; Options for search language parsing. (defcustom gnus-search-expandable-keys @@ -568,15 +603,13 @@ 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 (decode-time (time-subtract - (apply #'encode-time now) + (encode-time now) (days-to-time (* (string-to-number (match-string 1 value)) (cdr (assoc (match-string 2 value) @@ -595,7 +628,7 @@ REL-DATE, or (current-time) if REL-DATE is nil." ;; If DOW is given, handle that specially. (if (and (seq-elt d-time 6) (null (seq-elt d-time 3))) (decode-time - (time-subtract (apply #'encode-time now) + (time-subtract (encode-time now) (days-to-time (+ (if (> (seq-elt d-time 6) (seq-elt now 6)) @@ -760,6 +793,9 @@ the files in ARTLIST by that search key.") (generate-new-buffer " *gnus-search-"))) (cl-call-next-method engine slots)) +(defclass gnus-search-nnselect (gnus-search-engine) + nil) + (defclass gnus-search-imap (gnus-search-engine) ((literal-plus :initarg :literal-plus @@ -821,7 +857,7 @@ quirks.") :documentation "Location of the config file, if any.") (remove-prefix :initarg :remove-prefix - :initform (concat (getenv "HOME") "/Mail/") + :initform (expand-file-name "Mail/" "~") :type string :documentation "The path to the directory where the indexed mails are @@ -902,16 +938,30 @@ quirks.") (raw-queries-p :initform (symbol-value 'gnus-search-notmuch-raw-queries-p)))) +(defclass gnus-search-mu (gnus-search-indexed) + ((program + :initform (symbol-value 'gnus-search-mu-program)) + (remove-prefix + :initform (symbol-value 'gnus-search-mu-remove-prefix)) + (switches + :initform (symbol-value 'gnus-search-mu-switches)) + (config-directory + :initform (symbol-value 'gnus-search-mu-config-directory)) + (raw-queries-p + :initform (symbol-value 'gnus-search-mu-raw-queries-p)))) + (define-obsolete-variable-alias 'nnir-method-default-engines 'gnus-search-default-engines "28.1") -(defcustom gnus-search-default-engines '((nnimap . gnus-search-imap)) +(defcustom gnus-search-default-engines '((nnimap . gnus-search-imap) + (nnselect . gnus-search-nnselect)) "Alist of default search engines keyed by server method." :version "26.1" :type `(repeat (cons (choice (const nnimap) (const nntp) (const nnspool) (const nneething) (const nndir) (const nnmbox) (const nnml) (const nnmh) (const nndraft) - (const nnfolder) (const nnmaildir)) + (const nnfolder) (const nnmaildir) + (const nnselect)) (choice ,@(mapcar (lambda (el) (list 'const (intern (car el)))) @@ -1008,6 +1058,33 @@ Responsible for handling and, or, and parenthetical expressions.") unseen all old new or not) "Known IMAP search keys.") +(autoload 'nnselect-categorize "nnselect") +(autoload 'nnselect-get-artlist "nnselect" nil nil 'macro) +(autoload 'ids-by-group "nnselect") +;; nnselect interface +(cl-defmethod gnus-search-run-search ((_engine gnus-search-nnselect) + _srv query-spec groups) + (let ((artlist [])) + (dolist (group groups) + (let* ((gnus-newsgroup-selection (nnselect-get-artlist group)) + (group-spec + (nnselect-categorize + (mapcar 'car + (ids-by-group + (number-sequence 1 + (length gnus-newsgroup-selection)))) + (lambda (x) + (gnus-group-server x))))) + (setq artlist + (vconcat artlist + (seq-intersection + gnus-newsgroup-selection + (gnus-search-run-query + (list (cons 'search-query-spec query-spec) + (cons 'search-group-spec group-spec)))))))) + artlist)) + + ;; imap interface (cl-defmethod gnus-search-run-search ((engine gnus-search-imap) srv query groups) @@ -1018,7 +1095,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 @@ -1058,11 +1135,11 @@ Responsible for handling and, or, and parenthetical expressions.") q-string))) (while (and (setq group (pop grouplist)) - (or (null single-search) (null artlist))) + (or (null single-search) (= 0 (length artlist)))) (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 +1152,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 +1161,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 +1312,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)) @@ -1255,14 +1332,16 @@ elements are present." (setq dmonth 1)))) (format-time-string "%e-%b-%Y" - (apply #'encode-time - (append '(0 0 0) - (list dday dmonth dyear)))))) + (encode-time 0 0 0 dday dmonth dyear)))) (cl-defmethod gnus-search-imap-handle-string ((engine gnus-search-imap) (str string)) (with-slots (literal-plus) engine - (if (multibyte-string-p str) + ;; TODO: Figure out how Exchange IMAP servers actually work. They + ;; do not accept any CHARSET but US-ASCII, but they do report + ;; Literal+ capability. So what do we do? Will quoted strings + ;; always work? + (if (string-match-p "[^[:ascii:]]" str) ;; If LITERAL+ is available, use it and encode string as ;; UTF-8. (if literal-plus @@ -1318,19 +1397,17 @@ This method is common to all indexed search engines. Returns a list of [group article score] vectors." - (save-excursion - (let* ((qstring (gnus-search-make-query-string engine query)) - (program (slot-value engine 'program)) - (buffer (slot-value engine 'proc-buffer)) - (cp-list (gnus-search-indexed-search-command - engine qstring query groups)) - proc exitstatus) - (set-buffer buffer) + (let* ((qstring (gnus-search-make-query-string engine query)) + (program (slot-value engine 'program)) + (buffer (slot-value engine 'proc-buffer)) + (cp-list (gnus-search-indexed-search-command + engine qstring query groups)) + proc exitstatus) + (with-current-buffer buffer (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) @@ -1346,7 +1423,7 @@ Returns a list of [group article score] vectors." ;; wants it. (when (> gnus-verbose 6) (display-buffer buffer)) - nil)))) + nil)))) (cl-defmethod gnus-search-indexed-parse-output ((engine gnus-search-indexed) server query &optional groups) @@ -1367,18 +1444,27 @@ Returns a list of [group article score] vectors." (when (and f-name (file-readable-p f-name) (null (file-directory-p f-name))) - (setq group - (replace-regexp-in-string - "[/\\]" "." - (replace-regexp-in-string - "/?\\(cur\\|new\\|tmp\\)?/\\'" "" + ;; `expand-file-name' canoncalizes the file name, + ;; specifically collapsing multiple consecutive directory + ;; separators. + (setq f-name (expand-file-name f-name) + group + (delete + "" ; forward slash at root leaves an empty string + (file-name-split (replace-regexp-in-string - "\\`\\." "" - (string-remove-prefix + "\\`\\." "" ; why do we do this? + (string-remove-prefix prefix (file-name-directory f-name)) - nil t) - nil t) - nil t)) + nil t))) + ;; Turn file name segments into a Gnus group name. + group (mapconcat + #'identity + (if (member (car (last group)) + '("new" "tmp" "cur")) + (nbutlast group) + group) + ".")) (setq article (file-name-nondirectory f-name) article ;; TODO: Provide a cleaner way of producing final @@ -1600,19 +1686,26 @@ Namazu provides a little more information, for instance a score." (cp-list (gnus-search-indexed-search-command engine qstring query groups)) thread-ids proc) - (set-buffer proc-buffer) - (erase-buffer) - (setq proc (apply #'start-process (format "search-%s" server) - proc-buffer program cp-list)) - (while (process-live-p proc) - (accept-process-output proc)) - (while (re-search-forward "^thread:\\([^ ]+\\)" (point-max) t) - (push (match-string 1) thread-ids)) + (with-current-buffer proc-buffer + (erase-buffer) + (setq proc (apply #'start-process (format "search-%s" server) + proc-buffer program cp-list)) + (while (process-live-p proc) + (accept-process-output proc)) + (goto-char (point-min)) + (while (re-search-forward + "^thread:\\([^[:space:]\n]+\\)" + (point-max) t) + (cl-pushnew (match-string 1) thread-ids :test #'equal))) (cl-call-next-method engine server - ;; Completely replace the query with our new thread-based one. - (mapconcat (lambda (thrd) (concat "thread:" thrd)) - thread-ids " or ") + ;; If we found threads, completely replace the query with + ;; our new thread-based one. + (if thread-ids + `((query . ,(mapconcat (lambda (thrd) + (concat "thread:" thrd)) + thread-ids " or "))) + query) nil))) (cl-call-next-method engine server query groups))) @@ -1625,16 +1718,16 @@ Namazu provides a little more information, for instance a score." (let ((limit (alist-get 'limit query)) (thread (alist-get 'thread query))) (with-slots (switches config-file) engine - `(,(format "--config=%s" config-file) - "search" - ,(if thread - "--output=threads" - "--output=files") - "--duplicate=1" ; I have found this necessary, I don't know why. - ,@switches - ,(if limit (format "--limit=%d" limit) "") - ,qstring - )))) + (append + (list (format "--config=%s" config-file) + "search" + (if thread + "--output=threads" + "--output=files")) + (unless thread '("--duplicate=1")) + (when limit (list (format "--limit=%d" limit))) + switches + (list qstring))))) ;;; Mairix interface @@ -1807,6 +1900,101 @@ Assume \"size\" key is equal to \"larger\"." (when (alist-get 'thread query) (list "-t")) (list qstring)))) +;;; Mu interface + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-mu) + (expr list)) + (cl-case (car expr) + (recipient (setf (car expr) 'recip)) + (address (setf (car expr) 'contact)) + (id (setf (car expr) 'msgid)) + (attachment (setf (car expr) 'file))) + (cl-flet () + (cond + ((consp (car expr)) + (format "(%s)" (gnus-search-transform engine expr))) + ;; Explicitly leave out 'date as gnus-search will encode it + ;; first; it is handled later + ((memq (car expr) '(cc c bcc h from f to t subject s body b + maildir m msgid i prio p flag g d + size z embed e file j mime y tag x + list v)) + (format "%s:%s" (car expr) + (if (string-match "\\`\\*" (cdr expr)) + (replace-match "" nil nil (cdr expr)) + (cdr expr)))) + ((eq (car expr) 'mark) + (format "flag:%s" (gnus-search-mu-handle-flag (cdr expr)))) + ((eq (car expr) 'date) + (format "date:%s" (gnus-search-mu-handle-date (cdr expr)))) + ((eq (car expr) 'before) + (format "date:..%s" (gnus-search-mu-handle-date (cdr expr)))) + ((eq (car expr) 'since) + (format "date:%s.." (gnus-search-mu-handle-date (cdr expr)))) + (t (ignore-errors (cl-call-next-method)))))) + +(defun gnus-search-mu-handle-date (date) + (if (stringp date) + date + (pcase date + (`(nil ,m nil) + (nth (1- m) gnus-english-month-names)) + (`(nil nil ,y) + (number-to-string y)) + ;; mu prefers ISO date YYYY-MM-DD HH:MM:SS + (`(,d ,m nil) + (let* ((ct (decode-time)) + (cm (decoded-time-month ct)) + (cy (decoded-time-year ct)) + (y (if (> cm m) + cy + (1- cy)))) + (format "%d-%02d-%02d" y m d))) + (`(nil ,m ,y) + (format "%d-%02d" y m)) + (`(,d ,m ,y) + (format "%d-%02d-%02d" y m d))))) + +(defun gnus-search-mu-handle-flag (flag) + ;; Only change what doesn't match + (cond ((string= flag "flag") + "flagged") + ((string= flag "read") + "seen") + (t + flag))) + +(cl-defmethod gnus-search-indexed-extract ((_engine gnus-search-mu)) + (prog1 + (let ((bol (line-beginning-position)) + (eol (line-end-position))) + (list (buffer-substring-no-properties bol eol) + 100)) + (move-beginning-of-line 2))) + +(cl-defmethod gnus-search-indexed-search-command ((engine gnus-search-mu) + (qstring string) + query &optional groups) + (let ((limit (alist-get 'limit query)) + (thread (alist-get 'thread query))) + (with-slots (switches config-directory) engine + `("find" ; command must come first + "--nocolor" ; mu will always give coloured output otherwise + ,(format "--muhome=%s" config-directory) + ,@switches + ,(if thread "-r" "") + ,(if limit (format "--maxnum=%d" limit) "") + ,qstring + ,@(if groups + `("and" "(" + ,@(nbutlast (mapcan (lambda (x) + (list (concat "maildir:/" x) "or")) + groups)) + ")") + "") + "--format=plain" + "--fields=l")))) + ;;; Find-grep interface (cl-defmethod gnus-search-transform-expression ((_engine gnus-search-find-grep) @@ -1836,8 +2024,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 +2080,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 +2114,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 @@ -1941,9 +2129,9 @@ Assume \"size\" key is equal to \"larger\"." (defun gnus-search-prepare-query (query-spec) "Accept a search query in raw format, and prepare it. QUERY-SPEC is an alist produced by functions such as -`gnus-group-make-search-group', and contains at least a 'query +`gnus-group-make-search-group', and contains at least a `query' key, and possibly some meta keys. This function extracts any -additional meta keys from the 'query string, and parses the +additional meta keys from the `query' string, and parses the remaining string, then adds all that to the top-level spec." (let ((query (alist-get 'query query-spec)) val) diff --git a/lisp/gnus/gnus-srvr.el b/lisp/gnus/gnus-srvr.el index 9c17b7e8133..a520bfcd8b1 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 301120e4ee5..7b5721fafbb 100644 --- a/lisp/gnus/gnus-start.el +++ b/lisp/gnus/gnus-start.el @@ -329,10 +329,10 @@ with the subscription method in this variable." "If non-nil, Gnus will offer to subscribe hierarchically. When a new hierarchy appears, Gnus will ask the user: -'alt.binaries': Do you want to subscribe to this hierarchy? ([d]ys): +Descend hierarchy alt.binaries? ([y]nsq): -If the user pressed `d', Gnus will descend the hierarchy, `y' will -subscribe to all newsgroups in the hierarchy and `s' will skip this +If the user pressed `y', Gnus will descend the hierarchy, `s' will +subscribe to all newsgroups in the hierarchy and `n' will skip this hierarchy in its entirety." :group 'gnus-group-new :type 'boolean) @@ -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. @@ -1882,13 +1884,12 @@ The info element is shared with the same element of (ranges (gnus-info-read info)) news article) (while articles - (when (gnus-member-of-range - (setq article (pop articles)) ranges) + (when (range-member-p (setq article (pop articles)) ranges) (push article news))) (when news ;; Enter this list into the group info. (setf (gnus-info-read info) - (gnus-remove-from-range (gnus-info-read info) (nreverse news))) + (range-remove (gnus-info-read info) (nreverse news))) ;; Set the number of unread articles in gnus-newsrc-hashtb. (gnus-get-unread-articles-in-group info (gnus-active group)) @@ -2360,10 +2361,10 @@ The form should return either t or nil." ticked (cdr (assq 'tick marks))) (when (or dormant ticked) (setf (gnus-info-read info) - (gnus-add-to-range + (range-add-list (gnus-info-read info) - (nconc (gnus-uncompress-range dormant) - (gnus-uncompress-range ticked))))))))) + (nconc (range-uncompress dormant) + (range-uncompress ticked))))))))) (defun gnus-load (file) "Load FILE, but in such a way that read errors can be reported." @@ -2455,8 +2456,7 @@ The form should return either t or nil." (unless (nthcdr 3 info) (nconc info (list nil))) (setf (gnus-info-marks info) - (list (cons 'tick (gnus-compress-sequence - (sort (cdr m) #'<) t)))))) + (list (cons 'tick (range-compress-list (sort (cdr m) #'<))))))) (setq newsrc killed) (while newsrc (setcar newsrc (caar newsrc)) @@ -2731,7 +2731,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 3f350bffb31..a4f98c91573 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -1182,8 +1182,8 @@ mark: The article's mark. uncached: Non-nil if the article is uncached." :group 'gnus-summary-visual :type '(repeat (cons (sexp :tag "Form" nil) - face))) -(put 'gnus-summary-highlight 'risky-local-variable t) + face)) + :risky t) (defcustom gnus-alter-header-function nil "Function called to allow alteration of article header structures. @@ -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) @@ -2889,45 +2887,11 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs)))) (defvar gnus-summary-tool-bar-map nil) -;; Note: The :set function in the `gnus-summary-tool-bar*' variables will only -;; affect _new_ message buffers. We might add a function that walks thru all -;; summary-mode buffers and force the update. -(defun gnus-summary-tool-bar-update (&optional symbol value) - "Update summary mode toolbar. -Setter function for custom variables." - (setq-default gnus-summary-tool-bar-map nil) - (when symbol - ;; When used as ":set" function: - (set-default symbol value)) - (when (gnus-buffer-live-p gnus-summary-buffer) - (with-current-buffer gnus-summary-buffer - (gnus-summary-make-tool-bar)))) - -(defcustom gnus-summary-tool-bar (if (eq gmm-tool-bar-style 'gnome) - 'gnus-summary-tool-bar-gnome - 'gnus-summary-tool-bar-retro) - "Specifies the Gnus summary tool bar. - -It can be either a list or a symbol referring to a list. See -`gmm-tool-bar-from-list' for the format of the list. The -default key map is `gnus-summary-mode-map'. - -Pre-defined symbols include `gnus-summary-tool-bar-gnome' and -`gnus-summary-tool-bar-retro'." - :type '(choice (const :tag "GNOME style" gnus-summary-tool-bar-gnome) - (const :tag "Retro look" gnus-summary-tool-bar-retro) - (repeat :tag "User defined list" gmm-tool-bar-item) - (symbol)) - :version "23.1" ;; No Gnus - :initialize 'custom-initialize-default - :set 'gnus-summary-tool-bar-update - :group 'gnus-summary) - -(defcustom gnus-summary-tool-bar-gnome +(defcustom gnus-summary-tool-bar '((gnus-summary-post-news "mail/compose" nil) - (gnus-summary-insert-new-articles "mail/inbox" nil - :visible (or (not gnus-agent) - gnus-plugged)) + (gnus-summary-insert-new-articles + "mail/inbox" nil + :visible (or (not gnus-agent) gnus-plugged)) (gnus-summary-reply-with-original "mail/reply") (gnus-summary-reply "mail/reply" nil :visible nil) (gnus-summary-followup-with-original "mail/reply-all") @@ -2937,17 +2901,10 @@ Pre-defined symbols include `gnus-summary-tool-bar-gnome' and (gnus-summary-search-article-forward "search" nil :visible nil) (gnus-summary-print-article "print") (gnus-summary-tick-article-forward "flag-followup" nil :visible nil) - ;; Some new commands that may need more suitable icons: (gnus-summary-save-newsrc "save" nil :visible nil) - ;; (gnus-summary-show-article "stock_message-display" nil :visible nil) (gnus-summary-prev-article "left-arrow") (gnus-summary-next-article "right-arrow") (gnus-summary-next-page "next-page") - ;; (gnus-summary-enter-digest-group "right_arrow" nil :visible nil) - ;; - ;; Maybe some sort-by-... could be added: - ;; (gnus-summary-sort-by-author "sort-a-z" nil :visible nil) - ;; (gnus-summary-sort-by-date "sort-1-9" nil :visible nil) (gnus-summary-mark-as-expirable "delete" nil :visible (gnus-check-backend-function 'request-expire-articles @@ -2961,64 +2918,25 @@ Pre-defined symbols include `gnus-summary-tool-bar-gnome' and "mail/not-spam" nil :visible (and (fboundp 'spam-group-spam-contents-p) (spam-group-spam-contents-p gnus-newsgroup-name))) - ;; (gnus-summary-exit "exit") (gmm-customize-mode "preferences" t :help "Edit mode preferences") (gnus-info-find-node "help")) - "List of functions for the summary tool bar (GNOME style). - -See `gmm-tool-bar-from-list' for the format of the list." - :type '(repeat gmm-tool-bar-item) - :version "23.1" ;; No Gnus - :initialize 'custom-initialize-default - :set 'gnus-summary-tool-bar-update - :group 'gnus-summary) + "Specifies the Gnus summary tool bar. -(defcustom gnus-summary-tool-bar-retro - '((gnus-summary-prev-unread-article "gnus/prev-ur") - (gnus-summary-next-unread-article "gnus/next-ur") - (gnus-summary-post-news "gnus/post") - (gnus-summary-followup-with-original "gnus/fuwo") - (gnus-summary-followup "gnus/followup") - (gnus-summary-reply-with-original "gnus/reply-wo") - (gnus-summary-reply "gnus/reply") - (gnus-summary-caesar-message "gnus/rot13") - (gnus-uu-decode-uu "gnus/uu-decode") - (gnus-summary-save-article-file "gnus/save-aif") - (gnus-summary-save-article "gnus/save-art") - (gnus-uu-post-news "gnus/uu-post") - (gnus-summary-catchup "gnus/catchup") - (gnus-summary-catchup-and-exit "gnus/cu-exit") - (gnus-summary-exit "gnus/exit-summ") - ;; Some new command that may need more suitable icons: - (gnus-summary-print-article "gnus/print" nil :visible nil) - (gnus-summary-mark-as-expirable "gnus/close" nil :visible nil) - (gnus-summary-save-newsrc "gnus/save" nil :visible nil) - ;; (gnus-summary-enter-digest-group "gnus/right_arrow" nil :visible nil) - (gnus-summary-search-article-forward "gnus/search" nil :visible nil) - ;; (gnus-summary-insert-new-articles "gnus/paste" nil :visible nil) - ;; (gnus-summary-toggle-threads "gnus/open" nil :visible nil) - ;; - (gnus-info-find-node "gnus/help" nil :visible nil)) - "List of functions for the summary tool bar (retro look). - -See `gmm-tool-bar-from-list' for the format of the list." - :type '(repeat gmm-tool-bar-item) - :version "23.1" ;; No Gnus - :initialize 'custom-initialize-default - :set 'gnus-summary-tool-bar-update +It can be either a list or a symbol referring to a list. See +`gmm-tool-bar-from-list' for the format of the list. The +default key map is `gnus-summary-mode-map'." + :type '(choice (repeat :tag "User defined list" gmm-tool-bar-item) + (symbol)) + :version "29.1" :group 'gnus-summary) -(defcustom gnus-summary-tool-bar-zap-list t - "List of icon items from the global tool bar. -These items are not displayed in the Gnus summary mode tool bar. - -See `gmm-tool-bar-from-list' for the format of the list." - :type 'gmm-tool-bar-zap-list - :version "23.1" ;; No Gnus - :initialize 'custom-initialize-default - :set 'gnus-summary-tool-bar-update - :group 'gnus-summary) +(defvar gnus-summary-tool-bar-gnome nil) +(make-obsolete-variable 'gnus-summary-tool-bar-gnome nil "29.1") +(defvar gnus-summary-tool-bar-retro nil) +(make-obsolete-variable 'gnus-summary-tool-bar-retro nil "29.1") +(defvar gnus-summary-tool-bar-zap-list t) +(make-obsolete-variable 'gnus-summary-tool-bar-zap-list nil "29.1") (defvar image-load-path) (defvar tool-bar-map) @@ -3970,10 +3888,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 +4921,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." @@ -5768,7 +5675,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." ;; (let ((n (cdr (gnus-active group)))) ;; (lambda () (> number (- n display)))) (setq select-articles - (gnus-uncompress-range + (range-uncompress (cons (let ((tmp (- (cdr (gnus-active group)) display))) (if (> tmp 0) tmp @@ -5941,7 +5848,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." "Find out what articles the user wants to read." (let* ((only-read-p t) (articles - (gnus-list-range-difference + (range-list-difference ;; Select all articles if `read-all' is non-nil, or if there ;; are no unread articles. (if (or read-all @@ -5956,13 +5863,13 @@ If SELECT-ARTICLES, only select those articles from GROUP." (or (if gnus-newsgroup-maximum-articles (let ((active (gnus-active group))) - (gnus-uncompress-range + (range-uncompress (cons (max (car active) (- (cdr active) gnus-newsgroup-maximum-articles -1)) (cdr active)))) - (gnus-uncompress-range (gnus-active group))) + (range-uncompress (gnus-active group))) (gnus-cache-articles-in-group group)) ;; Select only the "normal" subset of articles. (setq only-read-p nil) @@ -6053,7 +5960,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." (defun gnus-killed-articles (killed articles) (let (out) (while articles - (when (inline (gnus-member-of-range (car articles) killed)) + (when (inline (range-member-p (car articles) killed)) (push (car articles) out)) (setq articles (cdr articles))) out)) @@ -6091,7 +5998,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." ;; Adjust "simple" lists - compressed yet unsorted ((eq mark-type 'list) ;; Simultaneously uncompress and clip to active range - ;; See gnus-uncompress-range for a description of possible marks + ;; See range-uncompress for a description of possible marks (let (l lh) (if (not (cadr marks)) (set var nil) @@ -6190,10 +6097,10 @@ If SELECT-ARTICLES, only select those articles from GROUP." ;; When exiting the group, everything that's previously been ;; unseen is now seen. (when (eq (cdr type) 'seen) - (setq list (gnus-range-add list gnus-newsgroup-unseen))) + (setq list (range-concat list gnus-newsgroup-unseen))) (when (eq (gnus-article-mark-to-type (cdr type)) 'list) - (setq list (gnus-compress-sequence (set symbol (sort list #'<)) t))) + (setq list (range-compress-list (set symbol (sort list #'<))))) (when (and (gnus-check-backend-function 'request-set-mark gnus-newsgroup-name) @@ -6202,20 +6109,19 @@ If SELECT-ARTICLES, only select those articles from GROUP." ;; Don't do anything about marks for articles we ;; didn't actually get any headers for. (del - (gnus-list-range-intersection + (range-list-intersection gnus-newsgroup-articles - (gnus-remove-from-range (copy-tree old) list))) + (range-remove (copy-tree old) list))) (add - (gnus-list-range-intersection + (range-list-intersection gnus-newsgroup-articles - (gnus-remove-from-range - (copy-tree list) old)))) + (range-remove (copy-tree list) old)))) (when add (push (list add 'add (list (cdr type))) delta-marks)) (when del ;; Don't delete marks from outside the active range. ;; This shouldn't happen, but is a sanity check. - (setq del (gnus-sorted-range-intersection + (setq del (range-intersection (gnus-active gnus-newsgroup-name) del)) (push (list del 'del (list (cdr type))) delta-marks)))) @@ -6399,7 +6305,7 @@ The resulting hash table is returned, or nil if no Xrefs were found." (setq ninfo (cons 1 (1- (car active)))) (setq ninfo (gnus-info-read info))) ;; Then we add the read articles to the range. - (gnus-add-to-range + (range-add-list ninfo (setq articles (sort articles #'<)))))) (defun gnus-group-make-articles-read (group articles) @@ -6980,10 +6886,10 @@ displayed, no centering will be performed." (marked (gnus-info-marks info)) (active (gnus-active group))) (and info active - (gnus-list-range-difference - (gnus-list-range-difference + (range-list-difference + (range-list-difference (gnus-sorted-complement - (gnus-uncompress-range + (range-uncompress (if gnus-newsgroup-maximum-articles (cons (max (car active) (- (cdr active) @@ -7142,12 +7048,11 @@ The prefix argument ALL means to select all articles." (when group (when gnus-newsgroup-kill-headers (setq gnus-newsgroup-killed - (gnus-compress-sequence + (range-compress-list (gnus-sorted-union - (gnus-list-range-intersection + (range-list-intersection gnus-newsgroup-unselected gnus-newsgroup-killed) - gnus-newsgroup-unreads) - t))) + gnus-newsgroup-unreads)))) (unless (listp (cdr gnus-newsgroup-killed)) (setq gnus-newsgroup-killed (list gnus-newsgroup-killed))) (let ((headers gnus-newsgroup-headers) @@ -7208,7 +7113,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 +7176,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 +7235,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 +7266,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 +7968,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 +8002,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 () @@ -8673,20 +8576,20 @@ these articles." (gnus-fetch-old-headers nil) (gnus-build-sparse-threads nil)) (prog1 - (gnus-summary-limit (if thread-only articles - (nconc articles gnus-newsgroup-limit))) - (gnus-summary-limit-include-matching-articles - "subject" - (regexp-quote (gnus-general-simplify-subject - (mail-header-subject (gnus-id-to-header id))))) - ;; the previous two calls each push a limit onto the limit - ;; stack. the first pop remove the articles that match the - ;; subject, while the second pop gets us back to the state - ;; before we started to deal with the thread. presumably we want - ;; to think of the thread and its associated subject matches as - ;; a single thing so that we need to pop only once to get back - ;; to the original view. - (pop gnus-newsgroup-limits) + (gnus-summary-limit (if thread-only articles + (nconc articles gnus-newsgroup-limit))) + (let ((matching-subject (gnus-general-simplify-subject + (mail-header-subject (gnus-id-to-header id))))) + (when matching-subject + (gnus-summary-limit-include-matching-articles + "subject" + (regexp-quote matching-subject)) + ;; Each of the previous two limit calls push a limit onto + ;; the limit stack. Presumably we want to think of the + ;; thread and its associated subject matches as a single + ;; thing so we probably want a single pop to restore the + ;; original view. Hence we pop this last limit off. + (pop gnus-newsgroup-limits))) (gnus-summary-position-point)))) (defun gnus-summary-limit-include-matching-articles (header regexp) @@ -9462,6 +9365,16 @@ The 1st element is the button named by `gnus-collect-urls-primary-text'." (push primary urls)) (delete-dups urls))) +(defun gnus-collect-urls-from-article () + "Select the article and return the list of URLs in it. +See `gnus-collect-urls'." + (gnus-summary-select-article) + (gnus-with-article-buffer + (article-goto-body) + ;; Back up a char, in case body starts with a button. + (backward-char) + (gnus-collect-urls))) + (defun gnus-shorten-url (url max) "Return an excerpt from URL not exceeding MAX characters." (if (<= (length url) max) @@ -9477,33 +9390,27 @@ The 1st element is the button named by `gnus-collect-urls-primary-text'." "Scan the current article body for links, and offer to browse them. Links are opened using `browse-url' unless a prefix argument is -given: Then `browse-url-secondary-browser-function' is used instead. +given: then `browse-url-secondary-browser-function' is used instead. If only one link is found, browse that directly, otherwise use completion to select a link. The first link marked in the article text with `gnus-collect-urls-primary-text' is the default." (interactive "P" gnus-summary-mode) - (let (urls target) - (gnus-summary-select-article) - (gnus-with-article-buffer - (article-goto-body) - ;; Back up a char, in case body starts with a button. - (backward-char) - (setq urls (gnus-collect-urls)) - (setq target - (cond ((= (length urls) 1) - (car urls)) - ((> (length urls) 1) - (completing-read - (format-prompt "URL to browse" - (gnus-shorten-url (car urls) 40)) - urls nil t nil nil (car urls))))) - (if target - (if external - (funcall browse-url-secondary-browser-function target) - (browse-url target)) - (message "No URLs found."))))) + (let* ((urls (gnus-collect-urls-from-article)) + (target + (cond ((= (length urls) 1) + (car urls)) + ((> (length urls) 1) + (completing-read + (format-prompt "URL to browse" + (gnus-shorten-url (car urls) 40)) + urls nil t nil nil (car urls)))))) + (if target + (if external + (funcall browse-url-secondary-browser-function target) + (browse-url target)) + (message "No URLs found.")))) (defun gnus-summary-isearch-article (&optional regexp-p) "Do incremental search forward on the current article. @@ -9908,7 +9815,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. @@ -10257,8 +10163,8 @@ ACTION can be either `move' (the default), `crosspost' or `copy'." (cdr art-group)) (push 'read to-marks) (setf (gnus-info-read info) - (gnus-add-to-range (gnus-info-read info) - (list (cdr art-group))))) + (range-add-list (gnus-info-read info) + (list (cdr art-group))))) ;; See whether the article is to be put in the cache. (let* ((expirable (gnus-group-auto-expirable-p to-group)) @@ -10501,7 +10407,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 +10416,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))) @@ -10542,7 +10447,7 @@ This will be the case if the article has both been mailed and posted." ;; This backend supports expiry. (let* ((total (gnus-group-total-expirable-p gnus-newsgroup-name)) (expirable - (gnus-list-range-difference + (range-list-difference (if total (progn ;; We need to update the info for @@ -11915,7 +11820,8 @@ Returns nil if no threads were there to be hidden." (beginning-of-line) (let ((start (point)) (starteol (line-end-position)) - (article (gnus-summary-article-number))) + (article (unless (gnus-summary-article-intangible-p) + (gnus-summary-article-number)))) ;; Go forward until either the buffer ends or the subthread ends. (when (and (not (eobp)) (or (zerop (gnus-summary-next-thread 1 t)) @@ -11929,7 +11835,9 @@ Returns nil if no threads were there to be hidden." (let ((ol (make-overlay starteol (point) nil t nil))) (overlay-put ol 'invisible 'gnus-sum) (overlay-put ol 'evaporate t))) - (gnus-summary-goto-subject article) + (if article + (gnus-summary-goto-subject article) + (gnus-summary-position-point)) ;; We moved backward past the start point (invisible thread?) (when (> start (point)) (goto-char starteol))) @@ -12888,8 +12796,8 @@ UNREAD is a sorted list." (gnus-find-method-for-group group) 'server-marks) (gnus-check-backend-function 'request-set-mark group)) - (let ((del (gnus-remove-from-range (gnus-info-read info) read)) - (add (gnus-remove-from-range read (gnus-info-read info)))) + (let ((del (range-remove (gnus-info-read info) read)) + (add (range-remove read (gnus-info-read info)))) (when (or add del) (unless (gnus-check-group group) (error "Can't open server for %s" group)) @@ -13147,10 +13055,10 @@ If ALL is a number, fetch this number of articles." ;; Some nntp servers lie about their active range. When ;; this happens, the active range can be in the millions. ;; Use a compressed range to avoid creating a huge list. - (gnus-range-difference - (gnus-range-difference (list gnus-newsgroup-active) old) + (range-difference + (range-difference (list gnus-newsgroup-active) old) gnus-newsgroup-unexist)) - (setq len (gnus-range-length older)) + (setq len (range-length older)) (cond ((null older) nil) ((numberp all) @@ -13167,9 +13075,9 @@ If ALL is a number, fetch this number of articles." (push max older) (setq all (1- all) max (1- max)))))) - (setq older (gnus-uncompress-range older)))) + (setq older (range-uncompress older)))) (all - (setq older (gnus-uncompress-range older))) + (setq older (range-uncompress older))) (t (when (and (numberp gnus-large-newsgroup) (> len gnus-large-newsgroup)) @@ -13204,7 +13112,7 @@ If ALL is a number, fetch this number of articles." (push max older) (setq all (1- all) max (1- max)))))))))) - (setq older (gnus-uncompress-range older)))) + (setq older (range-uncompress older)))) (if (not older) (message "No old news.") (gnus-summary-insert-articles older) @@ -13294,6 +13202,8 @@ BOOKMARK is a bookmark name or a bookmark record." (buffer . ,(current-buffer)) . ,(bookmark-get-bookmark-record bookmark))))) +(put 'gnus-summary-bookmark-jump 'bookmark-handler-type "Gnus") + (gnus-summary-make-all-marking-commands) (provide 'gnus-sum) diff --git a/lisp/gnus/gnus-topic.el b/lisp/gnus/gnus-topic.el index 9493b02d062..fa942bee8e8 100644 --- a/lisp/gnus/gnus-topic.el +++ b/lisp/gnus/gnus-topic.el @@ -650,6 +650,7 @@ articles in the topic and its subtopics." (let* ((visible (if visiblep "" "...")) (level level) (name name) + (entries entries) (indentation (make-string (* gnus-topic-indent-level level) ? )) (total-number-of-articles unread) (number-of-groups (length entries)) @@ -677,7 +678,7 @@ articles in the topic and its subtopics." (defun gnus-topic-update-topics-containing-group (group) "Update all topics that have GROUP as a member." - (when (and (eq major-mode 'gnus-topic-mode) + (when (and (derived-mode-p 'gnus-group-mode) gnus-topic-mode) (save-excursion (let ((alist gnus-topic-alist)) @@ -693,7 +694,7 @@ articles in the topic and its subtopics." (defun gnus-topic-update-topic () "Update all parent topics to the current group." - (when (and (eq major-mode 'gnus-topic-mode) + (when (and (derived-mode-p 'gnus-group-mode) gnus-topic-mode) (let ((group (gnus-group-group-name)) (m (point-marker)) @@ -747,8 +748,8 @@ articles in the topic and its subtopics." (car type) (car gnus-group-list-mode) (cdr gnus-group-list-mode))) (all-groups (gnus-topic-find-groups - (car type) (car gnus-group-list-mode) - (cdr gnus-group-list-mode) nil t)) + (car type) (car gnus-group-list-mode) + (cdr gnus-group-list-mode) nil t)) entry) (while children (cl-incf unread (gnus-topic-unread (caar (pop children))))) @@ -787,8 +788,8 @@ articles in the topic and its subtopics." (car type) (car gnus-group-list-mode) (cdr gnus-group-list-mode))) (all-groups (gnus-topic-find-groups - (car type) (car gnus-group-list-mode) - (cdr gnus-group-list-mode) t)) + (car type) (car gnus-group-list-mode) + (cdr gnus-group-list-mode) nil t)) (parent (gnus-topic-parent-topic topic-name)) (all-entries entries) (unread 0) @@ -1056,63 +1057,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 406d0a51d52..8c2be7b07e4 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 662817255bb..218a4d242b2 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")) @@ -561,7 +562,7 @@ If N, return the Nth ancestor instead." buffer)) (define-obsolete-function-alias 'gnus-buffer-exists-p - 'gnus-buffer-live-p "27.1") + #'gnus-buffer-live-p "27.1") (defun gnus-horizontal-recenter () "Recenter the current buffer horizontally." @@ -679,7 +680,7 @@ yield \"nnimap:yxa\"." (defun gnus-turn-off-edit-menu (type) "Turn off edit menu in `gnus-TYPE-mode-map'." (define-key (symbol-value (intern (format "gnus-%s-mode-map" type))) - [menu-bar edit] 'undefined)) + [menu-bar edit] #'undefined)) (defvar print-string-length) @@ -857,126 +858,9 @@ variables and then do only the assignment atomically." `(let ((inhibit-quit gnus-atomic-be-safe)) ,@forms)) -;;; Functions for saving to babyl/mail files. - -(require 'rmail) -(autoload 'rmail-update-summary "rmailsum") - (defvar mm-text-coding-system) - (declare-function mm-append-to-file "mm-util" (start end filename &optional codesys inhibit)) -(declare-function rmail-swap-buffers-maybe "rmail" ()) -(declare-function rmail-maybe-set-message-counters "rmail" ()) -(declare-function rmail-count-new-messages "rmail" (&optional nomsg)) -(declare-function rmail-summary-exists "rmail" ()) -(declare-function rmail-show-message "rmail" (&optional n no-summary)) -;; Macroexpansion of rmail-select-summary: -(declare-function rmail-summary-displayed "rmail" ()) -(declare-function rmail-pop-to-buffer "rmail" (&rest args)) -(declare-function rmail-maybe-display-summary "rmail" ()) - -(defun gnus-output-to-rmail (filename &optional ask) - "Append the current article to an Rmail file named FILENAME. -In Emacs 22 this writes Babyl format; in Emacs 23 it writes mbox unless -FILENAME exists and is Babyl format." - (require 'rmail) - (require 'mm-util) - (require 'nnmail) - ;; Some of this codes is borrowed from rmailout.el. - (setq filename (expand-file-name filename)) - ;; FIXME should we really be messing with this defcustom? - ;; It is not needed for the operation of this function. - (if (boundp 'rmail-default-rmail-file) - (setq rmail-default-rmail-file filename) ; 22 - (setq rmail-default-file filename)) ; 23 - (let ((artbuf (current-buffer)) - (tmpbuf (gnus-get-buffer-create " *Gnus-output*")) - ;; Babyl rmail.el defines this, mbox does not. - (babyl (fboundp 'rmail-insert-rmail-file-header))) - (save-excursion - ;; Note that we ignore the possibility of visiting a Babyl - ;; format buffer in Emacs 23, since Rmail no longer supports that. - (or (get-file-buffer filename) - (progn - ;; In case someone wants to write to a Babyl file from Emacs 23. - (when (file-exists-p filename) - (setq babyl (mail-file-babyl-p filename)) - t)) - (if (or (not ask) - (gnus-yes-or-no-p - (concat "\"" filename "\" does not exist, create it? "))) - (let ((file-buffer (create-file-buffer filename))) - (with-current-buffer file-buffer - (if (fboundp 'rmail-insert-rmail-file-header) - (rmail-insert-rmail-file-header)) - (let ((require-final-newline nil) - (coding-system-for-write mm-text-coding-system)) - (gnus-write-buffer filename))) - (kill-buffer file-buffer)) - (error "Output file does not exist"))) - (set-buffer tmpbuf) - (erase-buffer) - (insert-buffer-substring artbuf) - (if babyl - (gnus-convert-article-to-rmail) - ;; Non-Babyl case copied from gnus-output-to-mail. - (goto-char (point-min)) - (if (looking-at "From ") - (forward-line 1) - (insert "From nobody " (current-time-string) "\n")) - (let (case-fold-search) - (while (re-search-forward "^From " nil t) - (beginning-of-line) - (insert ">")))) - ;; Decide whether to append to a file or to an Emacs buffer. - (let ((outbuf (get-file-buffer filename))) - (if (not outbuf) - (progn - (unless babyl ; from gnus-output-to-mail - (let ((buffer-read-only nil)) - (goto-char (point-max)) - (forward-char -2) - (unless (looking-at "\n\n") - (goto-char (point-max)) - (unless (bolp) - (insert "\n")) - (insert "\n")))) - (let ((file-name-coding-system nnmail-pathname-coding-system)) - (mm-append-to-file (point-min) (point-max) filename))) - ;; File has been visited, in buffer OUTBUF. - (set-buffer outbuf) - (let ((buffer-read-only nil) - (msg (and (boundp 'rmail-current-message) - (symbol-value 'rmail-current-message)))) - ;; If MSG is non-nil, buffer is in RMAIL mode. - ;; Compare this with rmail-output-to-rmail-buffer in Emacs 23. - (when msg - (unless babyl - (rmail-swap-buffers-maybe) - (rmail-maybe-set-message-counters)) - (widen) - (unless babyl - (goto-char (point-max)) - ;; Ensure we have a blank line before the next message. - (unless (bolp) - (insert "\n")) - (insert "\n")) - (narrow-to-region (point-max) (point-max))) - (insert-buffer-substring tmpbuf) - (when msg - (when babyl - (goto-char (point-min)) - (widen) - (search-backward "\n\^_") - (narrow-to-region (point) (point-max))) - (rmail-count-new-messages t) - (when (rmail-summary-exists) - (rmail-select-summary - (rmail-update-summary))) - (rmail-show-message msg)) - (save-buffer))))) - (kill-buffer tmpbuf))) (defun gnus-output-to-mail (filename &optional ask) "Append the current article to a mail file named FILENAME." @@ -1034,17 +918,6 @@ FILENAME exists and is Babyl format." (insert-buffer-substring tmpbuf))))) (kill-buffer tmpbuf))) -(defun gnus-convert-article-to-rmail () - "Convert article in current buffer to Rmail message format." - (let ((buffer-read-only nil)) - ;; Convert article directly into Babyl format. - (goto-char (point-min)) - (insert "\^L\n0, unseen,,\n*** EOOH ***\n") - (while (search-forward "\n\^_" nil t) ;single char - (replace-match "\n^_" t t)) ;2 chars: "^" and "_" - (goto-char (point-max)) - (insert "\^_"))) - (defun gnus-map-function (funs arg) "Apply the result of the first function in FUNS to the second, and so on. ARG is passed to the first function." @@ -1081,9 +954,9 @@ ARG is passed to the first function." (with-current-buffer gnus-group-buffer (eq major-mode 'gnus-group-mode)))) -(define-obsolete-function-alias 'gnus-remove-if 'seq-remove "27.1") +(define-obsolete-function-alias 'gnus-remove-if #'seq-remove "27.1") -(define-obsolete-function-alias 'gnus-remove-if-not 'seq-filter "27.1") +(define-obsolete-function-alias 'gnus-remove-if-not #'seq-filter "27.1") (defun gnus-grep-in-list (word list) "Find if a WORD matches any regular expression in the given LIST." @@ -1218,9 +1091,10 @@ ARG is passed to the first function." (defun gnus-byte-compile (form) "Byte-compile FORM if `gnus-use-byte-compile' is non-nil." (if gnus-use-byte-compile - (let ((byte-compile-warnings '(unresolved callargs redefine))) + (let ((byte-compile-warnings '(unresolved callargs redefine)) + (lexical-binding t)) (byte-compile form)) - form)) + (eval form t))) (defun gnus-remassoc (key alist) "Delete by side effect any elements of LIST whose car is `equal' to KEY. @@ -1310,9 +1184,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 @@ -1676,6 +1548,11 @@ lists of strings." (while overlays (delete-overlay (pop overlays))))) +;; This function used to live in this file, but was moved to a +;; separate file to avoid pulling in rmail.el when requiring +;; gnus-util. +(autoload 'gnus-output-to-rmail "gnus-rmail") + (provide 'gnus-util) ;;; gnus-util.el ends here diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index ad7062d84bd..f60c11f985d 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -662,12 +662,11 @@ be used directly.") (gnus-prune-buffers) (cl-pushnew (current-buffer) gnus-buffers)) -(defmacro gnus-kill-buffer (buffer) +(defun gnus-kill-buffer (buffer) "Kill BUFFER and remove from the list of Gnus buffers." - `(let ((buf ,buffer)) - (when (gnus-buffer-live-p buf) - (kill-buffer buf) - (gnus-prune-buffers)))) + (when (gnus-buffer-live-p buffer) + (kill-buffer buffer) + (gnus-prune-buffers))) (defun gnus-buffers () "Return a list of live Gnus buffers." @@ -1467,11 +1466,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).") @@ -1592,7 +1591,7 @@ posting an article." "Alist of group regexps and its initial input of the number of articles." :variable-group gnus-group-parameter :parameter-type '(choice :tag "Initial Input for Large Newsgroup" - (const :tag "All" 'all) + (const :tag "All" all) (integer)) :parameter-document "\ @@ -2528,16 +2527,9 @@ are always t.") ("babel" babel-as-string) ("nnmail" nnmail-split-fancy nnmail-article-group) ("nnvirtual" nnvirtual-catchup-group nnvirtual-convert-headers) - ;; This is only used in message.el, which has an autoload. - ("rmailout" rmail-output) - ;; Next two used in gnus-util, which has autoloads, and contrib/sendmail. - ("rmail" rmail-count-new-messages rmail-show-message - ;; Next two only used in gnus-util. - rmail-summary-exists rmail-select-summary) - ;; 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) + ("gnus-score" :interactive t 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 +2601,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 +2652,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 +2664,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 +3142,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 +3778,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 a0edbf6a2ad..320bc9c3b0e 100644 --- a/lisp/gnus/mail-source.el +++ b/lisp/gnus/mail-source.el @@ -31,6 +31,7 @@ (autoload 'pop3-movemail "pop3") (autoload 'pop3-get-message-count "pop3") (require 'mm-util) +(require 'gnus-range) (require 'message) ;; for `message-directory' (defvar display-time-mail-function) @@ -224,12 +225,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. @@ -415,7 +413,7 @@ the `mail-source-keyword-map' variable." (let* ((type (pop source)) (defaults (cdr (assq type mail-source-keyword-map))) (search '(:max 1)) - found default value keyword user-auth pass-auth) ;; auth-info + found default keyword user-auth pass-auth) ;; auth-info ;; append to the search the useful info from the source and the defaults: ;; user, host, and port @@ -442,22 +440,22 @@ the `mail-source-keyword-map' variable." ;; for each default :SYMBOL, set SYMBOL to the plist value for :SYMBOL ;; using `mail-source-value' to evaluate the plist value (set (mail-source-strip-keyword (setq keyword (car default))) - ;; note the following reasons for this structure: + ;; Note the following reasons for this structure: ;; 1) the auth-sources user and password override everything ;; 2) it avoids macros, so it's cleaner ;; 3) it falls through to the mail-sources and then default values (cond ((and - (eq keyword :user) - (setq user-auth - (plist-get - ;; cache the search result in `found' - (or found - (setq found (nth 0 (apply #'auth-source-search - search)))) - :user))) + (eq keyword :user) + (setq user-auth + (plist-get + ;; cache the search result in `found' + (or found + (setq found (nth 0 (apply #'auth-source-search + search)))) + :user))) user-auth) - ((and + ((and ; cf. 'auth-source-pick-first-password' (eq keyword :password) (setq pass-auth (plist-get @@ -470,9 +468,8 @@ the `mail-source-keyword-map' variable." (if (functionp pass-auth) (setq pass-auth (funcall pass-auth)) pass-auth)) - (t (if (setq value (plist-get source keyword)) - (mail-source-value value) - (mail-source-value (cadr default))))))))) + (t (mail-source-value (or (plist-get source keyword) + (cadr default))))))))) (eval-and-compile (defun mail-source-bind-common-1 () @@ -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)) @@ -1053,8 +1048,6 @@ This only works when `display-time' is enabled." (autoload 'imap-range-to-message-set "imap") (autoload 'nnheader-ms-strip-cr "nnheader") -(autoload 'gnus-compress-sequence "gnus-range") - (defvar mail-source-imap-file-coding-system 'binary "Coding system for the crashbox made by `mail-source-fetch-imap'.") @@ -1072,9 +1065,7 @@ This only works when `display-time' is enabled." (let ((from (format "%s:%s:%s" server user port)) (found 0) (buf (generate-new-buffer " *imap source*")) - (mail-source-string (format "imap:%s:%s" server mailbox)) - (imap-shell-program (or (list program) imap-shell-program)) - remove) + (imap-shell-program (or (list program) imap-shell-program))) (if (and (imap-open server port stream authentication buf) (imap-authenticate user (or (cdr (assoc from mail-source-password-cache)) @@ -1083,8 +1074,10 @@ This only works when `display-time' is enabled." (let ((mailbox-list (if (listp mailbox) mailbox (list mailbox)))) (dolist (mailbox mailbox-list) (when (imap-mailbox-select mailbox nil buf) - (let ((coding-system-for-write mail-source-imap-file-coding-system) - str) + (let ((coding-system-for-write + mail-source-imap-file-coding-system) + (mail-source-string (format "imap:%s:%s" server mailbox)) + str remove) (message "Fetching from %s..." mailbox) (with-temp-file mail-source-crash-box ;; Avoid converting 8-bit chars from inserted strings to diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index cbaa74d61cf..5936d29c9d1 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -48,6 +48,9 @@ (require 'puny) (require 'rmc) ; read-multiple-choice (require 'subr-x) +(require 'yank-media) +(require 'mailcap) +(require 'sendmail) (autoload 'mailclient-send-it "mailclient") @@ -714,7 +717,7 @@ The function accepts 1 parameter which is the matched prefix." (defvar sendmail-program) (cond ((executable-find sendmail-program) #'message-send-mail-with-sendmail) - ((bound-and-true-p 'smtpmail-default-smtp-server) + ((bound-and-true-p smtpmail-default-smtp-server) #'message-smtpmail-send-it) (t #'message-send-mail-with-mailclient))) @@ -2051,7 +2054,7 @@ You must have the \"hashcash\" binary installed, see `hashcash-path'." (autoload 'gnus-groups-from-server "gnus") (autoload 'gnus-open-server "gnus-int") (autoload 'gnus-output-to-mail "gnus-util") -(autoload 'gnus-output-to-rmail "gnus-util") +(autoload 'gnus-output-to-rmail "gnus-rmail") (autoload 'gnus-request-post "gnus-int") (autoload 'gnus-server-string "gnus") (autoload 'message-setup-toolbar "messagexmas") @@ -2870,84 +2873,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 +3158,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)) @@ -3182,8 +3180,7 @@ Like `text-mode', but with these additional commands: (mail-abbrevs-setup)) ((message-mail-alias-type-p 'ecomplete) (ecomplete-setup))) - ;; FIXME: merge the completion tables from ecomplete/bbdb/...? - ;;(add-hook 'completion-at-point-functions #'message-ecomplete-capf nil t) + (add-hook 'completion-at-point-functions #'eudc-capf-complete -1 t) (add-hook 'completion-at-point-functions #'message-completion-function nil t) (unless buffer-file-name (message-set-auto-save-file-name)) @@ -4338,6 +4335,48 @@ Instead, just auto-save the buffer and then bury it." (autoload 'mml-secure-bcc-is-safe "mml-sec") +(defcustom message-server-alist nil + "Alist of rules to generate \"X-Message-SMTP-Method\" header. +The header will be inserted just before the message is sent. +Elements should be of the form (COND . METHOD). +If COND is a string, METHOD will be inserted if the \"From\" +address compares equal with COND. +If COND is a function, METHOD will be inserted if COND returns +a non-nil value when called in the message buffer without any +arguments. If METHOD is nil in this case, the return value of +the function will be inserted instead. +If the buffer already has a\"X-Message-SMTP-Method\" header, +it is left unchanged." + :type '(alist :key-type '(choice + (string :tag "From Address") + (function :tag "Predicate")) + :value-type 'string) + :version "29.1" + :group 'message-sending) + +(defun message-update-smtp-method-header () + "Insert an X-Message-SMTP-Method header according to `message-server-alist'." + (unless (message-fetch-field "X-Message-SMTP-Method") + (let ((from (cadr (mail-extract-address-components + (save-restriction + (widen) + (message-narrow-to-headers-or-head) + (message-fetch-field "From"))))) + method) + (catch 'exit + (dolist (server message-server-alist) + (cond ((functionp (car server)) + (let ((res (funcall (car server)))) + (when res + (setq method (or (cdr server) res)) + (throw 'exit nil)))) + ((and (stringp (car server)) + (string= (car server) from)) + (setq method (cdr server)) + (throw 'exit nil))))) + (when method + (message-add-header (concat "X-Message-SMTP-Method: " method)))))) + (defun message-send (&optional arg) "Send the message in the current buffer. If `message-interactive' is non-nil, wait for success indication or @@ -4351,6 +4390,7 @@ It should typically alter the sending method in some way or other." (undo-boundary) (let ((inhibit-read-only t)) (put-text-property (point-min) (point-max) 'read-only nil)) + (message-update-smtp-method-header) (message-fix-before-sending) (run-hooks 'message-send-hook) (mml-secure-bcc-is-safe) @@ -4766,23 +4806,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 @@ -4863,7 +4905,18 @@ If you always want Gnus to send messages in one piece, set (message-generate-headers '(Lines))) ;; Remove some headers. (message-remove-header message-ignored-mail-headers t) - (mail-encode-encoded-word-buffer)) + (mail-encode-encoded-word-buffer) + ;; Then check for suspicious addresses. + (dolist (hdr '("To" "Cc" "Bcc")) + (let ((addr (message-fetch-field hdr))) + (when (stringp addr) + (dolist (address (mail-header-parse-addresses addr t)) + (when-let ((warning (textsec-suspicious-p + address 'email-address-header))) + (unless (y-or-n-p + (format "Suspicious address: %s; send anyway?" + warning)) + (user-error "Suspicious address %s" address)))))))) (goto-char (point-max)) ;; require one newline at the end. (or (= (preceding-char) ?\n) @@ -5358,7 +5411,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 +5882,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 +5900,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 +6002,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." @@ -7964,7 +8016,18 @@ is for the internal use." (select-safe-coding-system-function nil) message-required-mail-headers message-generate-hashcash - rfc2047-encode-encoded-words) + rfc2047-encode-encoded-words + ;; If `message-sendmail-envelope-from' is `header' then + ;; the envelope-from will be the original sender's + ;; address, not the resender's. But when resending, the + ;; envelope-from should be the resender's address. Defuse + ;; that particular case. + (message-sendmail-envelope-from + (and (not (and (eq message-sendmail-envelope-from + 'obey-mail-envelope-from) + (eq mail-envelope-from 'header))) + (not (eq message-sendmail-envelope-from 'header)) + message-sendmail-envelope-from))) (message-send-mail)) (when gcc (message-goto-eoh) @@ -8103,39 +8166,7 @@ which specify the range to operate on." ;; Support for toolbar (defvar tool-bar-mode) -;; Note: The :set function in the `message-tool-bar*' variables will only -;; affect _new_ message buffers. We might add a function that walks thru all -;; message-mode buffers and force the update. -(defun message-tool-bar-update (&optional symbol value) - "Update message mode toolbar. -Setter function for custom variables." - (setq-default message-tool-bar-map nil) - (when symbol - ;; When used as ":set" function: - (set-default symbol value))) - -(defcustom message-tool-bar (if (eq gmm-tool-bar-style 'gnome) - 'message-tool-bar-gnome - 'message-tool-bar-retro) - "Specifies the message mode tool bar. - -It can be either a list or a symbol referring to a list. See -`gmm-tool-bar-from-list' for the format of the list. The -default key map is `message-mode-map'. - -Pre-defined symbols include `message-tool-bar-gnome' and -`message-tool-bar-retro'." - :type '(repeat gmm-tool-bar-list-item) - :type '(choice (const :tag "GNOME style" message-tool-bar-gnome) - (const :tag "Retro look" message-tool-bar-retro) - (repeat :tag "User defined list" gmm-tool-bar-item) - (symbol)) - :version "23.1" ;; No Gnus - :initialize #'custom-initialize-default - :set #'message-tool-bar-update - :group 'message) - -(defcustom message-tool-bar-gnome +(defcustom message-tool-bar '((ispell-message "spell" nil :vert-only t :visible (not flyspell-mode)) @@ -8151,47 +8182,23 @@ Pre-defined symbols include `message-tool-bar-gnome' and (message-insert-importance-high "important" nil :visible nil) (message-insert-importance-low "unimportant" nil :visible nil) (message-insert-disposition-notification-to "receipt" nil :visible nil)) - "List of items for the message tool bar (GNOME style). - -See `gmm-tool-bar-from-list' for details on the format of the list." - :type '(repeat gmm-tool-bar-item) - :version "23.1" ;; No Gnus - :initialize #'custom-initialize-default - :set #'message-tool-bar-update - :group 'message) + "Specifies the message mode tool bar. -(defcustom message-tool-bar-retro - '(;; Old Emacs 21 icon for consistency. - (message-send-and-exit "mail/send") - (message-kill-buffer "close") - (message-dont-send "cancel") - (mml-attach-file "attach" mml-mode-map) - (ispell-message "spell") - (mml-preview "preview" mml-mode-map) - (message-insert-importance-high "gnus/important") - (message-insert-importance-low "gnus/unimportant") - (message-insert-disposition-notification-to "gnus/receipt")) - "List of items for the message tool bar (retro style). - -See `gmm-tool-bar-from-list' for details on the format of the list." - :type '(repeat gmm-tool-bar-item) - :version "23.1" ;; No Gnus - :initialize #'custom-initialize-default - :set #'message-tool-bar-update +It can be either a list or a symbol referring to a list. See +`gmm-tool-bar-from-list' for the format of the list. The +default key map is `message-mode-map'." + :type '(repeat gmm-tool-bar-list-item) + :type '(choice (repeat :tag "User defined list" gmm-tool-bar-item) + (symbol)) + :version "29.1" :group 'message) -(defcustom message-tool-bar-zap-list - '(new-file open-file dired kill-buffer write-file - print-buffer customize help) - "List of icon items from the global tool bar. -These items are not displayed on the message mode tool bar. - -See `gmm-tool-bar-from-list' for the format of the list." - :type 'gmm-tool-bar-zap-list - :version "23.1" ;; No Gnus - :initialize #'custom-initialize-default - :set #'message-tool-bar-update - :group 'message) +(defvar message-tool-bar-gnome nil) +(make-obsolete-variable 'message-tool-bar-gnome nil "29.1") +(defvar message-tool-bar-retro nil) +(make-obsolete-variable 'message-tool-bar-gnome nil "29.1") +(defvar message-tool-bar-zap-list t) +(make-obsolete-variable 'message-tool-bar-zap-list nil "29.1") (defvar image-load-path) (declare-function image-load-path-for-library "image" @@ -8213,17 +8220,23 @@ When FORCE, rebuild the tool bar." 'message-mode-map)))) message-tool-bar-map) -;;; Group name completion. +;;; Group name and email address completion. (defcustom message-newgroups-header-regexp "^\\(Newsgroups\\|Followup-To\\|Posted-To\\|Gcc\\):" - "Regexp that match headers that lists groups." + "Regexp matching headers that list groups." :group 'message :type 'regexp) +(defcustom message-email-recipient-header-regexp + "^\\([^ :]*-\\)?\\(To\\|B?Cc\\|From\\|Reply-to\\|Mail-Followup-To\\|Mail-Copies-To\\):" + "Regexp matching headers that list email addresses." + :version "29.1" + :type 'regexp) + (defcustom message-completion-alist `((,message-newgroups-header-regexp . ,#'message-expand-group) - ("^\\([^ :]*-\\)?\\(To\\|B?Cc\\|From\\):" . ,#'message-expand-name)) + (,message-email-recipient-header-regexp . ,#'message-expand-name)) "Alist of (RE . FUN). Use FUN for completion on header lines matching RE. FUN should be a function that obeys the same rules as those of `completion-at-point-functions'." @@ -8317,7 +8330,11 @@ regular text mode tabbing command." (defcustom message-expand-name-standard-ui nil "If non-nil, use the standard completion UI in `message-expand-name'. -E.g. this means it will obey `completion-styles' and other such settings." +E.g. this means it will obey `completion-styles' and other such settings. + +If this variable is non-nil and `message-mail-alias-type' is +`ecomplete', `message-self-insert-commands' should probably be +set to nil." :version "27.1" :type 'boolean) @@ -8346,7 +8363,8 @@ E.g. this means it will obey `completion-styles' and other such settings." (t (expand-abbrev)))) -(add-to-list 'completion-category-defaults '(email (styles substring))) +(add-to-list 'completion-category-defaults '(email (styles substring + partial-completion))) (defun message--bbdb-query-with-words (words) ;; FIXME: This (or something like this) should live on the BBDB side. @@ -8569,26 +8587,23 @@ From headers in the original article." message-hidden-headers)) (inhibit-point-motion-hooks t) (inhibit-modification-hooks t) - (end-of-headers (point-min))) + end-of-headers) (when regexps (save-excursion (save-restriction (message-narrow-to-headers) + (setq end-of-headers (point-min-marker)) (goto-char (point-min)) (while (not (eobp)) (if (not (message-hide-header-p regexps)) (message-next-header) - (let ((begin (point)) - header header-len) + (let ((begin (point))) (message-next-header) - (setq header (buffer-substring begin (point)) - header-len (- (point) begin)) - (delete-region begin (point)) - (goto-char end-of-headers) - (insert header) - (setq end-of-headers - (+ end-of-headers header-len)))))))) - (narrow-to-region end-of-headers (point-max)))) + (let ((header (delete-and-extract-region begin (point)))) + (save-excursion + (goto-char end-of-headers) + (insert-before-markers header)))))))) + (narrow-to-region end-of-headers (point-max))))) (defun message-hide-header-p (regexps) (let ((result nil) @@ -8879,24 +8894,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) @@ -8932,7 +8952,7 @@ used to take the screenshot." This is meant to be used for MIME handlers: Setting the handler for \"x-scheme-handler/mailto;\" to \"emacs -f message-mailto %u\" will then start up Emacs ready to compose mail. For emacsclient use - emacsclient -e '(message-mailto \"%u\")'" + emacsclient -e \\='(message-mailto \"%u\")'" (interactive) ;; <a href="mailto:someone@example.com?subject=This%20is%20the%20subject&cc=someone_else@example.com&body=This%20is%20the%20body">Send email</a> (message-mail) diff --git a/lisp/gnus/mm-bodies.el b/lisp/gnus/mm-bodies.el index 956449dac14..9045966df5a 100644 --- a/lisp/gnus/mm-bodies.el +++ b/lisp/gnus/mm-bodies.el @@ -191,19 +191,21 @@ If TYPE is `text/plain' CRLF->LF translation may occur." ((eq encoding 'base64) (base64-decode-region (point-min) - ;; Some mailers insert whitespace - ;; junk at the end which - ;; base64-decode-region dislikes. - ;; Also remove possible junk which could - ;; have been added by mailing list software. (save-excursion + ;; Some mailers insert whitespace junk at the end which + ;; base64-decode-region dislikes. (goto-char (point-min)) (while (re-search-forward "^[\t ]*\r?\n" nil t) (delete-region (match-beginning 0) (match-end 0))) + ;; Also ignore junk which could have been added by + ;; mailing list software by finding the final line with + ;; base64 text. (goto-char (point-max)) - (when (re-search-backward "^[\t ]*[A-Za-z0-9+/]+=*[\t ]*$" - nil t) - (forward-line)) + (beginning-of-line) + (while (and (not (mm-base64-line-p)) + (not (bobp))) + (forward-line -1)) + (forward-line 1) (point)))) ((memq encoding '(nil 7bit 8bit binary)) ;; Do nothing. @@ -236,6 +238,20 @@ If TYPE is `text/plain' CRLF->LF translation may occur." (while (search-forward "\r\n" nil t) (replace-match "\n" t t))))) +(defun mm-base64-line-p () + "Say whether the current line is base64." + ;; This is coded in this way to avoid using regexps that may + ;; overflow -- a base64 line may be megabytes long. + (save-excursion + (beginning-of-line) + (skip-chars-forward " \t") + (and (looking-at "[A-Za-z0-9+/]\\{3\\}") + (progn + (skip-chars-forward "A-Za-z0-9+/") + (skip-chars-forward "=") + (skip-chars-forward " \t") + (eolp))))) + (defun mm-decode-body (charset &optional encoding type) "Decode the current article that has been encoded with ENCODING to CHARSET. ENCODING is a MIME content transfer encoding. diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el index e04423ce377..7256e5a2f7c 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. @@ -473,6 +474,7 @@ The file will be saved in the directory `mm-tmp-directory'.") (autoload 'mml2015-verify-test "mml2015") (autoload 'mml-smime-verify "mml-smime") (autoload 'mml-smime-verify-test "mml-smime") +(autoload 'mm-view-pkcs7-verify "mm-view") (defvar mm-verify-function-alist '(("application/pgp-signature" mml2015-verify "PGP" mml2015-verify-test) @@ -481,7 +483,15 @@ The file will be saved in the directory `mm-tmp-directory'.") ("application/pkcs7-signature" mml-smime-verify "S/MIME" mml-smime-verify-test) ("application/x-pkcs7-signature" mml-smime-verify "S/MIME" - mml-smime-verify-test))) + mml-smime-verify-test) + ("application/x-pkcs7-signature" mml-smime-verify "S/MIME" + mml-smime-verify-test) + ;; these are only used for security-buttons and contain the + ;; smime-type after the underscore + ("application/pkcs7-mime_signed-data" mm-view-pkcs7-verify "S/MIME" + nil) + ("application/x-pkcs7-mime_signed-data" mml-view-pkcs7-verify "S/MIME" + nil))) (defcustom mm-verify-option 'never "Option of verifying signed parts. @@ -500,11 +510,17 @@ result of the verification." (autoload 'mml2015-decrypt "mml2015") (autoload 'mml2015-decrypt-test "mml2015") +(autoload 'mm-view-pkcs7-decrypt "mm-view") (defvar mm-decrypt-function-alist '(("application/pgp-encrypted" mml2015-decrypt "PGP" mml2015-decrypt-test) ("application/x-gnus-pgp-encrypted" mm-uu-pgp-encrypted-extract-1 "PGP" - mm-uu-pgp-encrypted-test))) + mm-uu-pgp-encrypted-test) + ;; these are only used for security-buttons and contain the + ;; smime-type after the underscore + ("application/pkcs7-mime_enveloped-data" mm-view-pkcs7-decrypt "S/MIME" nil) + ("application/x-pkcs7-mime_enveloped-data" + mm-view-pkcs7-decrypt "S/MIME" nil))) (defcustom mm-decrypt-option nil "Option of decrypting encrypted parts. @@ -681,18 +697,35 @@ MIME-Version header before proceeding." 'start start) (car ctl)) (cons (car ctl) (mm-dissect-multipart ctl from)))) - (t - (mm-possibly-verify-or-decrypt - (mm-dissect-singlepart - ctl - (and cte (intern (downcase (mail-header-strip-cte cte)))) - no-strict-mime - (and cd (mail-header-parse-content-disposition cd)) - description id) - ctl from)))) - (when id - (when (string-match " *<\\(.*\\)> *" id) - (setq id (match-string 1 id))) + (t + (let* ((handle + (mm-dissect-singlepart + ctl + (and cte (intern (downcase (mail-header-strip-cte cte)))) + no-strict-mime + (and cd (mail-header-parse-content-disposition cd)) + description id)) + (intermediate-result + (mm-possibly-verify-or-decrypt handle ctl from))) + (when (and (equal type "application") + (or (equal subtype "pkcs7-mime") + (equal subtype "x-pkcs7-mime"))) + (add-text-properties + 0 (length (car ctl)) + (list 'protocol + (concat (substring-no-properties (car ctl)) + "_" + (cdr (assoc 'smime-type ctl)))) + (car ctl)) + ;; If this is a pkcs7-mime lets treat this special and + ;; more like multipart so the pkcs7-mime part does not + ;; get ignored. + (setq intermediate-result + (cons (car ctl) (list intermediate-result)))) + intermediate-result)))) + (when id + (when (string-match " *<\\(.*\\)> *" id) + (setq id (match-string 1 id))) (push (cons id result) mm-content-id-alist)) result)))) @@ -957,10 +990,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 @@ -1670,43 +1709,40 @@ If RECURSIVE, search recursively." (cond ((or (equal type "application/x-pkcs7-mime") (equal type "application/pkcs7-mime")) - (with-temp-buffer - (when (and (cond - ((equal smime-type "signed-data") t) - ((eq mm-decrypt-option 'never) nil) - ((eq mm-decrypt-option 'always) t) - ((eq mm-decrypt-option 'known) t) - (t (y-or-n-p "Decrypt (S/MIME) part? "))) - (mm-view-pkcs7 parts from)) - (goto-char (point-min)) - ;; The encrypted document is a MIME part, and may use either - ;; CRLF (Outlook and the like) or newlines for end-of-line - ;; markers. Translate from CRLF. - (while (search-forward "\r\n" nil t) - (replace-match "\n")) - ;; Normally there will be a Content-type header here, but - ;; some mailers don't add that to the encrypted part, which - ;; makes the subsequent re-dissection fail here. - (save-restriction - (mail-narrow-to-head) - (unless (mail-fetch-field "content-type") - (goto-char (point-max)) - (insert "Content-type: text/plain\n\n"))) - (setq parts - (if (equal smime-type "signed-data") - (list (propertize - "multipart/signed" - 'protocol "application/pkcs7-signature" - 'gnus-info - (format - "%s:%s" - (get-text-property 0 'gnus-info - (car mm-security-handle)) - (get-text-property 0 'gnus-details - (car mm-security-handle)))) - (mm-dissect-buffer t) - parts) - (mm-dissect-buffer t)))))) + (add-text-properties 0 (length (car ctl)) + (list 'buffer (car parts)) + (car ctl)) + (let* ((envelope-p (string= smime-type "enveloped-data")) + (decrypt-or-verify-option (if envelope-p + mm-decrypt-option + mm-verify-option)) + (question (if envelope-p + "Decrypt (S/MIME) part? " + "Verify signed (S/MIME) part? "))) + (with-temp-buffer + (when (and (cond + ((equal smime-type "signed-data") t) + ((eq decrypt-or-verify-option 'never) nil) + ((eq decrypt-or-verify-option 'always) t) + ((eq decrypt-or-verify-option 'known) t) + (t (y-or-n-p (format question)))) + (mm-view-pkcs7 parts from)) + + (goto-char (point-min)) + ;; The encrypted document is a MIME part, and may use either + ;; CRLF (Outlook and the like) or newlines for end-of-line + ;; markers. Translate from CRLF. + (while (search-forward "\r\n" nil t) + (replace-match "\n")) + ;; Normally there will be a Content-type header here, but + ;; some mailers don't add that to the encrypted part, which + ;; makes the subsequent re-dissection fail here. + (save-restriction + (mail-narrow-to-head) + (unless (mail-fetch-field "content-type") + (goto-char (point-max)) + (insert "Content-type: text/plain\n\n"))) + (setq parts (mm-dissect-buffer t)))))) ((equal subtype "signed") (unless (and (setq protocol (mm-handle-multipart-ctl-parameter ctl 'protocol)) @@ -1833,7 +1869,7 @@ If RECURSIVE, search recursively." ;; Require since we bind its variables. (require 'shr) (let ((shr-width (if shr-use-fonts - nil + shr-width fill-column)) (shr-content-function (lambda (id) (let ((handle (mm-get-content-id id))) diff --git a/lisp/gnus/mm-url.el b/lisp/gnus/mm-url.el index 0910748ab50..e4d686ac837 100644 --- a/lisp/gnus/mm-url.el +++ b/lisp/gnus/mm-url.el @@ -34,8 +34,6 @@ (require 'gnus) (defvar url-current-object) -(defvar url-package-name) -(defvar url-package-version) (defgroup mm-url nil "A wrapper of url package and external url command for Gnus." diff --git a/lisp/gnus/mm-util.el b/lisp/gnus/mm-util.el index 3c529dbea0f..727e3abfffc 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 () @@ -101,9 +101,9 @@ version, you could use `autoload-coding-system' here." :type '(list (repeat :inline t :tag "Other options" (cons (symbol :tag "charset") - (symbol :tag "form")))) + (symbol :tag "form")))) + :risky t :group 'mime) -(put 'mm-charset-eval-alist 'risky-local-variable t) (defvar mm-charset-override-alist) @@ -315,8 +315,7 @@ Valid elements include: "ISO-8859-15 exchangeable coding systems and inconvertible characters.") (defvar mm-iso-8859-x-to-15-table - (and (fboundp 'coding-system-p) - (mm-coding-system-p 'iso-8859-15) + (and (mm-coding-system-p 'iso-8859-15) (mapcar (lambda (cs) (if (mm-coding-system-p (car cs)) diff --git a/lisp/gnus/mm-view.el b/lisp/gnus/mm-view.el index 44c744b068b..57ce36a9442 100644 --- a/lisp/gnus/mm-view.el +++ b/lisp/gnus/mm-view.el @@ -504,8 +504,6 @@ If MODE is not set, try to find mode automatically." (setq coding-system (mm-find-buffer-file-coding-system))) (setq text (buffer-string)))) (with-temp-buffer - (buffer-disable-undo) - (mm-enable-multibyte) (insert (cond ((eq charset 'gnus-decoded) (with-current-buffer (mm-handle-buffer handle) (buffer-string))) @@ -521,17 +519,17 @@ If MODE is not set, try to find mode automatically." ;; setting now, but it seems harmless and potentially still useful. (setq-local font-lock-mode-hook nil) (setq buffer-file-name (mm-handle-filename handle)) - (with-demoted-errors - (if mode - (save-window-excursion - ;; According to Katsumi Yamaoka <yamaoka@jpl.org>, org-mode - ;; requires the buffer to be temporarily displayed here, but - ;; I could not reproduce this problem. Furthermore, if - ;; there's such a problem, we should fix org-mode rather than - ;; use switch-to-buffer which can have undesirable - ;; side-effects! - ;;(switch-to-buffer (current-buffer)) - (funcall mode)) + (with-demoted-errors "Error setting mode: %S" + (if mode + (save-window-excursion + ;; According to Katsumi Yamaoka <yamaoka@jpl.org>, org-mode + ;; requires the buffer to be temporarily displayed here, but + ;; I could not reproduce this problem. Furthermore, if + ;; there's such a problem, we should fix org-mode rather than + ;; use switch-to-buffer which can have undesirable + ;; side-effects! + ;;(switch-to-buffer (current-buffer)) + (funcall mode)) (let ((auto-mode-alist (delq (rassq 'doc-view-mode-maybe auto-mode-alist) (copy-sequence auto-mode-alist)))) @@ -634,12 +632,9 @@ If MODE is not set, try to find mode automatically." (context (epg-make-context 'CMS))) (prog1 (epg-verify-string context part) - (let ((result (car (epg-context-result-for context 'verify)))) + (let ((result (epg-context-result-for context 'verify))) (mm-sec-status - 'gnus-info (epg-signature-status result) - 'gnus-details - (format "%s:%s" (epg-signature-validity result) - (epg-signature-key-id result)))))))) + 'gnus-info (epg-verify-result-to-string result))))))) (with-temp-buffer (insert "MIME-Version: 1.0\n") (mm-insert-headers "application/pkcs7-mime" "base64" "smime.p7m") @@ -659,7 +654,11 @@ If MODE is not set, try to find mode automatically." ;; Use EPG/gpgsm (let ((part (base64-decode-string (buffer-string)))) (erase-buffer) - (insert (epg-decrypt-string (epg-make-context 'CMS) part))) + (insert + (let ((context (epg-make-context 'CMS))) + (prog1 + (epg-decrypt-string context part) + (mm-sec-status 'gnus-info "OK"))))) ;; Use openssl (insert "MIME-Version: 1.0\n") (mm-insert-headers "application/pkcs7-mime" "base64" "smime.p7m") diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el index acf9ef0ebd1..093e582ea7a 100644 --- a/lisp/gnus/mml.el +++ b/lisp/gnus/mml.el @@ -500,7 +500,8 @@ type detected." (when (and (consp (car cont)) (= (length cont) 1) content-type) - (setcdr (assq 'type (cdr (car cont))) content-type)) + (when-let ((spec (assq 'type (cdr (car cont))))) + (setcdr spec content-type))) (when (fboundp 'libxml-parse-html-region) (setq cont (mapcar #'mml-expand-all-html-into-multipart-related cont))) (prog1 @@ -1143,48 +1144,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 +1402,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 +1423,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 +1442,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 +1456,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/nndiary.el b/lisp/gnus/nndiary.el index 0ab92488f83..bd60c43f59d 100644 --- a/lisp/gnus/nndiary.el +++ b/lisp/gnus/nndiary.el @@ -1308,7 +1308,7 @@ all. This may very well take some time.") (let ((minute (nndiary-max (nth 0 sched))) (hour (nndiary-max (nth 1 sched))) (year (nndiary-max (nth 4 sched))) - (time-zone (or (and (nth 6 sched) (car (nth 6 sched))) + (time-zone (or (car (nth 6 sched)) (current-time-zone)))) (when year (or minute (setq minute 59)) @@ -1405,7 +1405,7 @@ all. This may very well take some time.") t)) (dow-list (nth 5 sched)) (year (1- this-year)) - (time-zone (or (and (nth 6 sched) (car (nth 6 sched))) + (time-zone (or (car (nth 6 sched)) (current-time-zone)))) ;; Special case: an asterisk in one of the days specifications means that ;; only the other should be taken into account. If both are unspecified, diff --git a/lisp/gnus/nnheader.el b/lisp/gnus/nnheader.el index 8b3718ed7e8..c1c5f00ff7f 100644 --- a/lisp/gnus/nnheader.el +++ b/lisp/gnus/nnheader.el @@ -27,6 +27,7 @@ ;;; Code: (eval-when-compile (require 'cl-lib)) +(require 'range) (defvar gnus-decode-encoded-word-function) (defvar gnus-decode-encoded-address-function) @@ -44,8 +45,6 @@ (require 'mm-util) (require 'gnus-util) (autoload 'gnus-remove-odd-characters "gnus-sum") -(autoload 'gnus-range-add "gnus-range") -(autoload 'gnus-remove-from-range "gnus-range") ;; FIXME none of these are used explicitly in this file. (autoload 'gnus-sorted-intersection "gnus-range") (autoload 'gnus-intersection "gnus-range") @@ -1044,10 +1043,9 @@ See `find-file-noselect' for the arguments." mark (cond ((eq what 'add) - (gnus-range-add (cdr (assoc mark backend-marks)) range)) + (range-concat (cdr (assoc mark backend-marks)) range)) ((eq what 'del) - (gnus-remove-from-range - (cdr (assoc mark backend-marks)) range)) + (range-remove (cdr (assoc mark backend-marks)) range)) ((eq what 'set) range)) backend-marks))))) diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el index fd6e3c0ccf7..afd5418912f 100644 --- a/lisp/gnus/nnimap.el +++ b/lisp/gnus/nnimap.el @@ -40,6 +40,7 @@ (autoload 'auth-source-forget+ "auth-source") (autoload 'auth-source-search "auth-source") +(autoload 'auth-info-password "auth-source") (nnoo-declare nnimap) @@ -245,7 +246,7 @@ during splitting, which may be slow." (nnimap-header-parameters)) t) (unless (process-live-p (get-buffer-process (current-buffer))) - (error "Server closed connection")) + (error "IMAP server %S closed connection" nnimap-address)) (nnimap-transform-headers) (nnheader-remove-cr-followed-by-lf)) (insert-buffer-substring @@ -407,10 +408,7 @@ during splitting, which may be slow." :create t)))) (if found (list (plist-get found :user) - (let ((secret (plist-get found :secret))) - (if (functionp secret) - (funcall secret) - secret)) + (auth-info-password found) (plist-get found :save-function)) nil))) @@ -429,8 +427,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 +670,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) @@ -1645,13 +1660,13 @@ If LIMIT, first try to limit the search to the N last articles." (cdr (assoc '%Seen flags)) (cdr (assoc '%Deleted flags)))) (cdr (assoc '%Flagged flags))))) - (read (gnus-range-difference + (read (range-difference (cons start-article high) unread))) (when (> start-article 1) (setq read (gnus-range-nconcat (if (> start-article 1) - (gnus-sorted-range-intersection + (range-intersection (cons 1 (1- start-article)) (gnus-info-read info)) (gnus-info-read info)) @@ -1676,7 +1691,7 @@ If LIMIT, first try to limit the search to the N last articles." (pop old-marks) (when (and old-marks (> start-article 1)) - (setq old-marks (gnus-range-difference + (setq old-marks (range-difference old-marks (cons start-article high))) (setq new-marks (gnus-range-nconcat old-marks new-marks))) @@ -1687,15 +1702,15 @@ If LIMIT, first try to limit the search to the N last articles." (active (gnus-active group)) (unexists (if completep - (gnus-range-difference + (range-difference active (gnus-compress-sequence existing)) - (gnus-add-to-range + (range-add-list (cdr old-unexists) - (gnus-list-range-difference + (range-list-difference existing (gnus-active group)))))) (when (> (car active) 1) - (setq unexists (gnus-range-add + (setq unexists (range-concat (cons 1 (1- (car active))) unexists))) (if old-unexists @@ -1718,10 +1733,9 @@ If LIMIT, first try to limit the search to the N last articles." (defun nnimap-update-qresync-info (info existing vanished flags) ;; Add all the vanished articles to the list of read articles. (setf (gnus-info-read info) - (gnus-add-to-range - (gnus-add-to-range - (gnus-range-add (gnus-info-read info) - vanished) + (range-add-list + (range-add-list + (range-concat (gnus-info-read info) vanished) (cdr (assq '%Flagged flags))) (cdr (assq '%Seen flags)))) (let ((marks (gnus-info-marks info))) @@ -1735,9 +1749,9 @@ If LIMIT, first try to limit the search to the N last articles." (setq marks (delq ticks marks)) (pop ticks) ;; Add the new marks we got. - (setq ticks (gnus-add-to-range ticks new-marks)) + (setq ticks (range-add-list ticks new-marks)) ;; Remove the marks from messages that don't have them. - (setq ticks (gnus-remove-from-range + (setq ticks (range-remove ticks (gnus-compress-sequence (gnus-sorted-complement existing new-marks)))) @@ -1747,7 +1761,7 @@ If LIMIT, first try to limit the search to the N last articles." ;; Add vanished to the list of unexisting articles. (when vanished (let* ((old-unexists (assq 'unexist marks)) - (unexists (gnus-range-add (cdr old-unexists) vanished))) + (unexists (range-concat (cdr old-unexists) vanished))) (if old-unexists (setcdr old-unexists unexists) (push (cons 'unexist unexists) marks))) @@ -1937,10 +1951,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 @@ -2224,7 +2241,7 @@ Return the server's response to the SELECT or EXAMINE command." (while (re-search-forward "^\\([0-9]+\\) OK\\b" nil t) (setq sequence (string-to-number (match-string 1))) (when (setq range (cadr (assq sequence sequences))) - (push (gnus-uncompress-range range) copied))) + (push (range-uncompress range) copied))) (gnus-compress-sequence (sort (apply #'nconc copied) #'<)))) (defun nnimap-new-articles (flags) diff --git a/lisp/gnus/nnmail.el b/lisp/gnus/nnmail.el index c71627f83a4..bde0de98924 100644 --- a/lisp/gnus/nnmail.el +++ b/lisp/gnus/nnmail.el @@ -1937,9 +1937,7 @@ If TIME is nil, then return the cutoff time for oldness instead." (and (string-match (cadr regexp-target-pair) to) (let ((mail-dont-reply-to-names (message-dont-reply-to-names))) - (equal (if (fboundp 'rmail-dont-reply-to) - (rmail-dont-reply-to from) - (mail-dont-reply-to from)) ""))))) + (equal (mail-dont-reply-to from) ""))))) (setq target (format-time-string (caddr regexp-target-pair) date))) ((and (not (equal header 'to-from)) (string-match (cadr regexp-target-pair) diff --git a/lisp/gnus/nnmaildir.el b/lisp/gnus/nnmaildir.el index 690761a2d6c..30f473b1291 100644 --- a/lisp/gnus/nnmaildir.el +++ b/lisp/gnus/nnmaildir.el @@ -1006,10 +1006,10 @@ This variable is set by `nnmaildir-request-article'.") existing (nnmaildir--grp-nlist group) existing (mapcar #'car existing) existing (nreverse existing) - existing (gnus-compress-sequence existing 'always-list) + existing (range-compress-list existing) missing (list (cons 1 (nnmaildir--group-maxnum nnmaildir--cur-server group))) - missing (gnus-range-difference missing existing) + missing (range-difference missing existing) dir (nnmaildir--srv-dir nnmaildir--cur-server) dir (nnmaildir--srvgrp-dir dir gname) dir (nnmaildir--nndir dir) @@ -1076,10 +1076,10 @@ This variable is set by `nnmaildir-request-article'.") (let ((article (nnmaildir--flist-art flist prefix))) (when article (push (nnmaildir--art-num article) article-list)))))) - (setq ranges (gnus-add-to-range ranges (sort article-list #'<))))) + (setq ranges (range-add-list ranges (sort article-list #'<))))) (if (eq mark 'read) (setq read ranges) (if ranges (setq marks (cons (cons mark ranges) marks))))) - (setf (gnus-info-read info) (gnus-range-add read missing)) + (setf (gnus-info-read info) (range-concat read missing)) (gnus-info-set-marks info marks 'extend) (setf (nnmaildir--grp-mmth group) new-mmth) info))) @@ -1548,11 +1548,11 @@ This variable is set by `nnmaildir-request-article'.") (unless group (setf (nnmaildir--srv-error nnmaildir--cur-server) (if gname (concat "No such group: " gname) "No current group")) - (throw 'return (gnus-uncompress-range ranges))) + (throw 'return (range-uncompress ranges))) (setq gname (nnmaildir--grp-name group) pgname (nnmaildir--pgname nnmaildir--cur-server gname)) (if (nnmaildir--param pgname 'read-only) - (throw 'return (gnus-uncompress-range ranges))) + (throw 'return (range-uncompress ranges))) (setq time (nnmaildir--param pgname 'expire-age)) (unless time (setq time (or (and nnmail-expiry-wait-function @@ -1564,7 +1564,7 @@ This variable is set by `nnmaildir-request-article'.") (setq time (round (* time 86400)))))) (when no-force (unless (integerp time) ;; handle 'never - (throw 'return (gnus-uncompress-range ranges))) + (throw 'return (range-uncompress ranges))) (setq boundary (time-since time))) (setq dir (nnmaildir--srv-dir nnmaildir--cur-server) dir (nnmaildir--srvgrp-dir dir gname) @@ -1686,7 +1686,7 @@ This variable is set by `nnmaildir-request-article'.") (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "No such group: " gname)) (dolist (action actions) - (setq ranges (gnus-range-add ranges (car action)))) + (setq ranges (range-concat ranges (car action)))) (throw 'return ranges)) (setq nlist (nnmaildir--grp-nlist group) marksdir (nnmaildir--srv-dir nnmaildir--cur-server) diff --git a/lisp/gnus/nnmairix.el b/lisp/gnus/nnmairix.el index 8ca1cf0fe8b..8c811b0c6c0 100644 --- a/lisp/gnus/nnmairix.el +++ b/lisp/gnus/nnmairix.el @@ -333,7 +333,7 @@ this might lead to problems, especially when used with marks propagation." (defvar nnmairix-widget-other '(threads flags) "Other editable mairix commands when using customization widgets. -Currently there are 'threads and 'flags.") +Currently there are `threads' and `flags'.") (defvar nnmairix-interactive-query-parameters '((?f "from" "f" "From") (?t "to" "t" "To") (?c "to" "tc" "To or Cc") @@ -597,7 +597,7 @@ Other back ends might or might not work.") (dolist (cur actions) (let ((type (nth 1 cur)) (cmdmarks (nth 2 cur)) - (range (gnus-uncompress-range (nth 0 cur))) + (range (range-uncompress (nth 0 cur))) mid ogroup temp) ;; number method (when (and corr (not (zerop (cadr corr)))) diff --git a/lisp/gnus/nnmbox.el b/lisp/gnus/nnmbox.el index 5a350aac746..96ecc34e156 100644 --- a/lisp/gnus/nnmbox.el +++ b/lisp/gnus/nnmbox.el @@ -529,7 +529,7 @@ ;; add article to index, either by building complete list ;; in reverse order, or as a list of ranges. (if (not nnmbox-group-building-active-articles) - (setcdr entry (gnus-add-to-range (cdr entry) (list article))) + (setcdr entry (range-add-list (cdr entry) (list article))) (when (memq article (cdr entry)) (switch-to-buffer nnmbox-mbox-buffer) (error "Article %s:%d already exists!" group article)) @@ -548,10 +548,10 @@ nnmbox-group-active-articles) (car nnmbox-group-active-articles))))) ;; remove article from index - (setcdr entry (gnus-remove-from-range (cdr entry) (list article))))) + (setcdr entry (range-remove (cdr entry) (list article))))) (defun nnmbox-is-article-active-p (article) - (gnus-member-of-range + (range-member-p article (cdr (assoc nnmbox-current-group nnmbox-group-active-articles)))) diff --git a/lisp/gnus/nnml.el b/lisp/gnus/nnml.el index afdb0c780a5..7fe2b516cce 100644 --- a/lisp/gnus/nnml.el +++ b/lisp/gnus/nnml.el @@ -1078,21 +1078,20 @@ Use the nov database for the current group if available." ;; #### doing anything on them. ;; 2 a/ read articles: (let ((read (gnus-info-read info))) - (setq read (gnus-remove-from-range read (list new-number))) - (when (gnus-member-of-range old-number read) - (setq read (gnus-remove-from-range read (list old-number))) - (setq read (gnus-add-to-range read (list new-number)))) + (setq read (range-remove read (list new-number))) + (when (range-member-p old-number read) + (setq read (range-remove read (list old-number))) + (setq read (range-add-list read (list new-number)))) (setf (gnus-info-read info) read)) ;; 2 b/ marked articles: (let ((oldmarks (gnus-info-marks info)) mark newmarks) (while (setq mark (pop oldmarks)) - (setcdr mark (gnus-remove-from-range (cdr mark) - (list new-number))) - (when (gnus-member-of-range old-number (cdr mark)) - (setcdr mark (gnus-remove-from-range (cdr mark) - (list old-number))) - (setcdr mark (gnus-add-to-range (cdr mark) + (setcdr mark (range-remove (cdr mark) (list new-number))) + (when (range-member-p old-number (cdr mark)) + (setcdr mark (range-remove (cdr mark) + (list old-number))) + (setcdr mark (range-add-list (cdr mark) (list new-number)))) (push mark newmarks)) (setf (gnus-info-marks info) newmarks)) diff --git a/lisp/gnus/nnnil.el b/lisp/gnus/nnnil.el index 36a8bc4581b..092b53298a2 100644 --- a/lisp/gnus/nnnil.el +++ b/lisp/gnus/nnnil.el @@ -40,7 +40,7 @@ (defun nnnil-open-server (_server &optional _definitions) t) -(defun nnnil-close-server (&optional _server) +(defun nnnil-close-server (&optional _server _defs) t) (defun nnnil-request-close () diff --git a/lisp/gnus/nnregistry.el b/lisp/gnus/nnregistry.el index d042981ca98..4a799acad98 100644 --- a/lisp/gnus/nnregistry.el +++ b/lisp/gnus/nnregistry.el @@ -36,7 +36,7 @@ (nnoo-declare nnregistry) (deffoo nnregistry-server-opened (_server) - gnus-registry-enabled) + gnus-registry-db) (deffoo nnregistry-close-server (_server &optional _defs) t) @@ -45,7 +45,7 @@ nil) (deffoo nnregistry-open-server (_server &optional _defs) - gnus-registry-enabled) + gnus-registry-db) (defvar nnregistry-within-nnregistry nil) diff --git a/lisp/gnus/nnrss.el b/lisp/gnus/nnrss.el index 10b378fd44c..f740af3b6d1 100644 --- a/lisp/gnus/nnrss.el +++ b/lisp/gnus/nnrss.el @@ -450,7 +450,7 @@ nnrss: %s: Not valid XML %s and libxml-parse-html-region doesn't work %s" This function handles the ISO 8601 date format described in URL `https://www.w3.org/TR/NOTE-datetime', and also the RFC 822 style which RSS 2.0 allows." - (let (case-fold-search vector year month day time zone cts given) + (let (case-fold-search vector year month day time zone given) (cond ((null date)) ; do nothing for this case ;; if the date is just digits (unix time stamp): ((string-match "^[0-9]+$" date) @@ -481,13 +481,13 @@ which RSS 2.0 allows." 0 (decoded-time-zone decoded)))))) (if month - (progn - (setq cts (current-time-string (encode-time 0 0 0 day month year))) - (format "%s, %02d %s %04d %s%s" - (substring cts 0 3) day (substring cts 4 7) year time - (if zone - (concat " " (format-time-string "%z" nil zone)) - ""))) + (concat (let ((system-time-locale "C")) + (format-time-string "%a, %d %b %Y " + (encode-time 0 0 0 day month year))) + time + (if zone + (format-time-string " %z" nil zone) + "")) (message-make-date given)))) ;;; data functions @@ -756,8 +756,7 @@ Export subscriptions to a buffer in OPML Format." (insert " </body>\n" "</opml>\n")) (pop-to-buffer "*OPML Export*") - (when (fboundp 'sgml-mode) - (sgml-mode))) + (sgml-mode)) (defun nnrss-generate-download-script () "Generate a download script in the current buffer. diff --git a/lisp/gnus/nnselect.el b/lisp/gnus/nnselect.el index e79b080e789..9b8333a7c6c 100644 --- a/lisp/gnus/nnselect.el +++ b/lisp/gnus/nnselect.el @@ -47,7 +47,8 @@ ;;; Setup: (require 'gnus-art) -(require 'gnus-search) +(autoload 'gnus-search-run-query "gnus-search") +(autoload 'gnus-search-server-to-engine "gnus-search") (eval-when-compile (require 'cl-lib)) @@ -79,33 +80,37 @@ ;;; Helper routines. (defun nnselect-compress-artlist (artlist) "Compress ARTLIST." - (let (selection) - (pcase-dolist (`(,artgroup . ,arts) - (nnselect-categorize artlist #'nnselect-artitem-group)) - (let (list) - (pcase-dolist (`(,rsv . ,articles) - (nnselect-categorize - arts #'nnselect-artitem-rsv #'nnselect-artitem-number)) - (push (cons rsv (gnus-compress-sequence (sort articles #'<))) - list)) - (push (cons artgroup list) selection))) - selection)) + (if (consp artlist) + artlist + (let (selection) + (pcase-dolist (`(,artgroup . ,arts) + (nnselect-categorize artlist #'nnselect-artitem-group)) + (let (list) + (pcase-dolist (`(,rsv . ,articles) + (nnselect-categorize + arts #'nnselect-artitem-rsv #'nnselect-artitem-number)) + (push (cons rsv (gnus-compress-sequence (sort articles #'<))) + list)) + (push (cons artgroup list) selection))) + selection))) (defun nnselect-uncompress-artlist (artlist) "Uncompress ARTLIST." (if (vectorp artlist) artlist (let (selection) - (pcase-dolist (`(,artgroup (,artrsv . ,artseq)) artlist) - (setq selection - (vconcat - (cl-map 'vector - (lambda (art) - (vector artgroup art artrsv)) - (gnus-uncompress-sequence artseq)) selection))) + (pcase-dolist (`(,artgroup . ,list) artlist) + (pcase-dolist (`(,artrsv . ,artseq) list) + (setq selection + (vconcat + (cl-map 'vector + (lambda (art) + (vector artgroup art artrsv)) + (gnus-uncompress-sequence artseq)) selection)))) selection))) (make-obsolete 'nnselect-group-server 'gnus-group-server "28.1") +(make-obsolete 'nnselect-run 'nnselect-generate-artlist "29.1") ;; Data type article list. @@ -207,7 +212,7 @@ as `(keyfunc member)' and the corresponding element is just (inline-quote (cond ((eq ,type 'range) - (nnselect-categorize (gnus-uncompress-range ,articles) + (nnselect-categorize (range-uncompress ,articles) #'nnselect-article-group #'nnselect-article-number)) ((eq ,type 'tuple) (nnselect-categorize ,articles @@ -227,11 +232,6 @@ as `(keyfunc member)' and the corresponding element is just `(gnus-group-prefixed-name (gnus-group-short-name ,group) '(nnselect "nnselect"))) -(defmacro nnselect-get-artlist (group) - "Retrieve the list of articles for GROUP." - `(when (gnus-nnselect-group-p ,group) - (nnselect-uncompress-artlist - (gnus-group-get-parameter ,group 'nnselect-artlist t)))) (defmacro nnselect-add-novitem (novitem) "Add NOVITEM to the list of headers." @@ -252,16 +252,78 @@ as `(keyfunc member)' and the corresponding element is just (define-obsolete-variable-alias 'nnir-retrieve-headers-override-function 'nnselect-retrieve-headers-override-function "28.1") +(defcustom nnselect-allow-ephemeral-expiry nil + "If non-nil, articles in ephemeral nnselect groups are subject to expiry." + :version "29.1" + :type 'boolean) + (defcustom nnselect-retrieve-headers-override-function nil "A function that retrieves article headers for ARTICLES from GROUP. The retrieved headers should populate the `nntp-server-buffer'. -Returns either the retrieved header format 'nov or 'headers. +Returns either the retrieved header format `nov' or `headers'. If this variable is nil, or if the provided function returns nil, `gnus-retrieve-headers' will be called instead." :version "28.1" :type '(repeat function)) +(defun nnselect-generate-artlist (group &optional specs) + "Generate the artlist for GROUP using SPECS. +SPECS should be an alist including an `nnselect-function' and an +`nnselect-args'. The former applied to the latter should create +the artlist. If SPECS is nil retrieve the specs from the group +parameters." + (let* ((specs + (or specs (gnus-group-get-parameter group 'nnselect-specs t))) + (function (alist-get 'nnselect-function specs)) + (args (alist-get 'nnselect-args specs))) + (condition-case-unless-debug err + (funcall function 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-generate-artlist: %s on %s gave error %s" function args err) + [])))) + +(defmacro nnselect-get-artlist (group) + "Get the list of articles for GROUP. +If the group parameter `nnselect-get-artlist-override-function' is +non-nil call this function with argument GROUP to get the +artlist; if the group parameter `nnselect-always-regenerate' is +non-nil, regenerate the artlist; otherwise retrieve the artlist +directly from the group parameters." + `(when (gnus-nnselect-group-p ,group) + (let ((override (gnus-group-get-parameter + ,group + 'nnselect-get-artlist-override-function))) + (cond + (override (funcall override ,group)) + ((gnus-group-get-parameter ,group 'nnselect-always-regenerate) + (nnselect-generate-artlist ,group)) + (t + (nnselect-uncompress-artlist + (gnus-group-get-parameter ,group 'nnselect-artlist t))))))) + +(defmacro nnselect-store-artlist (group artlist) + "Store the ARTLIST for GROUP. +If the group parameter `nnselect-store-artlist-override-function' +is non-nil call this function on GROUP and ARTLIST; if the group +parameter `nnselect-always-regenerate' is non-nil don't store the +artlist; otherwise store the ARTLIST in the group parameters." + `(let ((override (gnus-group-get-parameter + ,group + 'nnselect-store-artlist-override-function))) + (cond + (override (funcall override ,group ,artlist)) + ((gnus-group-get-parameter ,group 'nnselect-always-regenerate) t) + (t + (gnus-group-set-parameter ,group 'nnselect-artlist + (nnselect-compress-artlist ,artlist)))))) + ;; Gnus backend interface functions. (deffoo nnselect-open-server (server &optional definitions) @@ -287,11 +349,8 @@ If this variable is nil, or if the provided function returns nil, ;; Check for cached select result or run the selection and cache ;; the result. (unless nnselect-artlist - (gnus-group-set-parameter - group 'nnselect-artlist - (nnselect-compress-artlist (setq nnselect-artlist - (nnselect-run - (gnus-group-get-parameter group 'nnselect-specs t))))) + (nnselect-store-artlist group + (setq nnselect-artlist (nnselect-generate-artlist group))) (nnselect-request-update-info group (or info (gnus-get-info group)))) (if (zerop (setq length (nnselect-artlist-length nnselect-artlist))) @@ -329,6 +388,7 @@ If this variable is nil, or if the provided function returns nil, (gnus-group-find-parameter artgroup 'gnus-fetch-old-headers t)) fetch-old))) + (gnus-request-group artgroup) (erase-buffer) (pcase (setq gnus-headers-retrieved-by (or @@ -395,8 +455,7 @@ If this variable is nil, or if the provided function returns nil, (gnus-search-run-query (list (cons 'search-query-spec - (list (cons 'query `((id . ,article))) - (cons 'criteria "") (cons 'shortcut t))) + (list (cons 'query (format "id:%s" article)))) (cons 'search-group-spec servers)))) (unless (zerop (nnselect-artlist-length artlist)) (setq @@ -454,24 +513,26 @@ If this variable is nil, or if the provided function returns nil, :test #'equal :count 1))))) (deffoo nnselect-request-expire-articles - (articles _group &optional _server force) - (if force - (let (not-expired) - (pcase-dolist (`(,artgroup . ,artids) (ids-by-group articles)) - (let ((artlist (sort (mapcar #'cdr artids) #'<))) - (unless (gnus-check-backend-function 'request-expire-articles - artgroup) - (error "Group %s does not support article expiration" artgroup)) - (unless (gnus-check-server (gnus-find-method-for-group artgroup)) - (error "Couldn't open server for group %s" artgroup)) - (push (mapcar (lambda (art) - (car (rassq art artids))) - (let ((nnimap-expunge 'immediately)) - (gnus-request-expire-articles - artlist artgroup force))) - not-expired))) - (sort (delq nil not-expired) #'<)) - articles)) + (articles group &optional _server force) + (let ((nnimap-expunge 'immediately) not-deleted) + (if (and (not force) + (not nnselect-allow-ephemeral-expiry) + (gnus-ephemeral-group-p (nnselect-add-prefix group))) + articles + (pcase-dolist (`(,artgroup . ,artids) (ids-by-group articles)) + (let ((artlist (sort (mapcar #'cdr artids) #'<))) + (unless + (gnus-check-backend-function 'request-expire-articles artgroup) + (error "Group %s does not support article expiration" artgroup)) + (unless (gnus-check-server (gnus-find-method-for-group artgroup)) + (error "Couldn't open server for group %s" artgroup)) + (setq not-deleted + (append + (mapcar (lambda (art) (car (rassq art artids))) + (gnus-request-expire-articles artlist artgroup + force)) + not-deleted)))) + (sort (delq nil not-deleted) #'<)))) (deffoo nnselect-warp-to-article () @@ -529,68 +590,65 @@ If this variable is nil, or if the provided function returns nil, (deffoo nnselect-request-update-info (group info &optional _server) (let* ((group (nnselect-add-prefix group)) - (gnus-newsgroup-selection - (or gnus-newsgroup-selection (nnselect-get-artlist group))) - newmarks) + (gnus-newsgroup-selection + (or gnus-newsgroup-selection (nnselect-get-artlist group))) + newmarks) (gnus-info-set-marks info nil) (setf (gnus-info-read info) nil) (pcase-dolist (`(,artgroup . ,nartids) - (ids-by-group - (number-sequence 1 (nnselect-artlist-length - gnus-newsgroup-selection)))) + (ids-by-group + (number-sequence 1 (nnselect-artlist-length + gnus-newsgroup-selection)))) (let* ((gnus-newsgroup-active nil) - (artids (cl-sort nartids #'< :key 'car)) - (group-info (gnus-get-info artgroup)) - (marks (gnus-info-marks group-info)) - (unread (gnus-uncompress-sequence - (gnus-range-difference (gnus-active artgroup) - (gnus-info-read group-info))))) + (idmap (make-hash-table :test 'eql)) + (gactive (sort (mapcar 'cdr nartids) '<)) + (group-info (gnus-get-info artgroup)) + (marks (gnus-info-marks group-info))) + (pcase-dolist (`(,val . ,key) nartids) + (puthash key val idmap)) (setf (gnus-info-read info) - (gnus-add-to-range - (gnus-info-read info) - (delq nil (mapcar - (lambda (art) - (unless (memq (cdr art) unread) (car art))) - artids)))) - (pcase-dolist (`(,type . ,mark-list) marks) - (let ((mark-type (gnus-article-mark-to-type type)) new) - (when - (setq new - (delq nil - (cond - ((eq mark-type 'tuple) - (mapcar - (lambda (id) - (let (mark) - (when - (setq mark (assq (cdr id) mark-list)) - (cons (car id) (cdr mark))))) - artids)) - (t - (setq mark-list - (gnus-uncompress-range mark-list)) - (mapcar - (lambda (id) - (when (memq (cdr id) mark-list) - (car id))) artids))))) - (let ((previous (alist-get type newmarks))) - (if previous - (nconc previous new) - (push (cons type new) newmarks)))))))) + (range-add-list + (gnus-info-read info) + (sort (mapcar (lambda (art) (gethash art idmap)) + (gnus-sorted-intersection + gactive + (range-uncompress (gnus-info-read group-info)))) + '<))) + (pcase-dolist (`(,type . ,mark-list) marks) + (let ((mark-type (gnus-article-mark-to-type type)) new) + (when + (setq new + (if (not mark-list) nil + (cond + ((eq mark-type 'tuple) + (delq nil + (mapcar + (lambda (mark) + (let ((id (gethash (car mark) idmap))) + (when id (cons id (cdr mark))))) + mark-list))) + (t + (mapcar (lambda (art) (gethash art idmap)) + (gnus-sorted-intersection + gactive (range-uncompress mark-list))))))) + (let ((previous (alist-get type newmarks))) + (if previous + (nconc previous new) + (push (cons type new) newmarks)))))))) ;; Clean up the marks: compress lists; (pcase-dolist (`(,type . ,mark-list) newmarks) (let ((mark-type (gnus-article-mark-to-type type))) - (unless (eq mark-type 'tuple) - (setf (alist-get type newmarks) - (gnus-compress-sequence mark-list))))) + (unless (eq mark-type 'tuple) + (setf (alist-get type newmarks) + (gnus-compress-sequence (sort mark-list '<)))))) ;; and ensure an unexist key. (unless (assq 'unexist newmarks) (push (cons 'unexist nil) newmarks)) (gnus-info-set-marks info newmarks) (gnus-set-active group (cons 1 (nnselect-artlist-length - gnus-newsgroup-selection))))) + gnus-newsgroup-selection))))) (deffoo nnselect-request-thread (header &optional group server) @@ -645,8 +703,15 @@ If this variable is nil, or if the provided function returns nil, (lambda (article) (if (setq seq - (cl-position article - gnus-newsgroup-selection :test 'equal)) + (cl-position + article + gnus-newsgroup-selection + :test + (lambda (x y) + (and (equal (nnselect-artitem-group x) + (nnselect-artitem-group y)) + (eql (nnselect-artitem-number x) + (nnselect-artitem-number y)))))) (push (1+ seq) old-arts) (setq gnus-newsgroup-selection (vconcat gnus-newsgroup-selection (vector article))) @@ -657,10 +722,7 @@ If this variable is nil, or if the provided function returns nil, (append (sort old-arts #'<) (number-sequence first last)) nil t)) - (gnus-group-set-parameter - group - 'nnselect-artlist - (nnselect-compress-artlist gnus-newsgroup-selection)) + (nnselect-store-artlist group gnus-newsgroup-selection) (when (>= last first) (let (new-marks) (pcase-dolist (`(,artgroup . ,artids) @@ -707,6 +769,7 @@ If this variable is nil, or if the provided function returns nil, (message "Creating nnselect group %s" group) (let* ((group (gnus-group-prefixed-name group '(nnselect "nnselect"))) (specs (assq 'nnselect-specs args)) + (otherargs (assq-delete-all 'nnselect-specs args)) (function-spec (or (alist-get 'nnselect-function specs) (intern (completing-read "Function: " obarray #'functionp)))) @@ -716,10 +779,12 @@ If this variable is nil, or if the provided function returns nil, (nnselect-specs (list (cons 'nnselect-function function-spec) (cons 'nnselect-args args-spec)))) (gnus-group-set-parameter group 'nnselect-specs nnselect-specs) - (gnus-group-set-parameter - group 'nnselect-artlist - (nnselect-compress-artlist (or (alist-get 'nnselect-artlist args) - (nnselect-run nnselect-specs)))) + (dolist (arg otherargs) + (gnus-group-set-parameter group (car arg) (cdr arg))) + (nnselect-store-artlist + group + (or (alist-get 'nnselect-artlist args) + (nnselect-generate-artlist group nnselect-specs))) (nnselect-request-update-info group (gnus-get-info group))) t) @@ -744,20 +809,17 @@ If this variable is nil, or if the provided function returns nil, (deffoo nnselect-request-scan (group _method) (when (and group - (gnus-group-get-parameter (nnselect-add-prefix group) + (gnus-group-find-parameter (nnselect-add-prefix group) 'nnselect-rescan t)) (nnselect-request-group-scan group))) (deffoo nnselect-request-group-scan (group &optional _server _info) (let* ((group (nnselect-add-prefix group)) - (artlist (nnselect-run - (gnus-group-get-parameter group 'nnselect-specs t)))) + (artlist (nnselect-generate-artlist group))) (gnus-set-active group (cons 1 (nnselect-artlist-length artlist))) - (gnus-group-set-parameter - group 'nnselect-artlist - (nnselect-compress-artlist artlist)))) + (nnselect-store-artlist group artlist))) ;; Add any undefined required backend functions @@ -772,16 +834,6 @@ If this variable is nil, or if the provided function returns nil, (eq 'nnselect (car gnus-command-method)))) -(defun nnselect-run (specs) - "Apply nnselect-function to nnselect-args from SPECS. -Return an article list." - (let ((func (alist-get 'nnselect-function specs)) - (args (alist-get 'nnselect-args specs))) - (condition-case-unless-debug err - (funcall func args) - (error (gnus-error 3 "nnselect-run: %s on %s gave error %s" func args err) - [])))) - (defun nnselect-search-thread (header) "Make an nnselect group containing the thread with article HEADER. The current server will be searched. If the registry is @@ -860,19 +912,19 @@ article came from is also searched." ;; When the backend can store marks we collect any ;; changes. Unlike a normal group the mark lists only ;; include marks for articles we retrieved. - (when (and (gnus-check-backend-function - 'request-set-mark artgroup) - (not (gnus-article-unpropagatable-p type))) - (let* ((old (gnus-list-range-intersection + (when (and (gnus-check-backend-function + 'request-set-mark gnus-newsgroup-name) + (not (gnus-article-unpropagatable-p type))) + (let* ((old (range-list-intersection artlist (alist-get type (gnus-info-marks group-info)))) - (del (gnus-remove-from-range (copy-tree old) list)) - (add (gnus-remove-from-range (copy-tree list) old))) + (del (range-remove (copy-tree old) list)) + (add (range-remove (copy-tree list) old))) (when add (push (list add 'add (list type)) delta-marks)) (when del ;; Don't delete marks from outside the active range. ;; This shouldn't happen, but is a sanity check. - (setq del (gnus-sorted-range-intersection + (setq del (range-intersection (gnus-active artgroup) del)) (push (list del 'del (list type)) delta-marks)))) @@ -899,26 +951,29 @@ article came from is also searched." (setq list (cdr all)))) ;; now merge with the original list and sort just to ;; make sure - (setq list - (sort (map-merge - 'list list - (alist-get type (gnus-info-marks group-info))) - (lambda (elt1 elt2) - (< (car elt1) (car elt2)))))) + (setq + list (sort + (map-merge + 'alist list + (delq nil + (mapcar + (lambda (x) (unless (memq (car x) artlist) x)) + (alist-get type (gnus-info-marks group-info))))) + 'car-less-than-car))) (t (setq list - (gnus-compress-sequence + (range-compress-list (gnus-sorted-union (gnus-sorted-difference (gnus-uncompress-sequence (alist-get type (gnus-info-marks group-info))) artlist) - (sort list #'<)) t))) + (sort list #'<))))) ;; When exiting the group, everything that's previously been ;; unseen is now seen. (when (eq type 'seen) - (setq list (gnus-range-add + (setq list (range-concat list (cdr (assoc artgroup select-unseen)))))) (when (or list (eq type 'unexist)) @@ -941,16 +996,20 @@ article came from is also searched." ;; update read and unread (gnus-update-read-articles artgroup - (gnus-uncompress-range - (gnus-add-to-range - (gnus-remove-from-range + (range-uncompress + (range-add-list + (range-remove old-unread (cdr (assoc artgroup select-reads))) (sort (cdr (assoc artgroup select-unreads)) #'<)))) (gnus-get-unread-articles-in-group - group-info (gnus-active artgroup) t) - (gnus-group-update-group artgroup t t))))))) - + group-info (gnus-active artgroup) t)) + (gnus-group-update-group + artgroup t + (equal group-info + (setq group-info (copy-sequence (gnus-get-info artgroup)) + group-info + (delq (gnus-info-params group-info) group-info))))))))) (declare-function gnus-registry-get-id-key "gnus-registry" (id key)) diff --git a/lisp/gnus/nntp.el b/lisp/gnus/nntp.el index 038a6d0625f..f047c832931 100644 --- a/lisp/gnus/nntp.el +++ b/lisp/gnus/nntp.el @@ -36,6 +36,7 @@ (eval-when-compile (require 'cl-lib)) (autoload 'auth-source-search "auth-source") +(autoload 'auth-info-password "auth-source") (defgroup nntp nil "NNTP access for Gnus." @@ -305,7 +306,7 @@ backend doesn't catch this error.") (nntp-record-command string)) (process-send-string process (concat string nntp-end-of-line)) (or (memq (process-status process) '(open run)) - (nntp-report "Server closed connection"))) + (nntp-report "NNTP server %S closed connection" nntp-address))) (defun nntp-record-command (string) "Record the command STRING." @@ -331,9 +332,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." @@ -370,7 +369,7 @@ retried once before actually displaying the error report." (nntp-snarf-error-message) nil)) ((not (memq (process-status process) '(open run))) - (nntp-report "Server closed connection")) + (nntp-report "NNTP server %S closed connection" nntp-address)) (t (goto-char (point-max)) (let ((limit (point-min)) @@ -1177,10 +1176,7 @@ If SEND-IF-FORCE, only send authinfo to the server if the "563" "nntps" "snews")))) (auth-user (plist-get auth-info :user)) (auth-force (plist-get auth-info :force)) - (auth-passwd (plist-get auth-info :secret)) - (auth-passwd (if (functionp auth-passwd) - (funcall auth-passwd) - auth-passwd)) + (auth-passwd (auth-info-password auth-info)) (force (or (netrc-get alist "force") nntp-authinfo-force auth-force)) @@ -1229,6 +1225,7 @@ If SEND-IF-FORCE, only send authinfo to the server if the (generate-new-buffer (format " *server %s %s %s*" nntp-address nntp-port-number buffer)) + (gnus-add-buffer) (mm-disable-multibyte) (setq-local after-change-functions nil nntp-process-wait-for nil @@ -1435,7 +1432,7 @@ If SEND-IF-FORCE, only send authinfo to the server if the ;; be the process's former output buffer (i.e. now killed) (or (and process (memq (process-status process) '(open run))) - (nntp-report "Server closed connection"))))) + (nntp-report "NNTP server %S closed connection" nntp-address))))) (defun nntp-accept-response () "Wait for output from the process that outputs to BUFFER." @@ -1454,7 +1451,7 @@ If SEND-IF-FORCE, only send authinfo to the server if the (when group (let ((entry (nntp-find-connection-entry nntp-server-buffer))) (cond ((not entry) - (nntp-report "Server closed connection")) + (nntp-report "NNTP server %S closed connection" nntp-address)) ((not (equal group (caddr entry))) (with-current-buffer (process-buffer (car entry)) (erase-buffer) diff --git a/lisp/gnus/nnvirtual.el b/lisp/gnus/nnvirtual.el index 7478a2dd0af..ae4265de7fb 100644 --- a/lisp/gnus/nnvirtual.el +++ b/lisp/gnus/nnvirtual.el @@ -114,14 +114,9 @@ It is computed from the marks of individual component groups.") (gnus-check-server (gnus-find-method-for-group cgroup) t) (gnus-request-group cgroup t) - (setq prefix (gnus-group-real-prefix cgroup)) - ;; FIX FIX FIX we want to check the cache! - ;; This is probably evil if people have set - ;; gnus-use-cache to nil themselves, but I - ;; have no way of finding the true value of it. - (let ((gnus-use-cache t)) - (setq result (gnus-retrieve-headers - articles cgroup nil)))) + (setq prefix (gnus-group-real-prefix cgroup) + result (gnus-retrieve-headers + articles cgroup nil))) (set-buffer nntp-server-buffer) ;; If we got HEAD headers, we convert them into NOV ;; headers. This is slow, inefficient and, come to think @@ -365,7 +360,7 @@ It is computed from the marks of individual component groups.") (lambda (article) (nnvirtual-reverse-map-article group article)) - (gnus-uncompress-range + (range-uncompress (gnus-group-expire-articles-1 group)))))) (sort (delq nil unexpired) #'<))) diff --git a/lisp/gnus/smime.el b/lisp/gnus/smime.el index ac1e0810417..87b5551d31c 100644 --- a/lisp/gnus/smime.el +++ b/lisp/gnus/smime.el @@ -119,7 +119,7 @@ ;;; Code: (require 'dig) - +(require 'gnutls) (require 'password-cache) (eval-when-compile (require 'cl-lib)) @@ -149,10 +149,11 @@ certificate." :type '(choice (const :tag "none" nil) directory)) -(defcustom smime-CA-file nil - "Files containing certificates for CAs you trust. -File should contain certificates in PEM format." - :version "22.1" +(defcustom smime-CA-file (car (gnutls-trustfiles)) + "File containing certificates for CAs you trust. +The file should contain certificates in PEM format. By default, +this is initialized from the `gnutls-trusfiles' variable." + :version "29.1" :type '(choice (const :tag "none" nil) file)) diff --git a/lisp/gnus/spam.el b/lisp/gnus/spam.el index 4b12a9a7804..5af29c0a246 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'.") @@ -852,7 +852,7 @@ The value nil means that the check does not yield a decision, and so, that further checks are needed. The value t means that the message is definitely not spam, and that further spam checks should be inhibited. Otherwise, a mailgroup name or the symbol -'spam (depending on `spam-split-symbolic-return') is returned where +`spam' (depending on `spam-split-symbolic-return') is returned where the mail should go, and further checks are also inhibited. The usual mailgroup name is the value of `spam-split-group', meaning that the message is definitely a spam." diff --git a/lisp/help-at-pt.el b/lisp/help-at-pt.el index b2ba12bef20..1a6d374db09 100644 --- a/lisp/help-at-pt.el +++ b/lisp/help-at-pt.el @@ -81,25 +81,37 @@ If this produces no string either, return nil." (echo (help-at-pt-string))) (if (and kbd (not (eq kbd t))) kbd echo))) +(declare-function widget-describe "wid-edit" (&optional widget-or-pos)) +(declare-function widget-at "wid-edit" (&optional pos)) + ;;;###autoload -(defun display-local-help (&optional arg) +(defun display-local-help (&optional inhibit-warning describe-button) "Display local help in the echo area. -This displays a short help message, namely the string produced by -the `kbd-help' property at point. If `kbd-help' does not produce -a string, but the `help-echo' property does, then that string is -printed instead. +This command, by default, displays a short help message, namely +the string produced by the `kbd-help' property at point. If +`kbd-help' does not produce a string, but the `help-echo' +property does, then that string is printed instead. The string is passed through `substitute-command-keys' before it is displayed. -A numeric argument ARG prevents display of a message in case -there is no help. While ARG can be used interactively, it is -mainly meant for use from Lisp." - (interactive "P") +If INHIBIT-WARNING is non-nil, this prevents display of a message +in case there is no help. + +If DESCRIBE-BUTTON in non-nil (interactively, the prefix arg), and +there's a button/widget at point, pop a buffer describing that +button/widget instead." + (interactive (list nil current-prefix-arg)) (let ((help (help-at-pt-kbd-string))) - (if help - (message "%s" (substitute-command-keys help)) - (if (not arg) (message "No local help at point"))))) + (cond + ((and describe-button (button-at (point))) + (button-describe)) + ((and describe-button (widget-at (point))) + (widget-describe)) + (help + (message "%s" (substitute-command-keys help))) + ((not inhibit-warning) + (message "No local help at point"))))) (defvar help-at-pt-timer nil "Non-nil means that a timer is set that checks for local help. @@ -229,11 +241,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 f78c6ab0dfa..f200077faec 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -33,6 +33,7 @@ ;;; Code: (require 'cl-lib) +(require 'seq) (require 'help-mode) (require 'radix-tree) (eval-when-compile (require 'subr-x)) ;For when-let. @@ -132,6 +133,14 @@ with the current prefix. The files are chosen according to :group 'help :version "26.3") +(defcustom help-enable-variable-value-editing nil + "If non-nil, allow editing values in *Help* buffers. +Values that aren't readable by the Emacs Lisp reader can't be +edited even if this option is enabled." + :type 'boolean + :group 'help + :version "29.1") + (defcustom help-enable-symbol-autoload nil "Perform autoload if docs are missing from autoload objects." :type 'boolean @@ -249,7 +258,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) @@ -394,7 +404,7 @@ if the variable `help-downcase-arguments' is non-nil." ;; `describe-face' (instead of `describe-simplify-lib-file-name'). ;;;###autoload -(defun find-lisp-object-file-name (object type) +(defun find-lisp-object-file-name (object type &optional also-c-source) "Guess the file that defined the Lisp object OBJECT, of type TYPE. OBJECT should be a symbol associated with a function, variable, or face; alternatively, it can be a function definition. @@ -405,8 +415,13 @@ If TYPE is not a symbol, search for a function definition. The return value is the absolute name of a readable file where OBJECT is defined. If several such files exist, preference is given to a file found via `load-path'. The return value can also be `C-source', which -means that OBJECT is a function or variable defined in C. If no -suitable file is found, return nil." +means that OBJECT is a function or variable defined in C, but +it's currently unknown where. If no suitable file is found, +return nil. + +If ALSO-C-SOURCE is non-nil, instead of returning `C-source', +this function will attempt to locate the definition of OBJECT in +the C sources, too." (let* ((autoloaded (autoloadp type)) (file-name (or (and autoloaded (nth 1 type)) (symbol-file @@ -443,14 +458,18 @@ suitable file is found, return nil." (cond ((and (not file-name) (subrp type)) ;; A built-in function. The form is from `describe-function-1'. - (if (get-buffer " *DOC*") + (if (or (get-buffer " *DOC*") + (and also-c-source + (get-buffer-create " *DOC*"))) (help-C-file-name type 'subr) 'C-source)) ((and (not file-name) (symbolp object) (eq type 'defvar) (integerp (get object 'variable-documentation))) ;; A variable defined in C. The form is from `describe-variable'. - (if (get-buffer " *DOC*") + (if (or (get-buffer " *DOC*") + (and also-c-source + (get-buffer-create " *DOC*"))) (help-C-file-name object 'var) 'C-source)) ((not (stringp file-name)) @@ -495,9 +514,16 @@ suitable file is found, return nil." (let ((pt2 (with-current-buffer standard-output (point))) (remapped (command-remapping function))) (unless (memq remapped '(ignore undefined)) - (let ((keys (where-is-internal - (or remapped function) overriding-local-map nil nil)) - non-modified-keys) + (let* ((all-keys (where-is-internal + (or remapped function) overriding-local-map nil nil)) + (seps (seq-group-by + (lambda (key) + (and (vectorp key) + (eq (elt key 0) 'menu-bar))) + all-keys)) + (keys (cdr (assq nil seps))) + (menus (cdr (assq t seps))) + non-modified-keys) (if (and (eq function 'self-insert-command) (vectorp (car-safe keys)) (consp (aref (car keys) 0))) @@ -521,29 +547,85 @@ suitable file is found, return nil." ;; don't mention them one by one. (if (< (length non-modified-keys) 10) (with-current-buffer standard-output - (insert (mapconcat #'help--key-description-fontified - keys ", "))) + (help-fns--insert-bindings keys)) (dolist (key non-modified-keys) (setq keys (delq key keys))) (if keys (with-current-buffer standard-output - (insert (mapconcat #'help--key-description-fontified - keys ", ")) + (help-fns--insert-bindings keys) (insert ", and many ordinary text characters")) - (princ "many ordinary text characters")))) + (princ "many ordinary text characters.")))) (when (or remapped keys non-modified-keys) (princ ".") - (terpri))))) + (terpri))) - (with-current-buffer standard-output - (fill-region-as-paragraph pt2 (point)) - (unless (looking-back "\n\n" (- (point) 2)) - (terpri)))))) + (with-current-buffer standard-output + (fill-region-as-paragraph pt2 (point)) + (unless (bolp) + (insert "\n")) + (when menus + (let ((start (point))) + (help-fns--insert-menu-bindings + menus + (concat "It can " (and keys "also ") + "be invoked from the menu: ")) + (fill-region-as-paragraph start (point)))) + (ensure-empty-lines))))))) + +(defun help-fns--insert-bindings (keys) + (seq-do-indexed (lambda (key i) + (insert + (cond ((zerop i) "") + ((= i (1- (length keys))) " and ") + (t ", "))) + (insert (help--key-description-fontified key))) + keys)) + +(defun help-fns--insert-menu-bindings (menus heading) + (seq-do-indexed + (lambda (menu i) + (insert + (cond ((zerop i) "") + ((= i (1- (length menus))) " and ") + (t ", "))) + (let ((map (lookup-key global-map (seq-take menu 1))) + (start (point))) + (seq-do-indexed + (lambda (entry level) + (when (symbolp map) + (setq map (symbol-function map))) + (when-let ((elem (assq entry (cdr map)))) + (when heading + (insert heading) + (setq heading nil start (point))) + (when (> level 0) + (insert + (if (char-displayable-p ?→) + " → " + " => "))) + (if (eq (nth 1 elem) 'menu-item) + (progn + (insert (nth 2 elem)) + (setq map (cadddr elem))) + (insert (nth 1 elem)) + (setq map (cddr elem))))) + (cdr (seq-into menu 'list))) + (put-text-property start (point) 'face 'help-key-binding))) + menus)) (defun help-fns--compiler-macro (function) - (let ((handler (function-get function 'compiler-macro))) + (pcase-dolist (`(,type . ,handler) + (list (cons "compiler macro" + (function-get function 'compiler-macro)) + (cons "`byte-compile' property" + (function-get function 'byte-compile)) + (cons "byte-code optimizer" + (function-get function 'byte-optimizer)))) (when handler - (insert " This function has a compiler macro") + (if (bolp) + (insert " This function has a ") + (insert " and a ")) + (insert type) (if (symbolp handler) (progn (insert (format-message " `%s'" handler)) @@ -558,8 +640,17 @@ suitable file is found, return nil." (save-excursion (re-search-backward (substitute-command-keys "`\\([^`']+\\)'") nil t) - (help-xref-button 1 'help-function-cmacro function lib))))) - (insert ".\n")))) + (help-xref-button 1 'help-function-cmacro function lib))))))) + (unless (bolp) + (insert ". See " + (buttonize "the manual" + (lambda (_) (info "(elisp)Advice and Byte Code"))) + " for details.\n") + (save-restriction + (let ((fill-prefix " ")) + (narrow-to-region (line-beginning-position -1) (point)) + (fill-region (point-min) (point-max))) + (goto-char (point-max))))) (defun help-fns--signature (function doc real-def real-function buffer) "Insert usage at point and return docstring. With highlighting." @@ -652,19 +743,9 @@ suitable file is found, return nil." (terpri))) ;; We could use `symbol-file' but this is a wee bit more efficient. -(defun help-fns--autoloaded-p (function file) - "Return non-nil if FUNCTION has previously been autoloaded. -FILE is the file where FUNCTION was probably defined." - (let* ((file (file-name-sans-extension (file-truename file))) - (load-hist load-history) - (target (cons t function)) - found) - (while (and load-hist (not found)) - (and (stringp (caar load-hist)) - (equal (file-name-sans-extension (caar load-hist)) file) - (setq found (member target (cdar load-hist)))) - (setq load-hist (cdr load-hist))) - found)) +(defun help-fns--autoloaded-p (function) + "Return non-nil if FUNCTION has previously been autoloaded." + (seq-some #'autoloadp (get function 'function-history))) (defun help-fns--interactive-only (function) "Insert some help blurb if FUNCTION should only be used interactively." @@ -718,21 +799,23 @@ FILE is the file where FUNCTION was probably defined." (erase-buffer) (insert-file-contents f) (goto-char (point-min)) - (search-forward "\n*") - (while (re-search-forward re nil t) - (let ((pos (match-beginning 0))) - (save-excursion - ;; Almost all entries are of the form "* ... in Emacs NN.MM." - ;; but there are also a few in the form "* Emacs NN.MM is a bug - ;; fix release ...". - (if (not (re-search-backward "^\\* .* Emacs \\([0-9.]+[0-9]\\)" - nil t)) - (message "Ref found in non-versioned section in %S" - (file-name-nondirectory f)) - (let ((version (match-string 1))) - (when (or (null first) (version< version first)) - (setq place (list f pos)) - (setq first version))))))))) + ;; Failed git merges can leave empty files that look like NEWS + ;; in etc. Don't error here. + (when (search-forward "\n*" nil t) + (while (re-search-forward re nil t) + (let ((pos (match-beginning 0))) + (save-excursion + ;; Almost all entries are of the form "* ... in Emacs NN.MM." + ;; but there are also a few in the form "* Emacs NN.MM is a bug + ;; fix release ...". + (if (not (re-search-backward "^\\* .* Emacs \\([0-9.]+[0-9]\\)" + nil t)) + (message "Ref found in non-versioned section in %S" + (file-name-nondirectory f)) + (let ((version (match-string 1))) + (when (or (null first) (version< version first)) + (setq place (list f pos)) + (setq first version)))))))))) (when first (make-text-button first nil 'type 'help-news 'help-args place)))) @@ -774,7 +857,8 @@ FILE is the file where FUNCTION was probably defined." (insert-text-button (symbol-name group) 'action (lambda (_) - (shortdoc-display-group group object)) + (shortdoc-display-group group object + help-window-keep-selected)) 'follow-link t 'help-echo (purecopy "mouse-1, RET: show documentation group"))) groups) @@ -828,11 +912,7 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)." (symbol-name function))))))) (real-def (cond ((and aliased (not (subrp def))) - (let ((f real-function)) - (while (and (fboundp f) - (symbolp (symbol-function f))) - (setq f (symbol-function f))) - f)) + (car (function-alias-p real-function t))) ((subrp def) (intern (subr-name def))) (t def)))) @@ -851,13 +931,13 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)." "Print a line describing FUNCTION to `standard-output'." (pcase-let* ((`(,_real-function ,def ,aliased ,real-def) (help-fns--analyze-function function)) - (file-name (find-lisp-object-file-name function (if aliased 'defun - def))) + (file-name (find-lisp-object-file-name + function (if aliased 'defun def))) (beg (if (and (or (byte-code-function-p def) (keymapp def) (memq (car-safe def) '(macro lambda closure))) (stringp file-name) - (help-fns--autoloaded-p function file-name)) + (help-fns--autoloaded-p function)) (concat "an autoloaded " (if (commandp def) "interactive ")) @@ -946,12 +1026,18 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)." ;;;###autoload (defun describe-function-1 (function) - (let ((pt1 (with-current-buffer (help-buffer) (point)))) + (let ((pt1 (with-current-buffer standard-output (point)))) (help-fns-function-description-header function) - (with-current-buffer (help-buffer) - (fill-region-as-paragraph (save-excursion (goto-char pt1) (forward-line 0) (point)) - (point)))) - (terpri)(terpri) + (with-current-buffer standard-output + (let ((inhibit-read-only t)) + (fill-region-as-paragraph + (save-excursion + (goto-char pt1) + (forward-line 0) + (point)) + (point) + nil t) + (ensure-empty-lines)))) (pcase-let* ((`(,real-function ,def ,_aliased ,real-def) (help-fns--analyze-function function)) @@ -995,7 +1081,7 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)." (add-hook 'help-fns-describe-function-functions #'help-fns--obsolete) (add-hook 'help-fns-describe-function-functions #'help-fns--interactive-only) (add-hook 'help-fns-describe-function-functions #'help-fns--parent-mode) -(add-hook 'help-fns-describe-function-functions #'help-fns--compiler-macro) +(add-hook 'help-fns-describe-function-functions #'help-fns--compiler-macro 100) ;; Variables @@ -1078,7 +1164,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)) @@ -1138,10 +1225,11 @@ it is displayed along with the global value." (let ((rep (let ((print-quoted t) (print-circle t)) - (cl-prin1-to-string val)))) - (if (and (symbolp val) (not (booleanp val))) + (cl-prin1-to-string val)))) + (if (and (symbolp val) (not (booleanp val))) (format-message "`%s'" rep) - rep)))) + rep))) + (start (point))) (if (< (+ (length print-rep) (point) (- line-beg)) 68) (insert " " print-rep) (terpri) @@ -1156,6 +1244,8 @@ it is displayed along with the global value." (insert-buffer-substring pp-buffer))))) ;; Remove trailing newline. (and (= (char-before) ?\n) (delete-char -1))) + (help-fns--editable-variable start (point) + variable val buffer) (let* ((sv (get variable 'standard-value)) (origval (and (consp sv) (condition-case nil @@ -1175,6 +1265,8 @@ it is displayed along with the global value." (save-restriction (narrow-to-region from (point)) (save-excursion (pp-buffer))) + (help-fns--editable-variable from (point) + variable origval buffer) (if (< (point) (+ from 20)) (delete-region (1- from) from))))))) (terpri) @@ -1207,7 +1299,9 @@ it is displayed along with the global value." ;; See previous comment for this function. ;; (help-xref-on-pp from (point)) (if (< (point) (+ from 20)) - (delete-region (1- from) from))))))) + (delete-region (1- from) from)) + (help-fns--editable-variable + from (point) variable global-val buffer)))))) (terpri)) ;; If the value is large, move it to the end. @@ -1257,6 +1351,66 @@ it is displayed along with the global value." ;; Return the text we displayed. (buffer-string)))))))) +(defun help-fns--editable-variable (start end variable value buffer) + (when (and (readablep value) + (or (not (symbolp value)) + (and (not (and (symbolp value) (boundp value))) + (not (and (symbolp value) (fboundp value))))) + help-enable-variable-value-editing) + (add-text-properties + start end + (list 'help-echo "`e' to edit the value" + 'help-fns--edit-variable (list variable value buffer + (current-buffer)) + 'keymap (define-keymap + "e" #'help-fns-edit-variable))))) + +(defvar help-fns--edit-variable) + +(put 'help-fns-edit-variable 'disabled t) +(defun help-fns-edit-variable () + "Edit the variable under point." + (interactive) + (declare (completion ignore)) + (let ((var (get-text-property (point) 'help-fns--edit-variable))) + (unless var + (error "No variable under point")) + (pop-to-buffer-same-window (format "*edit %s*" (nth 0 var))) + (prin1 (nth 1 var) (current-buffer)) + (pp-buffer) + (goto-char (point-min)) + (insert (format ";; Edit the `%s' variable.\n" (nth 0 var)) + ";; C-c C-c to update the value and exit.\n\n") + (help-fns--edit-value-mode) + (setq-local help-fns--edit-variable var))) + +(defvar-keymap help-fns--edit-value-mode-map + "C-c C-c" #'help-fns-edit-mode-done) + +(define-derived-mode help-fns--edit-value-mode emacs-lisp-mode "Elisp" + :interactive nil) + +(defun help-fns-edit-mode-done (&optional kill) + "Update the value of the variable and kill the buffer. +If KILL (the prefix), don't update the value, but just kill the +current buffer." + (interactive "P" help-fns--edit-value-mode) + (unless help-fns--edit-variable + (error "Invalid buffer")) + (goto-char (point-min)) + (cl-destructuring-bind (variable _ buffer help-buffer) + help-fns--edit-variable + (unless (buffer-live-p buffer) + (error "Original buffer is gone; can't update")) + (unless kill + (let ((value (read (current-buffer)))) + (with-current-buffer buffer + (set variable value)))) + (kill-buffer (current-buffer)) + (when (buffer-live-p help-buffer) + (with-current-buffer help-buffer + (revert-buffer))))) + (defun help-fns--run-describe-functions (functions &rest args) (with-current-buffer standard-output (unless (bolp) @@ -1461,77 +1615,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 +1716,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 +1757,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 +1803,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 +1829,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. @@ -1746,8 +1904,8 @@ variable with value KEYMAP." The heuristic to determine which keymap is most likely to be relevant to a user follows this order: -1. 'keymap' text property at point -2. 'local-map' text property at point +1. `keymap' text property at point +2. `local-map' text property at point 3. the `current-local-map' This is used to set the default value for the interactive prompt @@ -1766,7 +1924,10 @@ in `describe-keymap'. See also `Searching the Active Keymaps'." When called interactively, prompt for a variable that has a keymap value." (interactive - (let* ((km (help-fns--most-relevant-active-keymap)) + (let* ((sym (symbol-at-point)) + (km (or (and (keymapp (ignore-errors (symbol-value sym))) + sym) + (help-fns--most-relevant-active-keymap))) (val (completing-read (format-prompt "Keymap" km) obarray @@ -1778,7 +1939,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 +2006,96 @@ 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. - (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) + (unless buffer + (setq buffer (current-buffer))) + (let ((help-buffer-under-preparation t) + (local-minors (buffer-local-value 'local-minor-modes 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 (help-buffer) + ;; Add the local minor modes at the start. + (when local-minors + (insert (format "Minor mode%s enabled in this buffer:" + (if (length> local-minors 1) + "s" ""))) + (describe-mode--minor-modes local-minors)) + + ;; Document the major mode. + (let ((major (buffer-local-value 'major-mode buffer))) + (insert "The major mode is " + (buttonize + (propertize (format-mode-line + (buffer-local-value 'mode-name buffer) + nil nil buffer) + 'face 'bold) + (lambda (_) + (describe-function major)))) + (insert " mode") + (when-let ((file-name (find-lisp-object-file-name major nil))) + (insert (format " defined in %s:\n\n" + (buttonize + (help-fns-short-filename file-name) + (lambda (_) + (help-function-def--button-function + major file-name)))))) + (insert (help-split-fundoc (documentation major) nil 'doc) + (with-current-buffer buffer + (help-fns--list-local-commands))) + (ensure-empty-lines 1) + + ;; Insert the global minor modes after the major mode. + (when global-minor-modes + (insert (format "Global minor mode%s enabled:" + (if (length> global-minor-modes 1) + "s" ""))) + (describe-mode--minor-modes global-minor-modes) + (when (re-search-forward "^\f") + (beginning-of-line) + (ensure-empty-lines 1))) + ;; For the sake of IELM and maybe others + nil))))) + +(defun describe-mode--minor-modes (modes) + (dolist (mode (seq-sort #'string< modes)) + (let ((pretty-minor-mode + (capitalize + (replace-regexp-in-string + "\\(\\(-minor\\)?-mode\\)?\\'" "" + (symbol-name mode))))) + (insert + " " + (buttonize + pretty-minor-mode + (lambda (mode) + (goto-char (point-min)) + (text-property-search-forward + 'help-minor-mode mode t) + (beginning-of-line)) + mode)) + (save-excursion + (goto-char (point-max)) + (insert "\n\n\f\n") + ;; Document the minor modes fully. + (insert (buttonize + (propertize pretty-minor-mode 'help-minor-mode mode) + (lambda (mode) + (describe-function mode)) + mode)) + (let ((indicator + (format-mode-line (assq mode minor-mode-alist)))) + (insert (format " minor mode (%s):\n" + (if (zerop (length indicator)) + "no indicator" + (format "indicator%s" + indicator))))) + (insert (help-split-fundoc (documentation mode) nil 'doc))))) + (forward-line -1) + (fill-paragraph nil) + (forward-paragraph 1) + (ensure-empty-lines 1)) (defun help-fns--list-local-commands () (let ((functions nil)) @@ -1998,7 +2150,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 7b6ccdc174e..91c2a804000 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 ee68d253cb8..2fcb8b9f3e6 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) @@ -43,6 +45,7 @@ (define-key map [XF86Forward] 'help-go-forward) (define-key map "\C-c\C-c" 'help-follow-symbol) (define-key map "s" 'help-view-source) + (define-key map "I" 'help-goto-lispref-info) (define-key map "i" 'help-goto-info) (define-key map "c" 'help-customize) map) @@ -265,7 +268,9 @@ The format is (FUNCTION ARGS...).") (let* ((location (find-function-search-for-symbol fun type file)) (position (cdr location))) - (pop-to-buffer (car location)) + (if help-window-keep-selected + (pop-to-buffer-same-window (car location)) + (pop-to-buffer (car location))) (run-hooks 'find-function-after-hook) (if position (progn @@ -273,6 +278,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"))))) @@ -287,7 +296,10 @@ The format is (FUNCTION ARGS...).") (setq file (locate-library file t)) (if (and file (file-readable-p file)) (progn - (pop-to-buffer (find-file-noselect file)) + (if help-window-keep-selected + (pop-to-buffer-same-window + (find-file-noselect file)) + (pop-to-buffer (find-file-noselect file))) (widen) (goto-char (point-min)) (if (re-search-forward @@ -306,7 +318,9 @@ The format is (FUNCTION ARGS...).") (setq file (help-C-file-name var 'var))) (let* ((location (find-variable-noselect var file)) (position (cdr location))) - (pop-to-buffer (car location)) + (if help-window-keep-selected + (pop-to-buffer-same-window (car location)) + (pop-to-buffer (car location))) (run-hooks 'find-function-after-hook) (if position (progn @@ -327,7 +341,9 @@ The format is (FUNCTION ARGS...).") (let* ((location (find-function-search-for-symbol fun 'defface file)) (position (cdr location))) - (pop-to-buffer (car location)) + (if help-window-keep-selected + (pop-to-buffer-same-window (car location)) + (pop-to-buffer (car location))) (if position (progn ;; Widen the buffer if necessary to go to this position. @@ -369,9 +385,18 @@ The format is (FUNCTION ARGS...).") :supertype 'help-xref 'help-function (lambda (file pos) - (view-buffer-other-window (find-file-noselect file)) + (if help-window-keep-selected + (view-buffer (find-file-noselect file)) + (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) @@ -379,7 +404,8 @@ The format is (FUNCTION ARGS...).") ;;;###autoload (define-derived-mode help-mode special-mode "Help" "Major mode for viewing help text and navigating references in it. -Entry to this mode runs the normal hook `help-mode-hook'. +Also see the `help-enable-variable-value-editing' variable. + Commands: \\{help-mode-map}" (setq-local revert-buffer-function @@ -389,17 +415,21 @@ Commands: help-mode-tool-bar-map) (setq-local help-mode--current-data nil) (setq-local bookmark-make-record-function - #'help-bookmark-make-record)) + #'help-bookmark-make-record) + (unless search-default-mode + (isearch-fold-quotes-mode))) ;;;###autoload (defun help-mode-setup () "Enter Help mode in the current buffer." + (declare (obsolete nil "29.1")) (help-mode) (setq buffer-read-only nil)) ;;;###autoload (defun help-mode-finish () "Finalize Help mode setup in current buffer." + (declare (obsolete nil "29.1")) (when (derived-mode-p 'help-mode) (setq buffer-read-only t) (help-make-xrefs (current-buffer)))) @@ -424,6 +454,7 @@ Commands: "\\(symbol\\|program\\|property\\)\\|" ; Don't link "\\(source \\(?:code \\)?\\(?:of\\|for\\)\\)\\)" "[ \t\n]+\\)?" + "\\(\\\\\\+\\)?" "['`‘]\\(\\(?:\\sw\\|\\s_\\)+\\|`\\)['’]")) "Regexp matching doc string references to symbols. @@ -600,27 +631,28 @@ that." ;; Quoted symbols (save-excursion (while (re-search-forward help-xref-symbol-regexp nil t) - (let* ((data (match-string 8)) - (sym (intern-soft data))) - (if sym - (cond - ((match-string 3) ; `variable' &c - (and (or (boundp sym) ; `variable' doesn't ensure + (when-let ((sym (intern-soft (match-string 9)))) + (if (match-string 8) + (delete-region (match-beginning 8) + (match-end 8)) + (cond + ((match-string 3) ; `variable' &c + (and (or (boundp sym) ; `variable' doesn't ensure ; it's actually bound - (get sym 'variable-documentation)) - (help-xref-button 8 'help-variable sym))) - ((match-string 4) ; `function' &c - (and (fboundp sym) ; similarly - (help-xref-button 8 'help-function sym))) - ((match-string 5) ; `face' - (and (facep sym) - (help-xref-button 8 'help-face sym))) - ((match-string 6)) ; nothing for `symbol' - ((match-string 7) - (help-xref-button 8 'help-function-def sym)) - ((cl-some (lambda (x) (funcall (nth 1 x) sym)) - describe-symbol-backends) - (help-xref-button 8 'help-symbol sym))))))) + (get sym 'variable-documentation)) + (help-xref-button 9 'help-variable sym))) + ((match-string 4) ; `function' &c + (and (fboundp sym) ; similarly + (help-xref-button 9 'help-function sym))) + ((match-string 5) ; `face' + (and (facep sym) + (help-xref-button 9 'help-face sym))) + ((match-string 6)) ; nothing for `symbol' + ((match-string 7) + (help-xref-button 9 'help-function-def sym)) + ((cl-some (lambda (x) (funcall (nth 1 x) sym)) + describe-symbol-backends) + (help-xref-button 9 'help-symbol sym))))))) ;; An obvious case of a key substitution: (save-excursion (while (re-search-forward @@ -631,34 +663,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 +800,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) @@ -811,7 +836,16 @@ See `help-make-xrefs'." (unless help-mode--current-data (error "No symbol to look up in the current buffer")) (info-lookup-symbol (plist-get help-mode--current-data :symbol) - 'emacs-lisp-mode)) + 'emacs-lisp-mode + help-window-keep-selected)) + +(defun help-goto-lispref-info () + "View the Emacs Lisp manual *info* node of the current help item." + (interactive nil help-mode) + (unless help-mode--current-data + (error "No symbol to look up in the current buffer")) + (info-lookup-symbol (plist-get help-mode--current-data :symbol) + 'emacs-lisp-only)) (defun help-customize () "Customize variable or face whose doc string is shown in the current buffer." @@ -921,6 +955,7 @@ BOOKMARK is a bookmark name or a bookmark record." (pop-to-buffer "*Help*") (goto-char position))) +(put 'help-bookmark-jump 'bookmark-handler-type "Help") (provide 'help-mode) diff --git a/lisp/help.el b/lisp/help.el index fd331ac0d48..1faebdf461d 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) @@ -448,8 +453,8 @@ With argument, display info only for the selected version." ((< vn 18) "NEWS.1-17") (t (format "NEWS.%d" vn)))) res) - (view-file (expand-file-name file data-directory)) - (widen) + (find-file (expand-file-name file data-directory)) + (emacs-news-view-mode) (goto-char (point-min)) (when (stringp version) (when (re-search-forward @@ -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. @@ -614,7 +621,7 @@ If INSERT (the prefix arg) is non-nil, insert the message in the buffer." (enable-recursive-minibuffers t) val) (setq val (completing-read (format-prompt "Where is command" fn) - obarray 'commandp t nil nil + obarray #'commandp t nil nil (and fn (symbol-name fn)))) (list (unless (equal val "") (intern val)) current-prefix-arg))) @@ -643,15 +650,21 @@ If INSERT (the prefix arg) is non-nil, insert the message in the buffer." (if insert (if (> (length keys) 0) (if remapped - (format "%s (%s) (remapped from %s)" - keys remapped symbol) - (format "%s (%s)" keys symbol)) + (format "%s, remapped to %s (%s)" + symbol remapped keys) + (format "%s (%s)" symbol keys)) (format "M-x %s RET" symbol)) (if (> (length keys) 0) (if remapped - (format "%s is remapped to %s which is on %s" - symbol remapped keys) - (format "%s is on %s" symbol keys)) + (if (eq symbol (symbol-function definition)) + (format + "%s, which is remapped to %s, which is on %s" + symbol remapped keys) + (format "%s is remapped to %s, which is on %s" + symbol remapped keys)) + (if (eq symbol (symbol-function definition)) + (format "%s, which is on %s" symbol keys) + (format "%s is on %s" symbol keys))) ;; If this is the command the user asked about, ;; and it is not on any key, say so. ;; For other symbols, its aliases, say nothing @@ -660,7 +673,9 @@ If INSERT (the prefix arg) is non-nil, insert the message in the buffer." (format "%s is not on any key" symbol))))) (when string (unless (eq symbol definition) - (princ ";\n its alias ")) + (if (eq definition (symbol-function symbol)) + (princ ";\n its alias ") + (princ ";\n it's an alias for "))) (princ string))))) nil) @@ -852,7 +867,7 @@ with `mouse-movement' events." (memq 'down last-modifiers) ;; After a click, see if a double click is on the way. (and (memq 'click last-modifiers) - (not (sit-for (/ double-click-time 1000.0) t)))) + (not (sit-for (/ (mouse-double-click-time) 1000.0) t)))) (let* ((seq (read-key-sequence "\ Describe the following key, mouse click, or menu item: " nil nil 'can-return-switch-frame)) @@ -892,6 +907,12 @@ While reading KEY-LIST interactively, this command temporarily enables menu items or tool-bar buttons that are disabled to allow getting help on them. +Interactively, this command can't describe prefix commands, but +will always wait for the user to type the complete key sequence. +For instance, entering \"C-x\" will wait until the command has +been completed, but `M-: (describe-key (kbd \"C-x\")) RET' will +tell you what this prefix command is bound to. + BUFFER is the buffer in which to lookup those keys; it defaults to the current buffer." (declare (advertised-calling-convention (key-list &optional buffer) "27.1")) @@ -903,7 +924,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,25 +1082,38 @@ is currently activated with completion." result)) -(defun substitute-command-keys (string &optional no-face) +(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 include-menus) "Substitute key descriptions for command names in STRING. Each substring of the form \\\\=[COMMAND] is replaced by either a 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 \\\\={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 -(used by the helper function ‘help-make-xrefs’ to find the end of the -summary). +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'. This will normally +exclude menu bindings, but if the optional INCLUDE-MENUS argument +is non-nil, also include menu bindings. The summary ends in two +newlines (used by the helper function `help-make-xrefs' to find +the end of the summary). Each substring of the form \\\\=<MAPVAR> specifies the use of MAPVAR as the keymap for future \\\\=[COMMAND] substrings. Each grave accent \\=` is replaced by left quote, and each apostrophe \\=' is replaced by right quote. Left and right quote characters are -specified by ‘text-quoting-style’. +specified by `text-quoting-style'. \\\\== quotes the following character and is discarded; thus, \\\\==\\\\== puts \\\\== into the output, \\\\==\\[ puts \\[ into the output, and \\\\==\\=` puts \\=` into the @@ -1119,6 +1154,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 +1202,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]. @@ -1193,9 +1255,11 @@ Otherwise, return a new string." (t ;; Get the list of active keymaps that precede this one. ;; If this one's not active, get nil. - (let ((earlier-maps (cdr (memq this-keymap (reverse active-maps))))) + (let ((earlier-maps + (cdr (memq this-keymap (reverse active-maps))))) (describe-map-tree this-keymap t (nreverse earlier-maps) - nil nil t nil nil t)))))))) + nil nil (not include-menus) + nil nil t)))))))) ;; 2. Handle quotes. ((and (eq (text-quoting-style) 'curve) (or (and (= (following-char) ?\`) @@ -1212,8 +1276,9 @@ 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 + buffer) "Insert a description of the key bindings in STARTMAP. This is followed by the key bindings of all maps reachable through STARTMAP. @@ -1241,8 +1306,8 @@ 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')." +If BUFFER, lookup keys while in that buffer. This only affects +things like :filters for menu bindings." (let* ((amaps (accessible-keymaps startmap prefix)) (orig-maps (if no-menu (progn @@ -1259,17 +1324,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) @@ -1292,10 +1348,27 @@ Any inserted text ends in two newlines (used by (setq sub-shadows (cons (cdr (car tail)) sub-shadows))) (setq tail (cdr tail)))) (describe-map (cdr elt) elt-prefix transl partial - sub-shadows no-menu mention-shadow))) + sub-shadows no-menu mention-shadow + buffer))) (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 +1381,38 @@ 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 (format "[%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,26 +1426,35 @@ 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 buffer) "Describe the contents of keymap MAP. Assume that this keymap itself is reached by the sequence of prefix keys PREFIX (a string or vector). -TRANSL, PARTIAL, SHADOW, NOMENU, MENTION-SHADOW are as in -`describe-map-tree'." +TRANSL, PARTIAL, SHADOW, NOMENU, MENTION-SHADOW and BUFFER are as +in `describe-map-tree'." ;; Converted from describe_map in keymap.c. (let* ((suppress (and partial 'suppress-keymap)) (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) @@ -1412,7 +1484,10 @@ TRANSL, PARTIAL, SHADOW, NOMENU, MENTION-SHADOW are as in ((and mention-shadow (not (eq tem definition))) (setq this-shadowed t)) (t nil)))) - (eq definition (lookup-key tail (vector event) t)) + (eq definition (if buffer + (with-current-buffer buffer + (lookup-key tail (vector event) t)) + (lookup-key tail (vector event) t))) (push (list event definition this-shadowed) vect)))) ((eq (car tail) 'keymap) ;; The same keymap might be in the structure twice, if @@ -1425,7 +1500,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 +1510,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 +1524,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 +1733,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 +1757,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 @@ -1667,13 +1806,25 @@ the help window appears on another frame, it may get selected and its frame get input focus even if this option is nil. This option has effect if and only if the help window was created -by `with-help-window'." +by `with-help-window'. + +Also see `help-window-keep-selected'." :type '(choice (const :tag "never (nil)" nil) (const :tag "other" other) (const :tag "always (t)" t)) :group 'help :version "23.1") +(defcustom help-window-keep-selected nil + "If non-nil, navigation commands in the *Help* buffer will reuse the window. +If nil, many commands in the *Help* buffer, like \\<help-mode-map>\\[help-view-source] and \\[help-goto-info], will +pop to a different window to display the results. + +Also see `help-window-select'." + :type 'boolean + :group 'help + :version "29.1") + (define-obsolete-variable-alias 'help-enable-auto-load 'help-enable-autoload "27.1") @@ -1754,13 +1905,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 +1922,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,48 +1930,47 @@ 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)) -;; `with-help-window' is a wrapper for `with-temp-buffer-window' -;; providing the following additional twists: - -;; (1) It puts the buffer in `help-mode' (via `help-mode-setup') and -;; adds cross references (via `help-mode-finish'). - -;; (2) It issues a message telling how to scroll and quit the help -;; window (via `help-window-setup'). - -;; (3) An option (customizable via `help-window-select') to select the -;; help window automatically. - -;; (4) A marker (`help-window-point-marker') to move point in the help -;; window to an arbitrary buffer position. (defmacro with-help-window (buffer-or-name &rest body) "Evaluate BODY, send output to BUFFER-OR-NAME and show in a help window. -This construct is like `with-temp-buffer-window', which see, but unlike -that, it puts the buffer specified by BUFFER-OR-NAME in `help-mode' and -displays a message about how to delete the help window when it's no -longer needed. The help window will be selected if -`help-window-select' is non-nil. -Most of this is done by `help-window-setup', which see." +The return value from BODY will be returned. + +The help window will be selected if `help-window-select' is +non-nil. + +The `temp-buffer-window-setup-hook' hook is called." (declare (indent 1) (debug t)) - `(progn - ;; Make `help-window-point-marker' point nowhere. The only place - ;; where this should be set to a buffer position is within BODY. - (set-marker help-window-point-marker nil) - (let ((temp-buffer-window-setup-hook - (cons 'help-mode-setup temp-buffer-window-setup-hook)) - (temp-buffer-window-show-hook - (cons 'help-mode-finish temp-buffer-window-show-hook))) - (setq help-window-old-frame (selected-frame)) - (with-temp-buffer-window - ,buffer-or-name nil 'help-window-setup (progn ,@body))))) + `(help--window-setup ,buffer-or-name (lambda () ,@body))) + +(defun help--window-setup (buffer callback) + ;; Make `help-window-point-marker' point nowhere. The only place + ;; where this should be set to a buffer position is within BODY. + (set-marker help-window-point-marker nil) + (with-current-buffer (get-buffer-create buffer) + (unless (derived-mode-p 'help-mode) + (help-mode)) + (setq buffer-read-only t + buffer-file-name nil) + (setq-local help-mode--current-data nil) + (buffer-disable-undo) + (let ((inhibit-read-only t) + (inhibit-modification-hooks t)) + (erase-buffer) + (delete-all-overlays) + (prog1 + (let ((standard-output (current-buffer))) + (prog1 + (funcall callback) + (run-hooks 'temp-buffer-window-setup-hook))) + (help-window-setup (temp-buffer-window-show (current-buffer))) + (help-make-xrefs (current-buffer)))))) ;; Called from C, on encountering `help-char' when reading a char. ;; Don't print to *Help*; that would clobber Help history. @@ -1904,7 +2054,7 @@ the same names as used in the original source code, when possible." (if (and (symbolp def) (fboundp def)) (setq def (indirect-function def))) ;; Advice wrappers have "catch all" args, so fetch the actual underlying ;; function to find the real arguments. - (while (advice--p def) (setq def (advice--cdr def))) + (setq def (advice--cd*r def)) ;; If definition is a macro, find the function inside it. (if (eq (car-safe def) 'macro) (setq def (cdr def))) (cond @@ -1957,7 +2107,7 @@ the same names as used in the original source code, when possible." ((symbolp arg) (let ((name (symbol-name arg))) (cond - ((string-match "\\`&" name) arg) + ((string-match "\\`&" name) (bare-symbol arg)) ((string-match "\\`_." name) (intern (upcase (substring name 1)))) (t (intern (upcase name)))))) @@ -2020,7 +2170,10 @@ the suggested string to use instead. See confusables ", ") string)))) -(defun help-command-error-confusable-suggestions (data _context _signal) +(defun help-command-error-confusable-suggestions (data context signal) + ;; Delegate most of the work to the original default value of + ;; `command-error-function' implemented in C. + (command-error-default-function data context signal) (pcase data (`(void-variable ,var) (let ((suggestions (help-uni-confusable-suggestions @@ -2029,8 +2182,12 @@ the suggested string to use instead. See (princ (concat "\n " suggestions) t)))) (_ nil))) -(add-function :after command-error-function - #'help-command-error-confusable-suggestions) +(when (eq command-error-function #'command-error-default-function) + ;; Override the default set in the C code. + ;; This is not done using `add-function' so as to loosen the bootstrap + ;; dependencies. + (setq command-error-function + #'help-command-error-confusable-suggestions)) (define-obsolete-function-alias 'help-for-help-internal #'help-for-help "28.1") diff --git a/lisp/hi-lock.el b/lisp/hi-lock.el index fbd698e234a..0934eef8ed7 100644 --- a/lisp/hi-lock.el +++ b/lisp/hi-lock.el @@ -235,10 +235,12 @@ by cycling through the faces in `hi-lock-face-defaults'." "Human-readable lighters for `hi-lock-interactive-patterns'.") (put 'hi-lock-interactive-lighters 'permanent-local t) -(defvar hi-lock-face-defaults +(defcustom hi-lock-face-defaults '("hi-yellow" "hi-pink" "hi-green" "hi-blue" "hi-salmon" "hi-aquamarine" "hi-black-b" "hi-blue-b" "hi-red-b" "hi-green-b" "hi-black-hb") - "Default faces for hi-lock interactive functions.") + "Default face names for hi-lock interactive functions." + :type '(repeat string) + :version "29.1") (defvar hi-lock-file-patterns-prefix "Hi-lock" "String used to identify hi-lock patterns at the start of files.") @@ -723,21 +725,32 @@ with completion and history." (when hi-lock-interactive-patterns (face-name (hi-lock-keyword->face (car hi-lock-interactive-patterns))))) - (defaults (append hi-lock--unused-faces - (cdr (member last-used-face hi-lock-face-defaults)) - hi-lock-face-defaults)) + (defaults (seq-uniq + (append hi-lock--unused-faces + (cdr (member last-used-face hi-lock-face-defaults)) + hi-lock-face-defaults) + #'equal)) face) - (if (and hi-lock-auto-select-face (not current-prefix-arg)) + (if (and hi-lock-auto-select-face (not current-prefix-arg)) (setq face (or (pop hi-lock--unused-faces) (car defaults))) - (setq face (completing-read - (format-prompt "Highlight using face" (car defaults)) - obarray 'facep t nil 'face-name-history defaults)) + (setq face (symbol-name (read-face-name "Highlight using face" defaults))) ;; Update list of un-used faces. (setq hi-lock--unused-faces (remove face hi-lock--unused-faces)) ;; Grow the list of defaults. (add-to-list 'hi-lock-face-defaults face t)) (intern face))) +(defvar hi-lock-use-overlays nil + "Whether to always use overlays instead of font-lock rules. +When font-lock-mode is enabled and the buffer specifies font-lock rules, +highlighting is performed by adding new font-lock rules to the existing ones, +so when new matching strings are added, they are highlighted by font-lock. +Otherwise, overlays are used, but new highlighting overlays are not added +when new matching strings are inserted to the buffer. +However, sometimes overlays are still preferable even in buffers +where font-lock is enabled, when hi-lock overlays take precedence +over other overlays in the same buffer.") + (defun hi-lock-set-pattern (regexp face &optional subexp lighter case-fold spaces-regexp) "Highlight SUBEXP of REGEXP with face FACE. If omitted or nil, SUBEXP defaults to zero, i.e. the entire @@ -759,7 +772,8 @@ SPACES-REGEXP is a regexp to substitute spaces in font-lock search." (add-to-list 'hi-lock--unused-faces (face-name face)) (push pattern hi-lock-interactive-patterns) (push (cons (or lighter regexp) pattern) hi-lock-interactive-lighters) - (if (and font-lock-mode (font-lock-specified-p major-mode)) + (if (and font-lock-mode (font-lock-specified-p major-mode) + (not hi-lock-use-overlays)) (progn (font-lock-add-keywords nil (list pattern) t) (font-lock-flush)) @@ -781,6 +795,8 @@ SPACES-REGEXP is a regexp to substitute spaces in font-lock search." (match-end subexp)))) (overlay-put overlay 'hi-lock-overlay t) (overlay-put overlay 'hi-lock-overlay-regexp (or lighter regexp)) + ;; Use priority higher than default used by e.g. diff-refine. + (overlay-put overlay 'priority 1) (overlay-put overlay 'face face)) (goto-char (match-end 0))) (when no-matches @@ -854,6 +870,27 @@ SPACES-REGEXP is a regexp to substitute spaces in font-lock search." ;; continue standard unloading nil) +;;; Mouse support +(defalias 'highlight-symbol-at-mouse 'hi-lock-face-symbol-at-mouse) +(defun hi-lock-face-symbol-at-mouse (event) + "Highlight symbol at mouse click EVENT." + (interactive "e") + (save-excursion + (mouse-set-point event) + (highlight-symbol-at-point))) + +;;;###autoload +(defun hi-lock-context-menu (menu click) + "Populate MENU with a menu item to highlight symbol at CLICK." + (when (thing-at-mouse click 'symbol) + (define-key-after menu [highlight-search-separator] menu-bar-separator + 'middle-separator) + (define-key-after menu [highlight-search-mouse] + '(menu-item "Highlight Symbol" highlight-symbol-at-mouse + :help "Highlight symbol at point") + 'highlight-search-separator)) + menu) + (provide 'hi-lock) ;;; hi-lock.el ends here diff --git a/lisp/hl-line.el b/lisp/hl-line.el index 8e60ddf6b07..e5ca6819f0d 100644 --- a/lisp/hl-line.el +++ b/lisp/hl-line.el @@ -102,7 +102,16 @@ This variable has no effect in Global Highlight Line mode. For that, use `global-hl-line-sticky-flag'." :type 'boolean :version "22.1" - :group 'hl-line) + :group 'hl-line + :set (lambda (symbol value) + (set-default symbol value) + (when (featurep 'hl-line) + (unless value + (let ((selected (window-buffer (selected-window)))) + (dolist (buffer (buffer-list)) + (unless (eq buffer selected) + (with-current-buffer buffer + (hl-line-unhighlight))))))))) (defcustom global-hl-line-sticky-flag nil "Non-nil means the Global HL-Line mode highlight appears in all windows. @@ -125,8 +134,11 @@ This variable is expected to be made buffer-local by modes.") (defvar hl-line-overlay-buffer nil "Most recently visited buffer in which Hl-Line mode is enabled.") -(defvar hl-line-overlay-priority -50 - "Priority used on the overlay used by hl-line.") +(defcustom hl-line-overlay-priority -50 + "Priority used on the overlay used by hl-line." + :type 'integer + :version "28.1" + :group 'hl-line) ;;;###autoload (define-minor-mode hl-line-mode diff --git a/lisp/htmlfontify.el b/lisp/htmlfontify.el index 115f67c9560..89cacdff21b 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) @@ -363,7 +364,7 @@ the etags output on stdout. Two canned commands are provided - they drive Emacs's etags and exuberant-ctags' etags respectively." :tag "etags-command" - :type (let ((clist (list '(string)))) + :type (let ((clist (list '(string) '(const :tag "None" nil)))) (dolist (C hfy-etags-cmd-alist) (push (list 'const :tag (car C) (cdr C)) clist)) (cons 'choice clist))) @@ -1156,14 +1157,6 @@ The default handler is `hfy-face-to-css-default'. See also `hfy-face-to-style'.") -(defalias 'hfy-prop-invisible-p - (if (fboundp 'invisible-p) #'invisible-p - (lambda (prop) - "Is text property PROP an active invisibility property?" - (or (and (eq buffer-invisibility-spec t) prop) - (or (memq prop buffer-invisibility-spec) - (assq prop buffer-invisibility-spec)))))) - (defun hfy-find-invisible-ranges () "Return a list of (start-point . end-point) cons cells of invisible regions." (save-excursion @@ -1253,8 +1246,8 @@ return a `defface' style list of face properties instead of a face symbol." (when face-name (setq base-face face-name)) (dolist (P overlay-data) (let ((iprops (cadr (memq 'invisible P)))) ;FIXME: plist-get? - ;;(message "(hfy-prop-invisible-p %S)" iprops) - (when (and iprops (hfy-prop-invisible-p iprops)) + ;;(message "(invisible-p %S)" iprops) + (when (and iprops (invisible-p iprops)) (setq extra-props (cons :invisible (cons t extra-props))) )) (let ((fprops (cadr (or (memq 'face P) @@ -2307,10 +2300,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) @@ -2412,6 +2401,8 @@ You may also want to set `hfy-page-header' and `hfy-page-footer'." (declare (obsolete seq-intersection "28.1")) (nreverse (seq-intersection set-a set-b #'eq))) +(define-obsolete-function-alias 'hfy-prop-invisible-p #'invisible-p "29.1") + (provide 'htmlfontify) ;;; htmlfontify.el ends here diff --git a/lisp/ibuf-ext.el b/lisp/ibuf-ext.el index 0e9f952221f..30b494f5733 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 42576f09cbf..7cfa428e9bc 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 7b7cc5b8bdf..a0f105a628d 100644 --- a/lisp/icomplete.el +++ b/lisp/icomplete.el @@ -139,7 +139,9 @@ See `icomplete-delay-completions-threshold'." :type 'integer) (defvar icomplete-in-buffer nil - "If non-nil, also use Icomplete when completing in non-mini buffers.") + "If non-nil, also use Icomplete when completing in non-mini buffers. +This affects commands like `complete-in-region', but not commands +like `dabbrev-completion', which uses its own completion setup.") (defcustom icomplete-minibuffer-setup-hook nil "Icomplete-specific customization of minibuffer setup. @@ -153,8 +155,7 @@ with other features and packages. For instance: will constrain Emacs to a maximum minibuffer height of 3 lines when icompletion is occurring." - :type 'hook - :group 'icomplete) + :type 'hook) ;;;_* Initialization @@ -174,11 +175,11 @@ Used to implement the option `icomplete-show-matches-on-no-input'.") (defvar icomplete-minibuffer-map (let ((map (make-sparse-keymap))) - (define-key map [?\M-\t] 'icomplete-force-complete) - (define-key map [remap minibuffer-complete-and-exit] 'icomplete-ret) - (define-key map [?\C-j] 'icomplete-force-complete-and-exit) - (define-key map [?\C-.] 'icomplete-forward-completions) - (define-key map [?\C-,] 'icomplete-backward-completions) + (define-key map [?\M-\t] #'icomplete-force-complete) + (define-key map [remap minibuffer-complete-and-exit] #'icomplete-ret) + (define-key map [?\C-j] #'icomplete-force-complete-and-exit) + (define-key map [?\C-.] #'icomplete-forward-completions) + (define-key map [?\C-,] #'icomplete-backward-completions) map) "Keymap used by `icomplete-mode' in the minibuffer.") @@ -380,28 +381,32 @@ 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))) - (define-key map (kbd "C-k") 'icomplete-fido-kill) - (define-key map (kbd "C-d") 'icomplete-fido-delete-char) - (define-key map (kbd "RET") 'icomplete-fido-ret) - (define-key map (kbd "C-m") 'icomplete-fido-ret) - (define-key map (kbd "DEL") 'icomplete-fido-backward-updir) - (define-key map (kbd "M-j") 'icomplete-fido-exit) - (define-key map (kbd "C-s") 'icomplete-forward-completions) - (define-key map (kbd "C-r") 'icomplete-backward-completions) - (define-key map (kbd "<right>") 'icomplete-forward-completions) - (define-key map (kbd "<left>") 'icomplete-backward-completions) - (define-key map (kbd "C-.") 'icomplete-forward-completions) - (define-key map (kbd "C-,") 'icomplete-backward-completions) + (define-key map (kbd "C-k") #'icomplete-fido-kill) + (define-key map (kbd "C-d") #'icomplete-fido-delete-char) + (define-key map (kbd "RET") #'icomplete-fido-ret) + (define-key map (kbd "C-m") #'icomplete-fido-ret) + (define-key map (kbd "DEL") #'icomplete-fido-backward-updir) + (define-key map (kbd "M-j") #'icomplete-fido-exit) + (define-key map (kbd "C-s") #'icomplete-forward-completions) + (define-key map (kbd "C-r") #'icomplete-backward-completions) + (define-key map (kbd "<right>") #'icomplete-forward-completions) + (define-key map (kbd "<left>") #'icomplete-backward-completions) + (define-key map (kbd "C-.") #'icomplete-forward-completions) + (define-key map (kbd "C-,") #'icomplete-backward-completions) map) "Keymap used by `fido-mode' in the minibuffer.") @@ -427,7 +432,7 @@ if that doesn't produce a completion match." This global minor mode makes minibuffer completion behave more like `ido-mode' than regular `icomplete-mode'." - :global t :group 'icomplete + :global t (remove-hook 'minibuffer-setup-hook #'icomplete-minibuffer-setup) (remove-hook 'minibuffer-setup-hook #'icomplete--fido-mode-setup) (when fido-mode @@ -453,7 +458,7 @@ You can use the following key bindings to navigate and select completions: \\{icomplete-minibuffer-map}" - :global t :group 'icomplete + :global t (remove-hook 'minibuffer-setup-hook #'icomplete-minibuffer-setup) (remove-hook 'completion-in-region-mode-hook #'icomplete--in-region-setup) (when icomplete-mode @@ -528,7 +533,7 @@ Usually run by inclusion in `minibuffer-setup-hook'." (setq icomplete--in-region-buffer nil) (delete-overlay icomplete-overlay) (kill-local-variable 'completion-show-inline-help) - (remove-hook 'post-command-hook 'icomplete-post-command-hook t) + (remove-hook 'post-command-hook #'icomplete-post-command-hook t) (message nil))) (when (and completion-in-region-mode icomplete-mode (icomplete-simple-completing-p)) @@ -539,7 +544,7 @@ Usually run by inclusion in `minibuffer-setup-hook'." (unless (memq icomplete-minibuffer-map (cdr tem)) (setcdr tem (make-composed-keymap icomplete-minibuffer-map (cdr tem))))) - (add-hook 'post-command-hook 'icomplete-post-command-hook nil t))) + (add-hook 'post-command-hook #'icomplete-post-command-hook nil t))) (defun icomplete--sorted-completions () (or completion-all-sorted-completions @@ -626,12 +631,12 @@ Usually run by inclusion in `minibuffer-setup-hook'." (defvar icomplete-vertical-mode-minibuffer-map (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-n") 'icomplete-forward-completions) - (define-key map (kbd "C-p") 'icomplete-backward-completions) - (define-key map (kbd "<down>") 'icomplete-forward-completions) - (define-key map (kbd "<up>") 'icomplete-backward-completions) - (define-key map (kbd "M-<") 'icomplete-vertical-goto-first) - (define-key map (kbd "M->") 'icomplete-vertical-goto-last) + (define-key map (kbd "C-n") #'icomplete-forward-completions) + (define-key map (kbd "C-p") #'icomplete-backward-completions) + (define-key map (kbd "<down>") #'icomplete-forward-completions) + (define-key map (kbd "<up>") #'icomplete-backward-completions) + (define-key map (kbd "M-<") #'icomplete-vertical-goto-first) + (define-key map (kbd "M->") #'icomplete-vertical-goto-last) map) "Keymap used by `icomplete-vertical-mode' in the minibuffer.") @@ -687,7 +692,7 @@ See `icomplete-mode' and `minibuffer-setup-hook'." (icomplete-simple-completing-p)) ;Shouldn't be necessary. (let ((saved-point (point))) (save-excursion - (goto-char (point-max)) + (goto-char (icomplete--field-end)) ; Insert the match-status information: (when (and (or icomplete-show-matches-on-no-input (not (equal (icomplete--field-string) @@ -716,11 +721,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 @@ -1044,7 +1044,7 @@ matches exist." (push first prospects))) (concat determ "{" - (mapconcat 'identity prospects icomplete-separator) + (mapconcat #'identity prospects icomplete-separator) (concat (and limit (concat icomplete-separator ellipsis)) "}"))) ;; Restore the base-size info, since completion-all-sorted-completions diff --git a/lisp/ido.el b/lisp/ido.el index 57e79500413..73cd163d465 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." @@ -920,85 +920,76 @@ The fallback command is passed as an argument to the functions." ;;;; Keymaps -(defvar ido-common-completion-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map minibuffer-local-map) - (define-key map "\C-a" 'ido-toggle-ignore) - (define-key map "\C-c" 'ido-toggle-case) - (define-key map "\C-e" 'ido-edit-input) - (define-key map "\t" 'ido-complete) - (define-key map " " 'ido-complete-space) - (define-key map "\C-j" 'ido-select-text) - (define-key map "\C-m" 'ido-exit-minibuffer) - (define-key map "\C-p" 'ido-toggle-prefix) - (define-key map "\C-r" 'ido-prev-match) - (define-key map "\C-s" 'ido-next-match) - (define-key map [?\C-.] 'ido-next-match) - (define-key map [?\C-,] 'ido-prev-match) - (define-key map "\C-t" 'ido-toggle-regexp) - (define-key map "\C-z" 'ido-undo-merge-work-directory) - (define-key map [(control ?\s)] 'ido-restrict-to-matches) - (define-key map [(meta ?\s)] 'ido-take-first-match) - (define-key map [(control ?@)] 'ido-restrict-to-matches) - (define-key map [right] 'ido-next-match) - (define-key map [left] 'ido-prev-match) - (define-key map "?" 'ido-completion-help) - (define-key map "\C-b" 'ido-magic-backward-char) - (define-key map "\C-f" 'ido-magic-forward-char) - (define-key map "\C-d" 'ido-magic-delete-char) - map) - "Keymap for all Ido commands.") - -(defvar ido-file-dir-completion-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map ido-common-completion-map) - (define-key map "\C-x\C-b" 'ido-enter-switch-buffer) - (define-key map "\C-x\C-f" 'ido-fallback-command) - (define-key map "\C-x\C-d" 'ido-enter-dired) - (define-key map [down] 'ido-next-match-dir) - (define-key map [up] 'ido-prev-match-dir) - (define-key map [(meta up)] 'ido-prev-work-directory) - (define-key map [(meta down)] 'ido-next-work-directory) - (define-key map [backspace] 'ido-delete-backward-updir) - (define-key map "\d" 'ido-delete-backward-updir) - (define-key map [remap delete-backward-char] 'ido-delete-backward-updir) ; BS - (define-key map [remap backward-kill-word] 'ido-delete-backward-word-updir) ; M-DEL - (define-key map [(control backspace)] 'ido-up-directory) - (define-key map "\C-l" 'ido-reread-directory) - (define-key map [(meta ?d)] 'ido-wide-find-dir-or-delete-dir) - (define-key map [(meta ?b)] 'ido-push-dir) - (define-key map [(meta ?v)] 'ido-push-dir-first) - (define-key map [(meta ?f)] 'ido-wide-find-file-or-pop-dir) - (define-key map [(meta ?k)] 'ido-forget-work-directory) - (define-key map [(meta ?m)] 'ido-make-directory) - (define-key map [(meta ?n)] 'ido-next-work-directory) - (define-key map [(meta ?o)] 'ido-prev-work-file) - (define-key map [(meta control ?o)] 'ido-next-work-file) - (define-key map [(meta ?p)] 'ido-prev-work-directory) - (define-key map [(meta ?s)] 'ido-merge-work-directories) - map) - "Keymap for Ido file and directory commands.") - -(defvar ido-file-completion-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map ido-file-dir-completion-map) - (define-key map "\C-k" 'ido-delete-file-at-head) - (define-key map "\C-o" 'ido-copy-current-word) - (define-key map "\C-w" 'ido-copy-current-file-name) - (define-key map [(meta ?l)] 'ido-toggle-literal) - map) - "Keymap for Ido file commands.") - -(defvar ido-buffer-completion-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map ido-common-completion-map) - (define-key map "\C-x\C-f" 'ido-enter-find-file) - (define-key map "\C-x\C-b" 'ido-fallback-command) - (define-key map "\C-k" 'ido-kill-buffer-at-head) - (define-key map [?\C-\S-b] 'ido-bury-buffer-at-head) - (define-key map "\C-o" 'ido-toggle-virtual-buffers) - map) - "Keymap for Ido buffer commands.") +(defvar-keymap ido-common-completion-map + :doc "Keymap for all Ido commands." + :parent minibuffer-local-map + "C-a" #'ido-toggle-ignore + "C-c" #'ido-toggle-case + "C-e" #'ido-edit-input + "TAB" #'ido-complete + "SPC" #'ido-complete-space + "C-j" #'ido-select-text + "C-m" #'ido-exit-minibuffer + "C-p" #'ido-toggle-prefix + "C-r" #'ido-prev-match + "C-s" #'ido-next-match + "C-." #'ido-next-match + "C-," #'ido-prev-match + "C-t" #'ido-toggle-regexp + "C-z" #'ido-undo-merge-work-directory + "C-SPC" #'ido-restrict-to-matches + "M-SPC" #'ido-take-first-match + "C-@" #'ido-restrict-to-matches + "<right>" #'ido-next-match + "<left>" #'ido-prev-match + "?" #'ido-completion-help + "C-b" #'ido-magic-backward-char + "C-f" #'ido-magic-forward-char + "C-d" #'ido-magic-delete-char) + +(defvar-keymap ido-file-dir-completion-map + :doc "Keymap for Ido file and directory commands." + :parent ido-common-completion-map + "C-x C-b" #'ido-enter-switch-buffer + "C-x C-f" #'ido-fallback-command + "C-x C-d" #'ido-enter-dired + "<down>" #'ido-next-match-dir + "<up>" #'ido-prev-match-dir + "M-<up>" #'ido-prev-work-directory + "M-<down>" #'ido-next-work-directory + "<backspace>" #'ido-delete-backward-updir + "DEL" #'ido-delete-backward-updir + "<remap> <delete-backward-char>" #'ido-delete-backward-updir + "<remap> <backward-kill-word>" #'ido-delete-backward-word-updir + "C-<backspace>" #'ido-up-directory + "C-l" #'ido-reread-directory + "M-d" #'ido-wide-find-dir-or-delete-dir + "M-b" #'ido-push-dir + "M-v" #'ido-push-dir-first + "M-f" #'ido-wide-find-file-or-pop-dir + "M-k" #'ido-forget-work-directory + "M-m" #'ido-make-directory + "M-n" #'ido-next-work-directory + "M-o" #'ido-prev-work-file + "C-M-o" #'ido-next-work-file + "M-p" #'ido-prev-work-directory + "M-s" #'ido-merge-work-directories) + +(defvar-keymap ido-file-completion-map + :doc "Keymap for Ido file commands." + :parent ido-file-dir-completion-map + "C-o" #'ido-copy-current-word + "C-w" #'ido-copy-current-file-name + "M-l" #'ido-toggle-literal) + +(defvar-keymap ido-buffer-completion-map + :doc "Keymap for Ido buffer commands." + :parent ido-common-completion-map + "C-x C-f" #'ido-enter-find-file + "C-x C-b" #'ido-fallback-command + "C-k" #'ido-kill-buffer-at-head + "C-S-b" #'ido-bury-buffer-at-head + "C-o" #'ido-toggle-virtual-buffers) ;;;; Persistent variables @@ -2247,8 +2238,7 @@ If cursor is not at the end of the user input, move to end of input." (t (add-to-history 'buffer-name-history buf) (setq buf (get-buffer-create buf)) - (if (fboundp 'set-buffer-major-mode) - (set-buffer-major-mode buf)) + (set-buffer-major-mode buf) (ido-visit-buffer buf method t)))))) (defun ido-record-work-directory (&optional dir) @@ -3949,7 +3939,7 @@ If `ido-change-word-sub' cannot be found in WORD, return nil." ;; In the new buffer, go to the first completion. ;; FIXME: Perhaps this should be done in `ido-completion-help'. (when (bobp) - (next-completion 1))))) + (first-completion))))) (defun ido-completion-auto-help () "Call `ido-completion-help' if `completion-auto-help' is non-nil." diff --git a/lisp/ielm.el b/lisp/ielm.el index b20b939e134..47c17921181 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/iimage.el b/lisp/iimage.el index 2fe50d3e3f1..8a765d5e5d5 100644 --- a/lisp/iimage.el +++ b/lisp/iimage.el @@ -76,11 +76,9 @@ Examples of image filename patterns to match: foo.JPG" :type '(alist :key-type regexp :value-type integer)) -(defvar iimage-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\C-l" #'iimage-recenter) - map) - "Keymap used in `iimage-mode'.") +(defvar-keymap iimage-mode-map + :doc "Keymap used in `iimage-mode'." + "C-l" #'iimage-recenter) (defun iimage-recenter (&optional arg) "Re-draw images and recenter." diff --git a/lisp/image-dired.el b/lisp/image-dired.el index dd22f1ffa90..30bf5ee1086 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-2022 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,37 @@ 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. + (hash (md5 (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 +626,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 +651,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 +743,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 +755,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 +764,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 +780,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 +894,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 +933,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 +956,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 +975,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 +1015,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 +1039,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 +1090,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 +1212,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 +1258,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 +1280,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 +1300,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 +1361,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 +1378,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 +1415,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 +1550,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 +1776,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 +1871,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 +1940,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 +1965,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 +1996,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 +2005,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 +2032,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 +2066,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 +2083,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 +2101,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 +2122,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 +2149,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 +2231,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. @@ -2263,23 +2261,26 @@ Optionally use old comment from FILE as initial value." comment))) ;;;###autoload -(defun image-dired-mark-tagged-files () - "Use regexp to mark files with matching tag. +(defun image-dired-mark-tagged-files (regexp) + "Use REGEXP to mark files with matching tag. A `tag' is a keyword, a piece of meta data, associated with an image file and stored in image-dired's database file. This command lets you input a regexp and this will be matched against all tags on all image files in the database file. The files that have a matching tag will be marked in the Dired buffer." - (interactive) + (interactive "sMark tagged files (regexp): ") (image-dired-sane-db-file) - (let ((tag (read-string "Mark tagged files (regexp): ")) - (hits 0) + (let ((hits 0) files) (image-dired--with-db-file - ;; Collect matches - (while (search-forward-regexp - (concat "\\(^[^;\n]+\\);.*" tag ".*$") nil t) - (push (match-string 1) files))) + ;; Collect matches + (while (search-forward-regexp "\\(^[^;\n]+\\);\\(.*\\)" nil t) + (let ((file (match-string 1)) + (tags (split-string (match-string 2) ";"))) + (when (seq-find (lambda (tag) + (string-match-p regexp tag)) + tags) + (push file files))))) ;; Mark files (dolist (curr-file files) ;; I tried using `dired-mark-files-regexp' but it was waaaay to @@ -2296,6 +2297,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 +2308,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,26 +2323,41 @@ 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)) + -(defun image-dired-thumb-file-marked-p () - "Check if file is marked in associated Dired buffer." + +;;; Dired marks and tags + +(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." (interactive) (image-dired--with-marked (image-dired-delete-char) - (backward-char)) + (unless (bobp) + (backward-char))) (image-dired--line-up-with-method) (with-current-buffer (image-dired-associated-dired-buffer) (dired-do-delete))) @@ -2351,11 +2371,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 +2425,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 +2481,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 +2516,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 +2535,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 +2556,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 +2578,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 +2660,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 +2764,286 @@ 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)))) + +(put 'image-dired-bookmark-jump 'bookmark-handler-type "Image") + +;;; 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 +3075,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 73d32707e34..0ed88e8e749 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 1eb7cd58c3d..ea5d7ff0f35 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.") @@ -267,10 +282,17 @@ Stop if the top edge of the image is reached." (defun image-scroll-up (&optional n) "Scroll image in current window upward by N lines. Stop if the bottom edge of the image is reached. -If ARG is omitted or nil, scroll upward by a near full screen. + +Interactively, giving this command a numerical prefix will scroll +up by that many lines (and down by that many lines if the number +is negative). Without a prefix, scroll up by a full screen. +If given a `C-u -' prefix, scroll a full page down instead. + +If N is omitted or nil, scroll upward by a near full screen. A near full screen is `next-screen-context-lines' less than a full screen. -Negative ARG means scroll downward. -If ARG is the atom `-', scroll downward by nearly full screen. +A negative N means scroll downward. + +If N is the atom `-', scroll downward by nearly full screen. When calling from a program, supply as argument a number, nil, or `-'." (interactive "P") (cond ((null n) @@ -288,10 +310,17 @@ When calling from a program, supply as argument a number, nil, or `-'." (defun image-scroll-down (&optional n) "Scroll image in current window downward by N lines. Stop if the top edge of the image is reached. -If ARG is omitted or nil, scroll downward by a near full screen. + +Interactively, giving this command a numerical prefix will scroll +down by that many lines (and up by that many lines if the number +is negative). Without a prefix, scroll down by a full screen. +If given a `C-u -' prefix, scroll a full page up instead. + +If N is omitted or nil, scroll downward by a near full screen. A near full screen is `next-screen-context-lines' less than a full screen. -Negative ARG means scroll upward. -If ARG is the atom `-', scroll upward by nearly full screen. +A negative N means scroll upward. + +If N is the atom `-', scroll upward by nearly full screen. When calling from a program, supply as argument a number, nil, or `-'." (interactive "P") (cond ((null n) @@ -404,42 +433,43 @@ window configuration prior to the last `image-mode-fit-frame' call." (interactive (list nil t)) (let* ((buffer (current-buffer)) - (display (image-get-display-property)) - (size (image-display-size display)) (saved (frame-parameter frame 'image-mode-saved-params)) (window-configuration (current-window-configuration frame)) - (width (frame-width frame)) - (height (frame-height frame))) + (frame-width (frame-text-width frame)) + (frame-height (frame-text-height frame))) (with-selected-frame (or frame (selected-frame)) (if (and toggle saved - (= (caar saved) width) - (= (cdar saved) height)) + (= (caar saved) frame-width) + (= (cdar saved) frame-height)) (progn - (set-frame-width frame (car (nth 1 saved))) - (set-frame-height frame (cdr (nth 1 saved))) + (set-frame-width frame (car (nth 1 saved)) nil t) + (set-frame-height frame (cdr (nth 1 saved)) nil t) (set-window-configuration (nth 2 saved)) (set-frame-parameter frame 'image-mode-saved-params nil)) (delete-other-windows) (switch-to-buffer buffer t t) - (let* ((edges (window-inside-edges)) - (inner-width (- (nth 2 edges) (nth 0 edges))) - (inner-height (- (nth 3 edges) (nth 1 edges)))) - (set-frame-width frame (+ (ceiling (car size)) - width (- inner-width))) - (set-frame-height frame (+ (ceiling (cdr size)) - height (- inner-height))) - ;; The frame size after the above `set-frame-*' calls may - ;; differ from what we specified, due to window manager - ;; interference. We have to call `frame-width' and - ;; `frame-height' to get the actual results. - (set-frame-parameter frame 'image-mode-saved-params - (list (cons (frame-width) - (frame-height)) - (cons width height) - window-configuration))))))) + (fit-frame-to-buffer frame) + ;; The frame size after the above `set-frame-*' calls may + ;; differ from what we specified, due to window manager + ;; interference. We have to call `frame-width' and + ;; `frame-height' to get the actual results. + (set-frame-parameter frame 'image-mode-saved-params + (list (cons (frame-text-width frame) + (frame-text-height frame)) + (cons frame-width frame-height) + window-configuration)))))) ;;; 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 +485,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 +542,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 @@ -602,11 +631,14 @@ call." (put 'image-mode 'mode-class 'special) +(declare-function image-converter-initialize "image-converter.el") + ;;;###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}" @@ -626,7 +658,12 @@ Key bindings: "Empty file" "(New file)") "Empty buffer")) - (image-mode--display))) + (image-mode--display) + ;; Ensure that we recognize externally parsed image formats in + ;; commands like `n'. + (when image-use-external-converter + (require 'image-converter) + (image-converter-initialize)))) (defun image-mode--display () (if (not (image-get-display-property)) @@ -680,12 +717,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 @@ -703,10 +738,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 @@ -753,11 +791,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. @@ -773,11 +811,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. @@ -805,6 +842,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 @@ -839,7 +891,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)))) @@ -886,6 +939,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))) @@ -1149,8 +1210,9 @@ replacing the current Image mode buffer." "Return an alist of type/buffer for all \"parent\" buffers to image FILE. This is normally a list of Dired buffers, but can also be archive and tar mode buffers." - (let ((buffers nil) - (dir (file-name-directory file))) + (let* ((non-essential t) ; Do not block for remote buffers. + (buffers nil) + (dir (file-name-directory file))) (cond ((and (boundp 'tar-superior-buffer) tar-superior-buffer) @@ -1165,6 +1227,8 @@ tar mode buffers." (dolist (buffer (buffer-list)) (with-current-buffer buffer (when (and (derived-mode-p 'dired-mode) + (equal (file-remote-p dir) + (file-remote-p default-directory)) (equal (file-truename dir) (file-truename default-directory))) (push (cons 'dired (current-buffer)) buffers)))) @@ -1496,21 +1560,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 ea1a22698c6..1b684d5c57a 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]*<" @@ -55,7 +58,7 @@ static \\(unsigned \\)?char \\1_bits" . xbm) "\\(?:!DOCTYPE[ \t\r\n]+[^>]*>[ \t\r\n]*<[ \t\r\n]*" comment-re "*\\)?" "[Ss][Vv][Gg]")) . svg) - ) + ("\\`....ftyp\\(heic\\|heix\\|hevc\\|heim\\|heis\\|hevm\\|hevs\\|mif1\\|msf1\\)" . heic)) "Alist of (REGEXP . IMAGE-TYPE) pairs used to auto-detect image types. When the first bytes of an image file match REGEXP, it is assumed to be of image type IMAGE-TYPE if IMAGE-TYPE is a symbol. If not a symbol, @@ -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) @@ -74,7 +78,7 @@ a non-nil value, TYPE is the image's type.") ("\\.ps\\'" . postscript) ("\\.tiff?\\'" . tiff) ("\\.svgz?\\'" . svg) - ) + ("\\.hei[cf]s?\\'" . heic)) "Alist of (REGEXP . IMAGE-TYPE) pairs used to identify image files. When the name of an image file match REGEXP, it is assumed to be of image type IMAGE-TYPE.") @@ -92,7 +96,9 @@ be of image type IMAGE-TYPE.") (jpeg . maybe) (tiff . maybe) (svg . maybe) - (postscript . nil)) + (webp . maybe) + (postscript . nil) + (heic . maybe)) "Alist of (IMAGE-TYPE . AUTODETECT) pairs used to auto-detect image files. \(See `image-type-auto-detected-p'). @@ -165,18 +171,16 @@ or \"ffmpeg\") is installed." (define-error 'unknown-image-type "Unknown image type") -;; Map put into text properties on images. -(defvar image-map - (let ((map (make-sparse-keymap))) - (define-key map "-" 'image-decrease-size) - (define-key map "+" 'image-increase-size) - (define-key map [C-wheel-down] 'image-mouse-decrease-size) - (define-key map [C-mouse-5] 'image-mouse-decrease-size) - (define-key map [C-wheel-up] 'image-mouse-increase-size) - (define-key map [C-mouse-4] 'image-mouse-increase-size) - (define-key map "r" 'image-rotate) - (define-key map "o" 'image-save) - map)) +(defvar-keymap image-map + :doc "Map put into text properties on images." + "-" #'image-decrease-size + "+" #'image-increase-size + "r" #'image-rotate + "o" #'image-save + "C-<wheel-down>" #'image-mouse-decrease-size + "C-<mouse-5>" #'image-mouse-decrease-size + "C-<wheel-up>" #'image-mouse-increase-size + "C-<mouse-4>" #'image-mouse-increase-size) (defun image-load-path-for-library (library image &optional path no-error) "Return a suitable search path for images used by LIBRARY. @@ -376,6 +380,7 @@ be determined." "Determine the type of image file FILE from its name. Value is a symbol specifying the image type, or nil if type cannot be determined." + (declare (obsolete image-supported-file-p "29.1")) (let (type first (case-fold-search t)) (catch 'found (dolist (elem image-type-file-name-regexps first) @@ -385,6 +390,20 @@ be determined." ;; If nothing seems to be supported, return first type that matched. (or first (setq first type)))))))) + ;;;###autoload +(defun image-supported-file-p (file) + "Say whether Emacs has native support for displaying TYPE. +The value is a symbol specifying the image type, or nil if type +cannot be determined (or if Emacs doesn't have built-in support +for the image type)." + (let ((case-fold-search t) + type) + (catch 'found + (dolist (elem image-type-file-name-regexps) + (when (and (string-match-p (car elem) file) + (image-type-available-p (setq type (cdr elem)))) + (throw 'found type)))))) + (declare-function image-convert-p "image-converter.el" (source &optional image-format)) (declare-function image-convert "image-converter.el" @@ -413,7 +432,7 @@ type if we can't otherwise guess it." (require 'image-converter) (image-convert-p source data-p)))) (or (image-type-from-file-header source) - (image-type-from-file-name source) + (image-supported-file-p source) (and image-use-external-converter (progn (require 'image-converter) @@ -457,6 +476,7 @@ must be available." (and auto (or (eq auto t) (image-type-available-p type))))) +(defvar image-convert-to-format) ;;;###autoload (defun create-image (file-or-data &optional type data-p &rest props) @@ -494,7 +514,7 @@ Image file names that are not absolute are searched for in the (when (eq type 'image-convert) (require 'image-converter) (setq file-or-data (image-convert file-or-data data-format) - type 'png + type (intern image-convert-to-format) data-p t))) (when (image-type-available-p type) (let ((image @@ -556,7 +576,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 +625,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 +642,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 +670,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 +821,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 +853,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 +872,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) @@ -913,40 +949,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) @@ -1138,6 +1188,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 23f11bd87cc..fd4673dc1b6 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 @@ -95,7 +100,10 @@ mirrored or not.") "Parse FILE (a JPEG file) and return the Exif data, if any. The return value is a list of Exif items. -If the data is invalid, an `exif-error' is signaled." +If the data is invalid, an `exif-error' is signaled. + +Also see the `exif-field' convenience function to extract data +from the return value of this function." (with-temp-buffer (set-buffer-multibyte nil) (insert-file-contents-literally file) @@ -105,7 +113,10 @@ If the data is invalid, an `exif-error' is signaled." "Parse BUFFER (which should be a JPEG file) and return the Exif data, if any. The return value is a list of Exif items. -If the data is invalid, an `exif-error' is signaled." +If the data is invalid, an `exif-error' is signaled. + +Also see the `exif-field' convenience function to extract data +from the return value of this function." (setq buffer (or buffer (current-buffer))) (with-current-buffer buffer (if enable-multibyte-characters @@ -122,13 +133,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 8ef8bd8eeed..78a2df72c4c 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/image/image-converter.el b/lisp/image/image-converter.el index 460ff16adb0..9440c623f90 100644 --- a/lisp/image/image-converter.el +++ b/lisp/image/image-converter.el @@ -46,6 +46,16 @@ formats that are to be supported: Only the suffixes that map to :type 'symbol :version "27.1") +(defcustom image-convert-to-format "png" + "The image format to convert to. +This should be a string like \"png\" or \"ppm\" or some +other (preferably lossless) format that Emacs understands +natively. The converter chosen has to support the format, and if +not, conversion will fail." + :group 'image + :version "29.1" + :type 'string) + (defvar image-converter-regexp nil "A regexp that matches the file name suffixes that can be converted.") @@ -58,15 +68,19 @@ formats that are to be supported: Only the suffixes that map to (imagemagick :command "convert" :probe ("-list" "format"))) "List of supported image converters to try.") +(defun image-converter-initialize () + "Determine the external image converter to be used. +This also determines which external formats we can parse." + (unless image-converter + (image-converter--find-converter))) + (defun image-convert-p (source &optional data-p) "Return `image-convert' if SOURCE is an image that can be converted. SOURCE can either be a file name or a string containing image data. In the latter case, DATA-P should be non-nil. If DATA-P is a string, it should be a MIME format string like \"image/gif\"." - ;; Find an installed image converter. - (unless image-converter - (image-converter--find-converter)) + (image-converter-initialize) ;; When image-converter was customized (when (and image-converter (not image-converter-regexp)) (when-let ((formats (image-converter--probe image-converter))) @@ -85,22 +99,23 @@ is a string, it should be a MIME format string like 'image-convert)) (defun image-convert (image &optional image-format) - "Convert IMAGE file to the PNG format. + "Convert IMAGE file to an image format Emacs understands. +This will usually be \"png\", but this is controlled by the +`image-convert-to-format' user option. + IMAGE can either be a file name or image data. To pass in image data, IMAGE should a string containing the image data, and IMAGE-FORMAT should be a symbol with a MIME format name like \"image/webp\". For instance: - (image-convert data-string 'image/bmp) + (image-convert data-string \\='image/bmp) IMAGE can also be an image object as returned by `create-image'. -This function converts the image to PNG, and the converted image -data is returned as a string." - ;; Find an installed image converter. - (unless image-converter - (image-converter--find-converter)) +This function converts the image the preferred format, and the +converted image data is returned as a string." + (image-converter-initialize) (unless image-converter (error "No external image converters available")) (when (and image-format @@ -120,7 +135,9 @@ data is returned as a string." (if (listp image) ;; Return an image object that's the same as we were passed, ;; but ignore the :type value. - (apply #'create-image (buffer-string) 'png t + (apply #'create-image (buffer-string) + (intern image-convert-to-format) + t (cl-loop for (key val) on (cdr image) by #'cddr unless (eq key :type) append (list key val))) @@ -239,12 +256,15 @@ Only suffixes that map to `image-mode' are returned." (list (format "%s:-" (image-converter--mime-type image-format)) - "png:-")))) + (concat image-convert-to-format + ":-"))))) ;; SOURCE is a file name. (apply #'call-process (car command) nil t nil (append (cdr command) - (list (expand-file-name source) "png:-"))))) + (list (expand-file-name source) + (concat image-convert-to-format + ":-")))))) ;; If the command failed, hopefully the buffer contains the ;; error message. (buffer-string)))) @@ -262,14 +282,15 @@ Only suffixes that map to `image-mode' are returned." (append (cdr command) (list "-i" "-" - "-c:v" "png" + "-c:v" image-convert-to-format "-f" "image2pipe" "-")))) (apply #'call-process (car command) nil '(t nil) nil (append (cdr command) (list "-i" (expand-file-name source) - "-c:v" "png" "-f" "image2pipe" + "-c:v" image-convert-to-format + "-f" "image2pipe" "-"))))) "ffmpeg error when converting"))) diff --git a/lisp/imenu.el b/lisp/imenu.el index a87860f0065..2636e77d08e 100644 --- a/lisp/imenu.el +++ b/lisp/imenu.el @@ -899,6 +899,13 @@ for more information." (`(,name . ,pos) (imenu (list name pos imenu-default-goto-function))) (_ (error "Unknown imenu item: %S" index-item))))) +(defun imenu-flush-cache () + "Flush the current imenu cache. +This forces a full rescan of the buffer to recreate the index alist +next time `imenu' is invoked." + (imenu--cleanup) + (setq imenu--index-alist nil)) + (provide 'imenu) ;;; imenu.el ends here diff --git a/lisp/indent.el b/lisp/indent.el index 071f46fd42a..d6dee94016d 100644 --- a/lisp/indent.el +++ b/lisp/indent.el @@ -89,16 +89,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 @@ -167,7 +171,7 @@ prefix argument is ignored." (let ((old-tick (buffer-chars-modified-tick)) (old-point (point)) (old-indent (current-indentation)) - (syn `(,(syntax-after (point))))) + (syn (syntax-after (point)))) ;; Indent the line. (or (not (eq (indent--funcall-widened indent-line-function) 'noindent)) @@ -179,21 +183,21 @@ prefix argument is ignored." (cond ;; If the text was already indented right, try completion. ((and (eq tab-always-indent 'complete) - (eq old-point (point)) - (eq old-tick (buffer-chars-modified-tick)) + (eql old-point (point)) + (eql old-tick (buffer-chars-modified-tick)) (or (null tab-first-completion) (eq last-command this-command) - (and (equal tab-first-completion 'eol) + (and (eq tab-first-completion 'eol) (eolp)) - (and (member tab-first-completion - '(word word-or-paren word-or-paren-or-punct)) - (not (member 2 syn))) - (and (member tab-first-completion - '(word-or-paren word-or-paren-or-punct)) - (not (or (member 4 syn) - (member 5 syn)))) - (and (equal tab-first-completion 'word-or-paren-or-punct) - (not (member 1 syn))))) + (and (memq tab-first-completion + '(word word-or-paren word-or-paren-or-punct)) + (not (eql 2 syn))) + (and (memq tab-first-completion + '(word-or-paren word-or-paren-or-punct)) + (not (or (eql 4 syn) + (eql 5 syn)))) + (and (eq tab-first-completion 'word-or-paren-or-punct) + (not (eql 1 syn))))) (completion-at-point)) ;; If a prefix argument was given, rigidly indent the following @@ -236,21 +240,23 @@ Blank lines are ignored." (current-indentation)))) indent)))) -(defvar indent-rigidly-map - (let ((map (make-sparse-keymap))) - (define-key map [left] 'indent-rigidly-left) - (define-key map [right] 'indent-rigidly-right) - (define-key map [S-left] 'indent-rigidly-left-to-tab-stop) - (define-key map [S-right] 'indent-rigidly-right-to-tab-stop) - map) - "Transient keymap for adjusting indentation interactively. -It is activated by calling `indent-rigidly' interactively.") +(defvar-keymap indent-rigidly-map + :doc "Transient keymap for adjusting indentation interactively. +It is activated by calling `indent-rigidly' interactively." + "TAB" #'indent-rigidly-right + "<left>" #'indent-rigidly-left + "<right>" #'indent-rigidly-right + "S-<left>" #'indent-rigidly-left-to-tab-stop + "S-<right>" #'indent-rigidly-right-to-tab-stop) +(put 'indent-rigidly-right :advertised-binding (kbd "<right>")) (defun indent-rigidly (start end arg &optional interactive) "Indent all lines starting in the region. If called interactively with no prefix argument, activate a transient mode in which the indentation can be adjusted interactively by typing \\<indent-rigidly-map>\\[indent-rigidly-left], \\[indent-rigidly-right], \\[indent-rigidly-left-to-tab-stop], or \\[indent-rigidly-right-to-tab-stop]. +In addition, \\`TAB' is also bound (and calls `indent-rigidly-right'). + Typing any other key exits this mode, and this key is then acted upon as normally. If `transient-mark-mode' is enabled, exiting also deactivates the mark. @@ -602,7 +608,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. @@ -616,7 +625,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 6742c2806b5..6c8ef091a08 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." @@ -93,7 +94,10 @@ HELP-DATA is a HELP-TOPIC's public data set. (HELP-MODE REGEXP IGNORE-CASE DOC-SPEC PARSE-RULE OTHER-MODES) -HELP-MODE is a mode's symbol. +HELP-MODE is either a mode's symbol, or a cons cell of the +form (HELP-MODE . SYMBOL-PREFIX), where SYMBOL-PREFIX is the +prefix (the part up to the first dash) of names of symbols whose +documentation is specified by DOC-SPEC. REGEXP is a regular expression matching those help items whose documentation can be looked up via DOC-SPEC. IGNORE-CASE is non-nil if help items are case insensitive. @@ -123,6 +127,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,9 +157,15 @@ 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'. -ARGUMENT has a value as explained in the documentation of the - variable `info-lookup-alist'. + `: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 is the value corresponding to KEYWORD. The meaning of the values +is explained in the documentation of the variable `info-lookup-alist': for +example, the value corresponding to `:topic' is documented as HELP-TOPIC, +the value of `:mode' as HELP-MODE, etc.. If no topic or mode option has been specified, then the help topic defaults to `symbol', and the help mode defaults to the current major mode." @@ -161,7 +179,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 +203,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 +212,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) @@ -258,36 +280,52 @@ system." ;;;###autoload (put 'info-lookup-symbol 'info-file "emacs") ;;;###autoload -(defun info-lookup-symbol (symbol &optional mode) - "Display the definition of SYMBOL, as found in the relevant manual. -When this command is called interactively, it reads SYMBOL from the -minibuffer. In the minibuffer, use \\<minibuffer-local-completion-map>\ -\\[next-history-element] to yank the default argument -value into the minibuffer so you can edit it. The default symbol is the -one found at point. - -With prefix arg MODE a query for the symbol help mode is offered." +(defun info-lookup-symbol (symbol &optional mode same-window) + "Look up and display documentation of SYMBOL in the relevant Info manual. +SYMBOL should be an identifier: a function or method, a macro, a variable, +a data type, a class, etc. + +Interactively, prompt for SYMBOL; you can use \\<minibuffer-local-completion-map>\\[next-history-element] in the minibuffer +to yank the default argument value into the minibuffer so you can edit it. +The default symbol is the one found at point. + +MODE is the major mode whose Info manuals to search for the documentation +of SYMBOL. It defaults to the current buffer's `major-mode'; if that +mode doesn't have any Info manuals known to Emacs, the command will +prompt for MODE to use, with completion. With prefix arg, the command +always prompts for MODE. + +Is SAME-WINDOW, try to reuse the current window instead of +popping up a new one." (interactive (info-lookup-interactive-arguments 'symbol current-prefix-arg)) - (info-lookup 'symbol symbol mode)) + (info-lookup 'symbol symbol mode same-window)) ;;;###autoload (put 'info-lookup-file 'info-file "emacs") ;;;###autoload (defun info-lookup-file (file &optional mode) - "Display the documentation of a file. -When this command is called interactively, it reads FILE from the minibuffer. -In the minibuffer, use \\<minibuffer-local-completion-map>\ -\\[next-history-element] to yank the default file name -into the minibuffer so you can edit it. + "Look up and display documentation of FILE in the relevant Info manual. +FILE should be the name of a file; a notable example is a standard header +file that is part of the C or C++ standard library. + +Interactively, prompt for FILE; you can use \\<minibuffer-local-completion-map>\\[next-history-element] in the minibuffer +to yank the default argument value into the minibuffer so you can edit it. The default file name is the one found at point. -With prefix arg MODE a query for the file help mode is offered." +MODE is the major mode whose Info manuals to search for the documentation +of FILE. It defaults to the current buffer's `major-mode'; if that +mode doesn't have any Info manuals known to Emacs, the command will +prompt for MODE to use, with completion. With prefix arg, the command +always prompts for MODE." (interactive (info-lookup-interactive-arguments 'file current-prefix-arg)) (info-lookup 'file file mode)) (defun info-lookup-interactive-arguments (topic &optional query) - "Read and return argument value (and help mode) for help topic TOPIC. + "Read and return argument value (and help mode) for help TOPIC. +TOPIC should be any known symbol of a help topic, such as `file' +or `symbol'. See the documentation of HELP-TOPIC in the doc +string of `info-lookup-alist'. If optional argument QUERY is non-nil, query for the help mode." (let* ((mode (cond (query (info-lookup-change-mode topic)) @@ -330,7 +368,10 @@ If optional argument QUERY is non-nil, query for the help mode." (defun info-lookup-change-mode (topic) (let* ((completions (mapcar (lambda (arg) - (cons (symbol-name (car arg)) (car arg))) + (let ((mode-spec (car arg))) + (and (consp mode-spec) + (setq mode-spec (car mode-spec))) + (cons (symbol-name mode-spec) mode-spec))) (info-lookup->topic-value topic))) (mode (completing-read (format "Use %s help mode: " topic) @@ -341,11 +382,33 @@ 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 (topic item mode) - "Display the documentation of a help item." +(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 &optional same-window) + "Display the documentation of TOPIC whose name is ITEM, using MODE's manuals. +TOPIC should be any known symbol of a help topic type, such as `file' +or `symbol'. See the documentation of HELP-TOPIC in the doc +string of `info-lookup-alist'. +ITEM is the item whose documentation to search: file name if +TOPIC is `file', a symbol if TOPIC is `symbol', etc. +MODE is the `major-mode' whose Info manuals to search for documentation +of ITEM; if it's nil, the function uses `info-lookup-file-name-alist' +and the current buffer's file name to guess the mode. + +If SAME-WINDOW, reuse the current window. If nil, pop to a +different window." (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) @@ -366,19 +429,21 @@ If optional argument QUERY is non-nil, query for the help mode." (if (not info-lookup-other-window-flag) (info) (save-window-excursion (info)) - (let* ((info-window (get-buffer-window "*info*" t)) - (info-frame (and info-window (window-frame info-window)))) - (if (and info-frame - (not (eq info-frame (selected-frame))) - (display-multi-frame-p) - (memq info-frame (frames-on-display-list))) - ;; *info* is visible in another frame on same display. - ;; Raise that frame and select the window. - (progn - (select-window info-window) - (raise-frame info-frame)) - ;; In any other case, switch to *info* in another window. - (switch-to-buffer-other-window "*info*"))))) + (if same-window + (pop-to-buffer-same-window "*info*") + (let* ((info-window (get-buffer-window "*info*" t)) + (info-frame (and info-window (window-frame info-window)))) + (if (and info-frame + (not (eq info-frame (selected-frame))) + (display-multi-frame-p) + (memq info-frame (frames-on-display-list))) + ;; *info* is visible in another frame on same display. + ;; Raise that frame and select the window. + (progn + (select-window info-window) + (raise-frame info-frame)) + ;; In any other case, switch to *info* another window. + (switch-to-buffer-other-window "*info*")))))) (while (and (not found) modes) (setq doc-spec (info-lookup->doc-spec topic (car modes))) (while (and (not found) doc-spec) @@ -724,6 +789,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 +971,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 +1018,75 @@ Return nil if there is nothing appropriate in the buffer near point." ("(cl)Function Index" nil "^ -+ .*: " "\\( \\|$\\)") ("(cl)Variable Index" nil "^ -+ .*: " "\\( \\|$\\)"))) +(info-lookup-maybe-add-help + :mode 'emacs-lisp-only + :regexp "[^][()`'‘’,\" \t\n]+" + :doc-spec '(("(elisp)Index" nil "^ -+ .*: " "\\( \\|$\\)") + ("(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") + ("vtable" "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 739116cceac..f9d63b0f32d 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)) @@ -159,59 +161,8 @@ A header-line does not scroll with the rest of the buffer." "Face used to highlight matches in an index entry." :version "24.4") -;; This is a defcustom largely so that we can get the benefit -;; of `custom-initialize-delay'. Perhaps it would work to make it a -;; `defvar' and explicitly give it a `standard-value' property, and -;; call `custom-initialize-delay' on it. -;; The value is initialized at startup time, when command-line calls -;; `custom-reevaluate-setting' on all the defcustoms in -;; `custom-delayed-init-variables'. This is somewhat sub-optimal, as ideally -;; this should be done when Info mode is first invoked. ;;;###autoload -(defcustom Info-default-directory-list - (let* ((config-dir - (file-name-as-directory - ;; Self-contained NS build with info/ in the app-bundle. - (or (and (featurep 'ns) - (let ((dir (expand-file-name "../info" data-directory))) - (if (file-directory-p dir) dir))) - configure-info-directory))) - (prefixes - ;; Directory trees in which to look for info subdirectories - (prune-directory-list '("/usr/local/" "/usr/" "/opt/"))) - (suffixes - ;; Subdirectories in each directory tree that may contain info - ;; directories. - '("share/" "")) - (standard-info-dirs - (apply #'nconc - (mapcar (lambda (pfx) - (let ((dirs - (mapcar (lambda (sfx) - (concat pfx sfx "info/")) - suffixes))) - (prune-directory-list dirs))) - prefixes))) - ;; If $(prefix)/share/info is not one of the standard info - ;; directories, they are probably installing an experimental - ;; version of Emacs, so make sure that experimental version's Info - ;; files override the ones in standard directories. - (dirs - (if (member config-dir standard-info-dirs) - ;; FIXME? What is the point of adding it again at the end - ;; when it is already present earlier in the list? - (nconc standard-info-dirs (list config-dir)) - (cons config-dir standard-info-dirs)))) - (if (not (eq system-type 'windows-nt)) - dirs - ;; Include the info directory near where Emacs executable was installed. - (let* ((instdir (file-name-directory invocation-directory)) - (dir1 (expand-file-name "../info/" instdir)) - (dir2 (expand-file-name "../../../info/" instdir))) - (cond ((file-exists-p dir1) (append dirs (list dir1))) - ((file-exists-p dir2) (append dirs (list dir2))) - (t dirs))))) - +(defcustom Info-default-directory-list nil "Default list of directories to search for Info documentation files. They are searched in the order they are given in the list. Therefore, the directory of Info files that come with Emacs @@ -222,15 +173,12 @@ first in this list. Once Info is started, the list of directories to search comes from the variable `Info-directory-list'. -This variable `Info-default-directory-list' is used as the default -for initializing `Info-directory-list' when Info is started, unless -the environment variable INFOPATH is set. - -Although this is a customizable variable, that is mainly for technical -reasons. Normally, you should either set INFOPATH or customize -`Info-additional-directory-list', rather than changing this variable." - :initialize #'custom-initialize-delay - :type '(repeat directory)) + +This variable is used as the default for initializing +`Info-directory-list' when Info is started, unless the +environment variable INFOPATH is set." + :type '(repeat directory) + :version "29.1") (defvar Info-directory-list nil "List of directories to search for Info documentation files. @@ -677,6 +625,51 @@ in `Info-file-supports-index-cookies-list'." (cdr (assoc file Info-file-supports-index-cookies-list))) +(defun Info--default-directory-list () + "Compute a directory list suitable for Info." + (let* ((config-dir + (file-name-as-directory + ;; Self-contained NS build with info/ in the app-bundle. + (or (and (featurep 'ns) + (let ((dir (expand-file-name "../info" data-directory))) + (if (file-directory-p dir) dir))) + configure-info-directory))) + (prefixes + ;; Directory trees in which to look for info subdirectories + (prune-directory-list '("/usr/local/" "/usr/" "/opt/"))) + (suffixes + ;; Subdirectories in each directory tree that may contain info + ;; directories. + '("share/" "")) + (standard-info-dirs + (apply #'nconc + (mapcar (lambda (pfx) + (let ((dirs + (mapcar (lambda (sfx) + (concat pfx sfx "info/")) + suffixes))) + (prune-directory-list dirs))) + prefixes))) + ;; If $(prefix)/share/info is not one of the standard info + ;; directories, they are probably installing an experimental + ;; version of Emacs, so make sure that experimental version's Info + ;; files override the ones in standard directories. + (dirs + (if (member config-dir standard-info-dirs) + ;; FIXME? What is the point of adding it again at the end + ;; when it is already present earlier in the list? + (nconc standard-info-dirs (list config-dir)) + (cons config-dir standard-info-dirs)))) + (if (not (eq system-type 'windows-nt)) + dirs + ;; Include the info directory near where Emacs executable was installed. + (let* ((instdir (file-name-directory invocation-directory)) + (dir1 (expand-file-name "../info/" instdir)) + (dir2 (expand-file-name "../../../info/" instdir))) + (cond ((file-exists-p dir1) (append dirs (list dir1))) + ((file-exists-p dir2) (append dirs (list dir2))) + (t dirs)))))) + (defun Info-default-dirs () (let ((source (expand-file-name "info/" source-directory)) (sibling (if installation-directory @@ -699,25 +692,11 @@ in `Info-file-supports-index-cookies-list'." sibling ;; Uninstalled, builddir == srcdir source)) - (if (or (member alternative Info-default-directory-list) - ;; On DOS/NT, we use movable executables always, - ;; and we must always find the Info dir at run time. - (if (memq system-type '(ms-dos windows-nt)) - nil - ;; Use invocation-directory for Info - ;; only if we used it for exec-directory also. - (not (string= exec-directory - (expand-file-name "lib-src/" - installation-directory)))) - (not (file-exists-p alternative))) - Info-default-directory-list - ;; `alternative' contains the Info files that came with this - ;; version, so we should look there first. `Info-insert-dir' - ;; currently expects to find `alternative' first on the list. - (cons alternative - ;; Don't drop the last part, it might contain non-Emacs stuff. - ;; (reverse (cdr (reverse - Info-default-directory-list)))) ;; ))) + ;; `alternative' contains the Info files that came with this + ;; version, so we should look there first. `Info-insert-dir' + ;; currently expects to find `alternative' first on the list. + (append (cons alternative Info-default-directory-list) + (Info--default-directory-list)))) (defun info-initialize () "Initialize `Info-directory-list', if that hasn't been done yet." @@ -928,17 +907,20 @@ find a node." filename))) filename)))) -(defun Info-find-node (filename nodename &optional no-going-back strict-case) +(defun Info-find-node (filename nodename &optional no-going-back strict-case + noerror) "Go to an Info node specified as separate FILENAME and NODENAME. NO-GOING-BACK is non-nil if recovering from an error in this function; it says do not attempt further (recursive) error recovery. This function first looks for a case-sensitive match for NODENAME; if none is found it then tries a case-insensitive match (unless -STRICT-CASE is non-nil)." +STRICT-CASE is non-nil). + +If NOERROR, inhibit error messages when we can't find the node." (info-initialize) (setq nodename (info--node-canonicalize-whitespace nodename)) - (setq filename (Info-find-file filename)) + (setq filename (Info-find-file filename noerror)) ;; Go into Info buffer. (or (derived-mode-p 'Info-mode) (switch-to-buffer "*info*")) ;; Record the node we are leaving, if we were in one. @@ -1792,7 +1774,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) @@ -1804,41 +1825,22 @@ directories to search if FILENAME is not absolute; SUFFIXES is a list of valid filename suffixes for Info files. See `try-completion' for a description of the remaining arguments." (setq suffixes (remove "" suffixes)) - (when (file-name-absolute-p string) - (setq dirs (list (file-name-directory string)))) (let ((names nil) - (names-sans-suffix nil) - (suffix (concat (regexp-opt suffixes t) "\\'")) - (string-dir (file-name-directory string))) + (suffix (concat (regexp-opt suffixes t) "\\'"))) (dolist (dir dirs) - (unless dir - (setq dir default-directory)) - (if string-dir (setq dir (expand-file-name string-dir dir))) (when (file-directory-p dir) - (dolist (file (file-name-all-completions - (file-name-nondirectory string) dir)) - ;; If the file name has no suffix or a standard suffix, - ;; include it. - (and (or (null (file-name-extension file)) - (string-match suffix file)) - ;; But exclude subfiles of split Info files. - (not (string-match "-[0-9]+\\'" file)) - ;; And exclude backup files. - (not (string-match "~\\'" file)) - (push (if string-dir (concat string-dir file) file) names)) - ;; If the file name ends in a standard suffix, - ;; add the unsuffixed name as a completion option. - (when (string-match suffix file) - (setq file (substring file 0 (match-beginning 0))) - (push (if string-dir (concat string-dir file) file) - names-sans-suffix))))) - ;; If there is just one file, don't duplicate it with suffixes, - ;; so `Info-read-node-name-1' will be able to complete a single - ;; candidate and to add the terminating ")". - (if (and (= (length names) 1) (= (length names-sans-suffix) 1)) - (setq names names-sans-suffix) - (setq names (append names-sans-suffix names))) - (complete-with-action action names string pred))) + (dolist (file (directory-files dir)) + ;; If the file name has a standard suffix, + ;; include it (without the suffix). + (when (and (string-match suffix file) + ;; But exclude subfiles of split Info files. + (not (string-match "\\.info-[0-9]+" file)) + ;; And exclude backup files. + (not (string-match "~\\'" file))) + (push (substring file 0 (match-beginning 0)) + names))))) + (complete-with-action action (delete-dups (nreverse names)) + string pred))) (defun Info-read-node-name-1 (string predicate code) "Internal function used by `Info-read-node-name'. @@ -1877,7 +1879,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 +1887,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))) @@ -2596,7 +2599,8 @@ new buffer." (if (eq alt-default t) (setq alt-default str)) ;; Don't add this string if it's a duplicate. (or (assoc-string str completions t) - (push str completions)))) + (push str completions))) + (setq completions (nreverse completions))) ;; If no good default was found, try an alternate. (or default (setq default alt-default)) @@ -2604,12 +2608,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)) @@ -3616,13 +3617,16 @@ MATCHES is a list of index matches found by `Info-apropos-matches'.") (format " (line %s)" (nth 3 entry)) ""))))))))) -(defun Info-apropos-matches (string) +(defun Info-apropos-matches (string &optional regexp) "Collect STRING matches from all known Info files on your system. +If REGEXP, use regexp matching instead of literal matching. Return a list of matches where each element is in the format \((FILENAME INDEXTEXT NODENAME LINENUMBER))." (unless (string= string "") (let ((pattern (format "\n\\* +\\([^\n]*\\(%s\\)[^\n]*\\):[ \t]+\\([^\n]+\\)\\.\\(?:[ \t\n]*(line +\\([0-9]+\\))\\)?" - (regexp-quote string))) + (if regexp + string + (regexp-quote string)))) (ohist Info-history) (ohist-list Info-history-list) (current-node Info-current-node) @@ -3647,9 +3651,9 @@ Return a list of matches where each element is in the format (dolist (manual (nreverse manuals)) (message "Searching %s" manual) (condition-case err - (if (setq nodes (Info-index-nodes (Info-find-file manual))) + (if (setq nodes (Info-index-nodes (Info-find-file manual t))) (save-excursion - (Info-find-node manual (car nodes)) + (Info-find-node manual (car nodes) nil nil t) (while (progn (goto-char (point-min)) @@ -3676,19 +3680,22 @@ Return a list of matches where each element is in the format (or (nreverse matches) t)))) ;;;###autoload -(defun info-apropos (string) - "Grovel indices of all known Info files on your system for STRING. -Build a menu of the possible matches." - (interactive "sIndex apropos: ") +(defun info-apropos (string &optional regexp) + "Search indices of all known Info files on your system for STRING. +If REGEXP (interactively, the prefix), use a regexp match. + +Display a menu of the possible matches." + (interactive "sIndex apropos: \nP") (if (equal string "") (Info-find-node Info-apropos-file "Top") - (let* ((nodes Info-apropos-nodes) nodename) + (let ((nodes Info-apropos-nodes) + nodename) (while (and nodes (not (equal string (nth 1 (car nodes))))) (setq nodes (cdr nodes))) (if nodes - (Info-find-node Info-apropos-file (car (car nodes))) + (Info-find-node Info-apropos-file (car (car nodes)) nil nil t) (setq nodename (format "Index for ‘%s’" string)) - (push (list nodename string (Info-apropos-matches string)) + (push (list nodename string (Info-apropos-matches string regexp)) Info-apropos-nodes) (Info-find-node Info-apropos-file nodename))))) @@ -4049,6 +4056,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. @@ -4228,7 +4236,7 @@ If FORK is non-nil, it is passed to `Info-goto-node'." (Info-history-menu e "Back in history" Info-history 'Info-history-back)) (defun Info-history-forward-menu (e) - "Pop up the menu with a list of Info nodes visited with ‘Info-history-back’." + "Pop up the menu with a list of Info nodes visited with `Info-history-back'." (interactive "e" Info-mode) (Info-history-menu e "Forward in history" Info-history-forward 'Info-history-forward)) @@ -4278,7 +4286,8 @@ If FORK is non-nil, it is passed to `Info-goto-node'." (substring str (match-end 0)))) (setq i (1+ i))) (setq items - (cons str items)))) + (cons str items))) + (setq items (nreverse items))) (while (and items (< number 9)) (setq current (car items) items (cdr items) @@ -4481,7 +4490,9 @@ Advanced commands: (setq-local revert-buffer-function #'Info-revert-buffer-function) (setq-local font-lock-defaults '(Info-mode-font-lock-keywords t t)) (Info-set-mode-line) - (setq-local bookmark-make-record-function #'Info-bookmark-make-record)) + (setq-local bookmark-make-record-function #'Info-bookmark-make-record) + (unless search-default-mode + (isearch-fold-quotes-mode))) ;; When an Info buffer is killed, make sure the associated tags buffer ;; is killed too. @@ -4653,7 +4664,7 @@ the variable `Info-file-list-for-emacs'." (defvar Info-link-keymap (let ((keymap (make-sparse-keymap))) (define-key keymap [header-line down-mouse-1] 'mouse-drag-header-line) - (define-key keymap [header-line mouse-1] 'mouse-select-window) + (define-key keymap [header-line mouse-1] 'Info-mouse-follow-link) (define-key keymap [header-line mouse-2] 'Info-mouse-follow-link) (define-key keymap [mouse-2] 'Info-mouse-follow-link) (define-key keymap [follow-link] 'mouse-face) @@ -4858,9 +4869,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))) "") @@ -5402,6 +5420,7 @@ type returned by `Info-bookmark-make-record', which see." (bookmark-default-handler `("" (buffer . ,buf) . ,(bookmark-get-bookmark-record bmk))))) +(put 'Info-bookmark-jump 'bookmark-handler-type "Info") ;;;###autoload (defun info-display-manual (manual) @@ -5415,7 +5434,8 @@ completion alternatives to currently visited manuals." (progn (info-initialize) (completing-read "Manual name: " - (info--manual-names current-prefix-arg) + (info--filter-manual-names + (info--manual-names current-prefix-arg)) nil t)))) (let ((blist (buffer-list)) (manual-re (concat "\\(/\\|\\`\\)" manual "\\(\\.\\|\\'\\)")) @@ -5443,6 +5463,22 @@ completion alternatives to currently visited manuals." (info (Info-find-file manual) (generate-new-buffer-name "*info*"))))) +(defun info--filter-manual-names (names) + (cl-flet ((strip (name) + (replace-regexp-in-string "\\([-.]info\\)?\\(\\.gz\\)?\\'" + "" name))) + (seq-uniq (sort (seq-filter + (lambda (name) + (and (not (string-match-p "info-[0-9]" name)) + (not (member name '("./" "../" "ChangeLog" + "NEWS" "README"))))) + names) + ;; We prefer the shorter names ("foo" over "foo.gz"). + (lambda (s1 s2) + (< (length s1) (length s2)))) + (lambda (s1 s2) + (equal (strip s1) (strip s2)))))) + (defun info--manual-names (visited-only) (let (names) (dolist (buffer (buffer-list)) diff --git a/lisp/international/ccl.el b/lisp/international/ccl.el index e23e059543d..c7d883276db 100644 --- a/lisp/international/ccl.el +++ b/lisp/international/ccl.el @@ -577,7 +577,7 @@ Return register which holds a value of the expression." (ccl-check-register expr cmd))) (defun ccl-compile-branch-blocks (code rrr blocks) - "Compile BLOCKs of BRANCH statement. CODE is 'branch or 'read-branch. + "Compile BLOCKs of BRANCH statement. CODE is `branch' or `read-branch'. REG is a register which holds a value of EXPRESSION part. BLOCKs is a list of CCL-BLOCKs." (let ((branches (length blocks)) @@ -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 7d625d1382a..ca28222c815 100644 --- a/lisp/international/characters.el +++ b/lisp/international/characters.el @@ -303,7 +303,8 @@ with L, LRE, or LRO Unicode bidi character type.") (setq charsets (cdr charsets)))) (modify-category-entry '(#x600 . #x6ff) ?b) (modify-category-entry '(#x870 . #x8ff) ?b) -(modify-category-entry '(#xfb50 . #xfdff) ?b) +(modify-category-entry '(#xfb50 . #xfdcf) ?b) +(modify-category-entry '(#xfdf0 . #xfdff) ?b) (modify-category-entry '(#xfe70 . #xfefe) ?b) ;; Cyrillic character set (ISO-8859-5) @@ -1440,6 +1441,10 @@ Setup `char-width-table' appropriate for non-CJK language environment." (set-char-table-range char-script-table range 'tibetan)) 'tibetan) +;; Fix some exceptions that blocks.awk/Blocks.txt couldn't get right. +(set-char-table-range char-script-table '(#x2ea . #x2eb) 'bopomofo) +(set-char-table-range char-script-table #xab65 'greek) + ;;; Setting unicode-category-table. @@ -1493,6 +1498,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 +1525,42 @@ 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 bidi-control-characters + '(#x200e ; ?\N{left-to-right mark} + #x200f ; ?\N{right-to-left mark} + #x061c ; ?\N{arabic letter mark} + #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} + "List of bidirectional control characters.") + +(defun bidi-string-strip-control-characters (string) + "Strip bidi control characters from STRING and return the result." + (apply #'string (seq-filter (lambda (char) + (not (memq char bidi-control-characters))) + string))) + (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 +1575,28 @@ 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 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 +1612,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 +1643,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 +1671,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..df488708afa --- /dev/null +++ b/lisp/international/emoji.el @@ -0,0 +1,715 @@ +;;; emoji.el --- Inserting emojis -*- lexical-binding:t -*- + +;; Copyright (C) 2021-2022 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) +(require 'multisession) + +(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-alternate-names nil + "Alist of emojis and lists of alternate names for the emojis. +Each element in the alist should have the emoji (as a string) as +the first element, and the rest of the elements should be strings +representing names. For instance: + + (\"🤗\" \"hug\" \"hugging\" \"kind\")") + +(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) +(define-multisession-variable emoji--recent (list "😀" "😖")) +(defvar emoji--insert-buffer) + +;;;###autoload +(defun emoji-insert (&optional text) + "Choose and insert an emoji glyph. +If TEXT (interactively, the prefix argument), choose the emoji +by typing its Unicode Standard name (with completion), instead +of selecting from emoji display." + (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 one of the recently-used emoji glyphs." + (interactive "*") + (emoji--init) + (unless (fboundp 'emoji--command-Emoji) + (emoji--define-transient)) + (funcall (emoji--define-transient + (cons "Recent" (multisession-value emoji--recent)) t))) + +;;;###autoload +(defun emoji-search () + "Choose and insert an emoji glyph by typing its Unicode name. +This command prompts for an emoji name, with completion, and +inserts it. It recognizes the Unicode Standard names of emoji, +and also consults the `emoji-alternate-names' alist." + (interactive "*") + (emoji--init) + (emoji--choose-emoji)) + +;;;###autoload +(defun emoji-list () + "List emojis and insert the one that's selected. +Select the emoji by typing \\<emoji-list-mode-map>\\[emoji-list-select] on its picture. +The glyph will be inserted into the buffer that was current +when the command was invoked." + (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) + "Display the name of the grapheme cluster composed from GLYPH. +GLYPH should be a string of one or more characters which together +produce an emoji. Interactively, GLYPH is the emoji at point (it +could also be any character, not just emoji). + +If called from Lisp, return the name as a string; return nil if +the name is not known." + (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 () + "Display the name of the emoji at point." + (interactive nil emoji-list-mode) + (let ((glyph (get-text-property (point) 'emoji-glyph))) + (unless glyph + (error "No emoji here")) + (let ((name (emoji--name glyph))) + (if (not name) + (error "Emoji name is unknown") + (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) + (glyphs nil) + 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)) + (glyph (mapconcat + (lambda (code) + (string (string-to-number code 16))) + (split-string codes)))) + (push (list name qualification group subgroup glyph) glyphs)))) + (forward-line 1)) + ;; We sort the data so that the "person foo" variant comes + ;; first, so that that becomes the key. + (setq glyphs + (sort (nreverse glyphs) + (lambda (g1 g2) + (and (equal (nth 2 g1) (nth 2 g2)) + (equal (nth 3 g1) (nth 3 g2)) + (< (emoji--score (car g1)) + (emoji--score (car g2))))))) + ;; Get the derivations. + (cl-loop for (name qualification group subgroup glyph) in glyphs + for base = (emoji--base-name name derivations) + do + ;; 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))))) + ;; 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--score (string) + (if (string-match-p "person\\|people" + (replace-regexp-in-string ":.*" "" string)) + 0 + 1)) + +(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))) + (catch 'found + ;; If we have (for instance) "person golfing", and we're adding + ;; "man golfing", make the latter a derivation of the former. + (let ((non-binary (replace-regexp-in-string + "\\`\\(m[ae]n\\|wom[ae]n\\) " "" base))) + (dolist (prefix '("person " "people " "")) + (let ((key (concat prefix non-binary))) + (when (gethash key derivations) + (throw 'found key))))) + ;; We can also have the gender at the end of the string, like + ;; "merman" and "pregnant woman". + (let ((non-binary (replace-regexp-in-string + "\\(m[ae]n\\|wom[ae]n\\|maid\\)\\'" "" base))) + (dolist (suffix '(" person" "person" "")) + (let ((key (concat non-binary suffix))) + (when (gethash key derivations) + (throw 'found key))))) + ;; Just return the base. + 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 nil not-a-mode) + ;; 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 nil not-a-mode) + (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" (multisession-value emoji--recent)) + t end-function)))) + +(defun emoji--add-recent (glyph) + "Add GLYPH to the set of recently used emojis." + (let ((recent (multisession-value emoji--recent))) + (setq recent (delete glyph recent)) + (push glyph recent) + ;; Shorten the list. + (when-let ((tail (nthcdr 30 recent))) + (setcdr tail nil)) + (setf (multisession-value emoji--recent) recent))) + +(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* ((table + (if (not emoji-alternate-names) + ;; If we don't have alternate names, do the efficient version. + emoji--all-bases + ;; Compute all the (possibly non-unique) names. + (let ((table nil)) + (maphash + (lambda (name glyph) + (push (concat name "\t" glyph) table)) + emoji--all-bases) + (dolist (elem emoji-alternate-names) + (dolist (name (cdr elem)) + (push (concat name "\t" (car elem)) table))) + (sort table #'string<)))) + (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) + (if emoji-alternate-names + (list name "" "") + (list name + (concat + (or (gethash name emoji--all-bases) " ") + "\t") + ""))) + strings)))) + (complete-with-action action table string pred))) + nil t))) + (when (cl-plusp (length name)) + (let* ((glyph (if emoji-alternate-names + (cadr (split-string name "\t")) + (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 31ffaf157b6..74be7edc649 100644 --- a/lisp/international/fontset.el +++ b/lisp/international/fontset.el @@ -182,8 +182,20 @@ (canadian-aboriginal #x14C0) (ogham #x168F) (runic #x16A0) + (tagalog #x1700) + (hanunoo #x1720) + (buhid #x1740) + (tagbanwa #x1760) (khmer #x1780) (mongolian #x1826) + (limbu #x1901 #x1920 #x1936) + (buginese #x1A00 #x1A1E) + (balinese #x1B13 #x1B35 #x1B5E) + (sundanese #x1B8A #x1BAB #x1CC4) + (batak #x1BC2 #x1BE7 #x1BFF) + (tai-le #x1950) + (tai-lue #x1980) + (tai-tham #x1A20 #x1A55 #x1A61 #x1A80) (symbol . [#x201C #x2200 #x2500]) (braille #x2800) (ideographic-description #x2FF0) @@ -193,7 +205,9 @@ (kanbun #x319D) (han #x5B57) (yi #xA288) - (javanese #xA980) + (syloti-nagri #xA807 #xA823 #xA82C) + (rejang #xA930 #xA947 #xA95F) + (javanese #xA98F #xA9B4 #xA9CA) (cham #xAA00) (tai-viet #xAA80) (hangul #xAC00) @@ -223,22 +237,24 @@ (lydian #x10920) (kharoshthi #x10A00) (manichaean #x10AC0) - (hanifi-rohingya #x10D00) + (hanifi-rohingya #x10D00 #x10D24 #x10D39) (yezidi #x10E80) (old-sogdian #x10F00) (sogdian #x10F30) (chorasmian #x10FB0) (elymaic #x10FE0) (old-uyghur #x10F70) + (brahmi #x11013 #x11045 #x11052 #x11065) + (kaithi #x1108D #x110B0 #x110BD) (mahajani #x11150) - (sinhala-archaic-number #x111E1) + (sharada #x11191 #x111B3 #x111CD) (khojki #x11200) (khudawadi #x112B0) - (grantha #x11305) + (grantha #x11315 #x1133E #x11374) (newa #x11400) - (tirhuta #x11481) - (siddham #x11580) - (modi #x11600) + (tirhuta #x11481 #x1148F #x114D0) + (siddham #x1158E #x115AF #x115D4) + (modi #x1160E #x11630 #x11655) (takri #x11680) (dogra #x11800) (warang-citi #x118A1) @@ -251,9 +267,8 @@ (marchen #x11C72) (masaram-gondi #x11D00) (gunjala-gondi #x11D60) - (makasar #x11EE0) + (makasar #x11EE0 #x11EF7) (cuneiform #x12000) - (cuneiform-numbers-and-punctuation #x12400) (cypro-minoan #x12F90) (egyptian #x13000) (mro #x16A40) @@ -262,7 +277,6 @@ (pahawh-hmong #x16B11) (medefaidrin #x16E40) (tangut #x17000) - (tangut-components #x18800) (khitan-small-script #x18B00) (nushu #x1B170) (duployan-shorthand #x1BC20) @@ -285,7 +299,7 @@ (defvar otf-script-alist) -;; The below was synchronized with the latest Oct 8, 2020 version of +;; The below was synchronized with the latest Sep 12, 2021 version of ;; https://docs.microsoft.com/en-us/typography/opentype/spec/scripttags (setq otf-script-alist '((adlm . adlam) @@ -318,6 +332,7 @@ (copt . coptic) (xsux . cuneiform) (cprt . cypriot) + (cpmn . cypro-minoan) (cyrl . cyrillic) (dsrt . deseret) (deva . devanagari) @@ -341,7 +356,7 @@ (gur2 . gurmukhi) (hani . han) (hang . hangul) - (jamo . hangul) + (jamo . hangul) ; Not recommended; use 'hang' instead. (rohg . hanifi-rohingya) (hano . hanunoo) (hatr . hatran) @@ -364,8 +379,8 @@ (latn . latin) (lepc . lepcha) (limb . limbu) - (lina . linear_a) - (linb . linear_b) + (lina . linear-a) + (linb . linear-b) (lisu . lisu) (lyci . lycian) (lydi . lydian) @@ -391,6 +406,7 @@ (musc . musical-symbol) (mym2 . burmese) (mymr . burmese) + (nand . nandinagari) (nbat . nabataean) (newa . newa) (nko\ . nko) @@ -405,6 +421,7 @@ (sogo . old-sogdian) (sarb . old-south-arabian) (orkh . old-turkic) + (ougr . old-uyghur) (orya . oriya) (ory2 . oriya) (osge . osage) @@ -430,17 +447,18 @@ (sora . sora-sompeng) (soyo . soyombo) (sund . sundanese) - (sylo . syloti_nagri) + (sylo . syloti-nagri) (syrc . syriac) (tglg . tagalog) (tagb . tagbanwa) - (tale . tai_le) + (tale . tai-le) (talu . tai-lue) (lana . tai-tham) (tavt . tai-viet) (takr . takri) (taml . tamil) (tml2 . tamil) + (tnsa . tangsa) (tang . tangut) (telu . telugu) (tel2 . telugu) @@ -449,7 +467,9 @@ (tibt . tibetan) (tfng . tifinagh) (tirh . tirhuta) + (toto . toto) (ugar . ugaritic) + (vith . vithkuqi) (vai\ . vai) (wcho . wancho) (wara . warang-citi) @@ -738,9 +758,20 @@ cham ogham runic + tagalog + hanunoo + buhid + tagbanwa + limbu + buginese + balinese + sundanese + batak symbol braille yi + syloti-nagri + rejang javanese tai-viet aegean-number @@ -760,15 +791,22 @@ cypriot-syllabary phoenician lydian + hanifi-rohingya yezidi kharoshthi manichaean chorasmian elymaic old-uyghur + brahmi + kaithi + sharada + grantha + tirhuta + siddham + modi makasar dives-akuru - cuneiform-numbers-and-punctuation cuneiform egyptian tangsa @@ -783,6 +821,7 @@ counting-rod-numeral toto adlam + tai-tham mahjong-tile domino-tile emoji)) @@ -816,11 +855,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 92bdee86879..3be80e5e6ab 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" . [?½]) @@ -121,7 +134,19 @@ ("*<" . [?«]) ("<" . [?«]) ("*=" . [?¯]) - ("=" . [?¯]) + ("==" . [?¯]) + ("=A" . [?Ā]) + ("=a" . [?ā]) + ("=E" . [?Ē]) + ("=e" . [?ē]) + ("=I" . [?Ī]) + ("=i" . [?ī]) + ("=O" . [?Ō]) + ("=o" . [?ō]) + ("=U" . [?Ū]) + ("=u" . [?ū]) + ("=Y" . [?Ȳ]) + ("=y" . [?ȳ]) ("*>" . [?»]) (">" . [?»]) ("*?" . [?¿]) @@ -138,9 +163,30 @@ ("S" . [?§]) ("*Y" . [?¥]) ("Y" . [?¥]) + ("^0" . [?⁰]) ("^1" . [?¹]) ("^2" . [?²]) ("^3" . [?³]) + ("^4" . [?⁴]) + ("^5" . [?⁵]) + ("^6" . [?⁶]) + ("^7" . [?⁷]) + ("^8" . [?⁸]) + ("^9" . [?⁹]) + ("^+" . [?⁺]) + ("^-" . [?⁻]) + ("_0" . [?₀]) + ("_1" . [?₁]) + ("_2" . [?₂]) + ("_3" . [?₃]) + ("_4" . [?₄]) + ("_5" . [?₅]) + ("_6" . [?₆]) + ("_7" . [?₇]) + ("_8" . [?₈]) + ("_9" . [?₉]) + ("_+" . [?₊]) + ("_-" . [?₋]) ("^A" . [?Â]) ("^E" . [?Ê]) ("^I" . [?Î]) @@ -169,10 +215,10 @@ ("o" . [?°]) ("Oe" . [?œ]) ("OE" . [?Œ]) - ("*u" . [?µ]) - ("u" . [?µ]) - ("*m" . [?µ]) - ("m" . [?µ]) + ("*u" . [?μ]) + ("u" . [?μ]) + ("*m" . [?μ]) + ("m" . [?μ]) ("*x" . [?×]) ("x" . [?×]) ("*|" . [?¦]) @@ -294,6 +340,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/ja-dic-cnv.el b/lisp/international/ja-dic-cnv.el index 704f1a1ae62..7f7c0261dca 100644 --- a/lisp/international/ja-dic-cnv.el +++ b/lisp/international/ja-dic-cnv.el @@ -335,7 +335,7 @@ Saves the output as `ja-dic-filename', in directory DIRNAME (if specified)." (insert-file-contents (expand-file-name filename))) (re-search-forward "^[^;]") (while (re-search-forward ";[^\n/]*/" nil t) - (replace-match "/"))) + (replace-match "/" t t))) ;; Setup and generate the header part of working buffer. (with-current-buffer buf (erase-buffer) diff --git a/lisp/international/latin1-disp.el b/lisp/international/latin1-disp.el index 96a54cc2128..7054077fb02 100644 --- a/lisp/international/latin1-disp.el +++ b/lisp/international/latin1-disp.el @@ -764,2426 +764,2425 @@ turn it off and display Unicode characters literally. The display isn't changed if the display can render Unicode characters." (interactive "p") (if (> arg 0) - (unless (char-displayable-p #x101) ; a with macron - ;; It doesn't look as though we have a Unicode font. - (let ((latin1-display-format "%s")) - (mapc - (lambda (l) - (apply 'latin1-display-char l)) - ;; Table derived by running Lynx on a suitable list of - ;; characters in a utf-8 file, except for some added by - ;; hand at the end. - '((?\Ā "A") - (?\ā "a") - (?\Ă "A") - (?\ă "a") - (?\Ą "A") - (?\ą "a") - (?\Ć "C") - (?\ć "c") - (?\Ĉ "C") - (?\ĉ "c") - (?\Ċ "C") - (?\ċ "c") - (?\Č "C") - (?\č "c") - (?\Ď "D") - (?\ď "d") - (?\Đ "Ð") - (?\đ "d/") - (?\Ē "E") - (?\ē "e") - (?\Ĕ "E") - (?\ĕ "e") - (?\Ė "E") - (?\ė "e") - (?\Ę "E") - (?\ę "e") - (?\Ě "E") - (?\ě "e") - (?\Ĝ "G") - (?\ĝ "g") - (?\Ğ "G") - (?\ğ "g") - (?\Ġ "G") - (?\ġ "g") - (?\Ģ "G") - (?\ģ "g") - (?\Ĥ "H") - (?\ĥ "h") - (?\Ħ "H/") - (?\ħ "H") - (?\Ĩ "I") - (?\ĩ "i") - (?\Ī "I") - (?\ī "i") - (?\Ĭ "I") - (?\ĭ "i") - (?\Į "I") - (?\į "i") - (?\İ "I") - (?\ı "i") - (?\IJ "IJ") - (?\ij "ij") - (?\Ĵ "J") - (?\ĵ "j") - (?\Ķ "K") - (?\ķ "k") - (?\ĸ "kk") - (?\Ĺ "L") - (?\ĺ "l") - (?\Ļ "L") - (?\ļ "l") - (?\Ľ "L") - (?\ľ "l") - (?\Ŀ "L.") - (?\ŀ "l.") - (?\Ł "L/") - (?\ł "l/") - (?\Ń "N") - (?\ń "n") - (?\Ņ "N") - (?\ņ "n") - (?\Ň "N") - (?\ň "n") - (?\ʼn "'n") - (?\Ŋ "NG") - (?\ŋ "N") - (?\Ō "O") - (?\ō "o") - (?\Ŏ "O") - (?\ŏ "o") - (?\Ő "O\"") - (?\ő "o\"") - (?\Œ "OE") - (?\œ "oe") - (?\Ŕ "R") - (?\ŕ "r") - (?\Ŗ "R") - (?\ŗ "r") - (?\Ř "R") - (?\ř "r") - (?\Ś "S") - (?\ś "s") - (?\Ŝ "S") - (?\ŝ "s") - (?\Ş "S") - (?\ş "s") - (?\Š "S") - (?\š "s") - (?\Ţ "T") - (?\ţ "t") - (?\Ť "T") - (?\ť "t") - (?\Ŧ "T/") - (?\ŧ "t/") - (?\Ũ "U") - (?\ũ "u") - (?\Ū "U") - (?\ū "u") - (?\Ŭ "U") - (?\ŭ "u") - (?\Ů "U") - (?\ů "u") - (?\Ű "U\"") - (?\ű "u\"") - (?\Ų "U") - (?\ų "u") - (?\Ŵ "W") - (?\ŵ "w") - (?\Ŷ "Y") - (?\ŷ "y") - (?\Ÿ "Y") - (?\Ź "Z") - (?\ź "z") - (?\Ż "Z") - (?\ż "z") - (?\Ž "Z") - (?\ž "z") - (?\ſ "s1") - (?\Ƈ "C2") - (?\ƈ "c2") - (?\Ƒ "F2") - (?\ƒ " f") - (?\Ƙ "K2") - (?\ƙ "k2") - (?\Ơ "O9") - (?\ơ "o9") - (?\Ƣ "OI") - (?\ƣ "oi") - (?\Ʀ "yr") - (?\Ư "U9") - (?\ư "u9") - (?\Ƶ "Z/") - (?\ƶ "z/") - (?\Ʒ "ED") - (?\Ǎ "A") - (?\ǎ "a") - (?\Ǐ "I") - (?\ǐ "i") - (?\Ǒ "O") - (?\ǒ "o") - (?\Ǔ "U") - (?\ǔ "u") - (?\Ǖ "U:-") - (?\ǖ "u:-") - (?\Ǘ "U:'") - (?\ǘ "u:'") - (?\Ǚ "U:<") - (?\ǚ "u:<") - (?\Ǜ "U:!") - (?\ǜ "u:!") - (?\Ǟ "A1") - (?\ǟ "a1") - (?\Ǡ "A7") - (?\ǡ "a7") - (?\Ǣ "A3") - (?\ǣ "a3") - (?\Ǥ "G/") - (?\ǥ "g/") - (?\Ǧ "G") - (?\ǧ "g") - (?\Ǩ "K") - (?\ǩ "k") - (?\Ǫ "O") - (?\ǫ "o") - (?\Ǭ "O1") - (?\ǭ "o1") - (?\Ǯ "EZ") - (?\ǯ "ez") - (?\ǰ "j") - (?\Ǵ "G") - (?\ǵ "g") - (?\Ǻ "AA'") - (?\ǻ "aa'") - (?\Ǽ "AE'") - (?\ǽ "ae'") - (?\Ǿ "O/'") - (?\ǿ "o/'") - (?\Ȁ "A!!") - (?\ȁ "a!!") - (?\Ȃ "A)") - (?\ȃ "a)") - (?\Ȅ "E!!") - (?\ȅ "e!!") - (?\Ȇ "E)") - (?\ȇ "e)") - (?\Ȉ "I!!") - (?\ȉ "i!!") - (?\Ȋ "I)") - (?\ȋ "i)") - (?\Ȍ "O!!") - (?\ȍ "o!!") - (?\Ȏ "O)") - (?\ȏ "o)") - (?\Ȑ "R!!") - (?\ȑ "r!!") - (?\Ȓ "R)") - (?\ȓ "r)") - (?\Ȕ "U!!") - (?\ȕ "u!!") - (?\Ȗ "U)") - (?\ȗ "u)") - (?\ȝ "Z") - (?\ɑ "A") - (?\ɒ "A.") - (?\ɓ "b`") - (?\ɔ "O") - (?\ɖ "d.") - (?\ɗ "d`") - (?\ɘ "@<umd>") - (?\ə "@") - (?\ɚ "R") - (?\ɛ "E") - (?\ɜ "V\"") - (?\ɝ "R<umd>") - (?\ɞ "O\"") - (?\ɟ "J") - (?\ɠ "g`") - (?\ɡ "g") - (?\ɢ "G") - (?\ɣ "Q") - (?\ɤ "o-") - (?\ɥ "j<rnd>") - (?\ɦ "h<?>") - (?\ɨ "i\"") - (?\ɩ "I") - (?\ɪ "I") - (?\ɫ "L") - (?\ɬ "L") - (?\ɭ "l.") - (?\ɮ "z<lat>") - (?\ɯ "u-") - (?\ɰ "j<vel>") - (?\ɱ "M") - (?\ɳ "n.") - (?\ɴ "n\"") - (?\ɵ "@.") - (?\ɶ "&.") - (?\ɷ "U") - (?\ɹ "r") - (?\ɺ "*<lat>") - (?\ɻ "r.") - (?\ɽ "*.") - (?\ɾ "*") - (?\ʀ "R") - (?\ʁ "g\"") - (?\ʂ "s.") - (?\ʃ "S") - (?\ʄ "J`") - (?\ʇ "t!") - (?\ʈ "t.") - (?\ʉ "u\"") - (?\ʊ "U") - (?\ʋ "r<lbd>") - (?\ʌ "V") - (?\ʍ "w<vls>") - (?\ʎ "l^") - (?\ʏ "I.") - (?\ʐ "z.") - (?\ʒ "Z") - (?\ʔ "?") - (?\ʕ "H<vcd>") - (?\ʖ "l!") - (?\ʗ "c!") - (?\ʘ "p!") - (?\ʙ "b<trl>") - (?\ʛ "G`") - (?\ʝ "j") - (?\ʞ "k!") - (?\ʟ "L") - (?\ʠ "q`") - (?\ʤ "d3") - (?\ʦ "ts") - (?\ʧ "tS") - (?\ʰ "<h>") - (?\ʱ "<?>") - (?\ʲ ";") - (?\ʳ "<r>") - (?\ʷ "<w>") - (?\ʻ ";S") - (?\ʼ "`") - (?\ˆ "^") - (?\ˇ "'<") - (?\ˈ "|") - (?\ˉ "1-") - (?\ˋ "1!") - (?\ː ":") - (?\ˑ ":\\") - (?\˖ "+") - (?\˗ "-") - (?\˘ "'(") - (?\˙ "'.") - (?\˚ "'0") - (?\˛ "';") - (?\˜ "~") - (?\˝ "'\"") - (?\˥ "_T") - (?\˦ "_H") - (?\˧ "_M") - (?\˨ "_L") - (?\˩ "_B") - (?\ˬ "_v") - (?\ˮ "''") - (?\̀ "`") - (?\́ "'") - (?\̂ "^") - (?\̃ "~") - (?\̄ "¯") - (?\̇ "·") - (?\̈ "¨") - (?\̊ "°") - (?\̋ "''") - (?\̍ "|") - (?\̎ "||") - (?\̏ "``") - (?\̡ ";") - (?\̢ ".") - (?\̣ ".") - (?\̤ "<?>") - (?\̥ "<o>") - (?\̦ ",") - (?\̧ "¸") - (?\̩ "-") - (?\̪ "[") - (?\̫ "<w>") - (?\̴ "~") - (?\̷ "/") - (?\̸ "/") - (?\̀ "`") - (?\́ "'") - (?\͂ "~") - (?\̈́ "'%") - (?\ͅ "j3") - (?\͇ "=") - (?\͠ "~~") - (?\ʹ "'") - (?\͵ ",") - (?\ͺ "j3") - (?\; "?%") - (?\΄ "'*") - (?\΅ "'%") - (?\Ά "A'") - (?\· "·") - (?\Έ "E'") - (?\Ή "Y%") - (?\Ί "I'") - (?\Ό "O'") - (?\Ύ "U%") - (?\Ώ "W%") - (?\ΐ "i3") - (?\Α "A") - (?\Β "B") - (?\Γ "G") - (?\Δ "D") - (?\Ε "E") - (?\Ζ "Z") - (?\Η "Y") - (?\Θ "TH") - (?\Ι "I") - (?\Κ "K") - (?\Λ "L") - (?\Μ "M") - (?\Ν "N") - (?\Ξ "C") - (?\Ο "O") - (?\Π "P") - (?\Ρ "R") - (?\Σ "S") - (?\Τ "T") - (?\Υ "U") - (?\Φ "F") - (?\Χ "X") - (?\Ψ "Q") - (?\Ω "W*") - (?\Ϊ "J") - (?\Ϋ "V*") - (?\ά "a'") - (?\έ "e'") - (?\ή "y%") - (?\ί "i'") - (?\ΰ "u3") - (?\α "a") - (?\β "b") - (?\γ "g") - (?\δ "d") - (?\ε "e") - (?\ζ "z") - (?\η "y") - (?\θ "th") - (?\ι "i") - (?\κ "k") - (?\λ "l") - (?\μ "µ") - (?\ν "n") - (?\ξ "c") - (?\ο "o") - (?\π "p") - (?\ρ "r") - (?\ς "*s") - (?\σ "s") - (?\τ "t") - (?\υ "u") - (?\φ "f") - (?\χ "x") - (?\ψ "q") - (?\ω "w") - (?\ϊ "j") - (?\ϋ "v*") - (?\ό "o'") - (?\ύ "u%") - (?\ώ "w%") - (?\ϐ "beta ") - (?\ϑ "theta ") - (?\ϒ "upsi ") - (?\ϕ "phi ") - (?\ϖ "pi ") - (?\ϗ "k.") - (?\Ϛ "T3") - (?\ϛ "t3") - (?\Ϝ "M3") - (?\ϝ "m3") - (?\Ϟ "K3") - (?\ϟ "k3") - (?\Ϡ "P3") - (?\ϡ "p3") - (?\ϰ "kappa ") - (?\ϱ "rho ") - (?\ϳ "J") - (?\ϴ "'%") - (?\ϵ "j3") - (?\Ё "IO") - (?\Ђ "D%") - (?\Ѓ "G%") - (?\Є "IE") - (?\Ѕ "DS") - (?\І "II") - (?\Ї "YI") - (?\Ј "J%") - (?\Љ "LJ") - (?\Њ "NJ") - (?\Ћ "Ts") - (?\Ќ "KJ") - (?\Ў "V%") - (?\Џ "DZ") - (?\А "A") - (?\Б "B") - (?\В "V") - (?\Г "G") - (?\Д "D") - (?\Е "E") - (?\Ж "ZH") - (?\З "Z") - (?\И "I") - (?\Й "J") - (?\К "K") - (?\Л "L") - (?\М "M") - (?\Н "N") - (?\О "O") - (?\П "P") - (?\Р "R") - (?\С "S") - (?\Т "T") - (?\У "U") - (?\Ф "F") - (?\Х "H") - (?\Ц "C") - (?\Ч "CH") - (?\Ш "SH") - (?\Щ "SCH") - (?\Ъ "\"") - (?\Ы "Y") - (?\Ь "'") - (?\Э "`E") - (?\Ю "YU") - (?\Я "YA") - (?\а "a") - (?\б "b") - (?\в "v") - (?\г "g") - (?\д "d") - (?\е "e") - (?\ж "zh") - (?\з "z") - (?\и "i") - (?\й "j") - (?\к "k") - (?\л "l") - (?\м "m") - (?\н "n") - (?\о "o") - (?\п "p") - (?\р "r") - (?\с "s") - (?\т "t") - (?\у "u") - (?\ф "f") - (?\х "h") - (?\ц "c") - (?\ч "ch") - (?\ш "sh") - (?\щ "sch") - (?\ъ "\"") - (?\ы "y") - (?\ь "'") - (?\э "`e") - (?\ю "yu") - (?\я "ya") - (?\ё "io") - (?\ђ "d%") - (?\ѓ "g%") - (?\є "ie") - (?\ѕ "ds") - (?\і "ii") - (?\ї "yi") - (?\ј "j%") - (?\љ "lj") - (?\њ "nj") - (?\ћ "ts") - (?\ќ "kj") - (?\ў "v%") - (?\џ "dz") - (?\Ѣ "Y3") - (?\ѣ "y3") - (?\Ѫ "O3") - (?\ѫ "o3") - (?\Ѳ "F3") - (?\ѳ "f3") - (?\Ѵ "V3") - (?\ѵ "v3") - (?\Ҁ "C3") - (?\ҁ "c3") - (?\Ґ "G3") - (?\ґ "g3") - (?\Ӕ "AE") - (?\ӕ "ae") - (?\ִ "i") - (?\ַ "a") - (?\ָ "o") - (?\ּ "u") - (?\ֿ "h") - (?\ׂ ":") - (?\א "#") - (?\ב "B+") - (?\ג "G+") - (?\ד "D+") - (?\ה "H+") - (?\ו "W+") - (?\ז "Z+") - (?\ח "X+") - (?\ט "Tj") - (?\י "J+") - (?\ך "K%") - (?\כ "K+") - (?\ל "L+") - (?\ם "M%") - (?\מ "M+") - (?\ן "N%") - (?\נ "N+") - (?\ס "S+") - (?\ע "E+") - (?\ף "P%") - (?\פ "P+") - (?\ץ "Zj") - (?\צ "ZJ") - (?\ק "Q+") - (?\ר "R+") - (?\ש "Sh") - (?\ת "T+") - (?\װ "v") - (?\ױ "oy") - (?\ײ "ey") - (?\، ",+") - (?\؛ ";+") - (?\؟ "?+") - (?\ء "H'") - (?\آ "aM") - (?\أ "aH") - (?\ؤ "wH") - (?\إ "ah") - (?\ئ "yH") - (?\ا "a+") - (?\ب "b+") - (?\ة "tm") - (?\ت "t+") - (?\ث "tk") - (?\ج "g+") - (?\ح "hk") - (?\خ "x+") - (?\د "d+") - (?\ذ "dk") - (?\ر "r+") - (?\ز "z+") - (?\س "s+") - (?\ش "sn") - (?\ص "c+") - (?\ض "dd") - (?\ط "tj") - (?\ظ "zH") - (?\ع "e+") - (?\غ "i+") - (?\ـ "++") - (?\ف "f+") - (?\ق "q+") - (?\ك "k+") - (?\ل "l+") - (?\م "m+") - (?\ن "n+") - (?\ه "h+") - (?\و "w+") - (?\ى "j+") - (?\ي "y+") - (?\ً ":+") - (?\ٌ "\"+") - (?\ٍ "=+") - (?\َ "/+") - (?\ُ "'+") - (?\ِ "1+") - (?\ّ "3+") - (?\ْ "0+") - (?\٠ "0a") - (?\١ "1a") - (?\٢ "2a") - (?\٣ "3a") - (?\٤ "4a") - (?\٥ "5a") - (?\٦ "6a") - (?\٧ "7a") - (?\٨ "8a") - (?\٩ "9a") - (?\ٰ "aS") - (?\پ "p+") - (?\ځ "hH") - (?\چ "tc") - (?\ژ "zj") - (?\ڤ "v+") - (?\گ "gf") - (?\۰ "0a") - (?\۱ "1a") - (?\۲ "2a") - (?\۳ "3a") - (?\۴ "4a") - (?\۵ "5a") - (?\۶ "6a") - (?\۷ "7a") - (?\۸ "8a") - (?\۹ "9a") - (?\ሀ "he") - (?\ሁ "hu") - (?\ሂ "hi") - (?\ሃ "ha") - (?\ሄ "hE") - (?\ህ "h") - (?\ሆ "ho") - (?\ለ "le") - (?\ሉ "lu") - (?\ሊ "li") - (?\ላ "la") - (?\ሌ "lE") - (?\ል "l") - (?\ሎ "lo") - (?\ሏ "lWa") - (?\ሐ "He") - (?\ሑ "Hu") - (?\ሒ "Hi") - (?\ሓ "Ha") - (?\ሔ "HE") - (?\ሕ "H") - (?\ሖ "Ho") - (?\ሗ "HWa") - (?\መ "me") - (?\ሙ "mu") - (?\ሚ "mi") - (?\ማ "ma") - (?\ሜ "mE") - (?\ም "m") - (?\ሞ "mo") - (?\ሟ "mWa") - (?\ሠ "`se") - (?\ሡ "`su") - (?\ሢ "`si") - (?\ሣ "`sa") - (?\ሤ "`sE") - (?\ሥ "`s") - (?\ሦ "`so") - (?\ሧ "`sWa") - (?\ረ "re") - (?\ሩ "ru") - (?\ሪ "ri") - (?\ራ "ra") - (?\ሬ "rE") - (?\ር "r") - (?\ሮ "ro") - (?\ሯ "rWa") - (?\ሰ "se") - (?\ሱ "su") - (?\ሲ "si") - (?\ሳ "sa") - (?\ሴ "sE") - (?\ስ "s") - (?\ሶ "so") - (?\ሷ "sWa") - (?\ሸ "xe") - (?\ሹ "xu") - (?\ሺ "xi") - (?\ሻ "xa") - (?\ሼ "xE") - (?\ሽ "xa") - (?\ሾ "xo") - (?\ሿ "xWa") - (?\ቀ "qe") - (?\ቁ "qu") - (?\ቂ "qi") - (?\ቃ "qa") - (?\ቄ "qE") - (?\ቅ "q") - (?\ቆ "qo") - (?\ቈ "qWe") - (?\ቊ "qWi") - (?\ቋ "qWa") - (?\ቌ "qWE") - (?\ቍ "qW") - (?\ቐ "Qe") - (?\ቑ "Qu") - (?\ቒ "Qi") - (?\ቓ "Qa") - (?\ቔ "QE") - (?\ቕ "Q") - (?\ቖ "Qo") - (?\ቘ "QWe") - (?\ቚ "QWi") - (?\ቛ "QWa") - (?\ቜ "QWE") - (?\ቝ "QW") - (?\በ "be") - (?\ቡ "bu") - (?\ቢ "bi") - (?\ባ "ba") - (?\ቤ "bE") - (?\ብ "b") - (?\ቦ "bo") - (?\ቧ "bWa") - (?\ቨ "ve") - (?\ቩ "vu") - (?\ቪ "vi") - (?\ቫ "va") - (?\ቬ "vE") - (?\ቭ "v") - (?\ቮ "vo") - (?\ቯ "vWa") - (?\ተ "te") - (?\ቱ "tu") - (?\ቲ "ti") - (?\ታ "ta") - (?\ቴ "tE") - (?\ት "t") - (?\ቶ "to") - (?\ቷ "tWa") - (?\ቸ "ce") - (?\ቹ "cu") - (?\ቺ "ci") - (?\ቻ "ca") - (?\ቼ "cE") - (?\ች "c") - (?\ቾ "co") - (?\ቿ "cWa") - (?\ኀ "`he") - (?\ኁ "`hu") - (?\ኂ "`hi") - (?\ኃ "`ha") - (?\ኄ "`hE") - (?\ኅ "`h") - (?\ኆ "`ho") - (?\ኈ "hWe") - (?\ኊ "hWi") - (?\ኋ "hWa") - (?\ኌ "hWE") - (?\ኍ "hW") - (?\ነ "na") - (?\ኑ "nu") - (?\ኒ "ni") - (?\ና "na") - (?\ኔ "nE") - (?\ን "n") - (?\ኖ "no") - (?\ኗ "nWa") - (?\ኘ "Ne") - (?\ኙ "Nu") - (?\ኚ "Ni") - (?\ኛ "Na") - (?\ኜ "NE") - (?\ኝ "N") - (?\ኞ "No") - (?\ኟ "NWa") - (?\አ "e") - (?\ኡ "u") - (?\ኢ "i") - (?\ኣ "a") - (?\ኤ "E") - (?\እ "I") - (?\ኦ "o") - (?\ኧ "e3") - (?\ከ "ke") - (?\ኩ "ku") - (?\ኪ "ki") - (?\ካ "ka") - (?\ኬ "kE") - (?\ክ "k") - (?\ኮ "ko") - (?\ኰ "kWe") - (?\ኲ "kWi") - (?\ኳ "kWa") - (?\ኴ "kWE") - (?\ኵ "kW") - (?\ኸ "Ke") - (?\ኹ "Ku") - (?\ኺ "Ki") - (?\ኻ "Ka") - (?\ኼ "KE") - (?\ኽ "K") - (?\ኾ "Ko") - (?\ዀ "KWe") - (?\ዂ "KWi") - (?\ዃ "KWa") - (?\ዄ "KWE") - (?\ዅ "KW") - (?\ወ "we") - (?\ዉ "wu") - (?\ዊ "wi") - (?\ዋ "wa") - (?\ዌ "wE") - (?\ው "w") - (?\ዎ "wo") - (?\ዐ "`e") - (?\ዑ "`u") - (?\ዒ "`i") - (?\ዓ "`a") - (?\ዔ "`E") - (?\ዕ "`I") - (?\ዖ "`o") - (?\ዘ "ze") - (?\ዙ "zu") - (?\ዚ "zi") - (?\ዛ "za") - (?\ዜ "zE") - (?\ዝ "z") - (?\ዞ "zo") - (?\ዟ "zWa") - (?\ዠ "Ze") - (?\ዡ "Zu") - (?\ዢ "Zi") - (?\ዣ "Za") - (?\ዤ "ZE") - (?\ዥ "Z") - (?\ዦ "Zo") - (?\ዧ "ZWa") - (?\የ "ye") - (?\ዩ "yu") - (?\ዪ "yi") - (?\ያ "ya") - (?\ዬ "yE") - (?\ይ "y") - (?\ዮ "yo") - (?\ዯ "yWa") - (?\ደ "de") - (?\ዱ "du") - (?\ዲ "di") - (?\ዳ "da") - (?\ዴ "dE") - (?\ድ "d") - (?\ዶ "do") - (?\ዷ "dWa") - (?\ዸ "De") - (?\ዹ "Du") - (?\ዺ "Di") - (?\ዻ "Da") - (?\ዼ "DE") - (?\ዽ "D") - (?\ዾ "Do") - (?\ዿ "DWa") - (?\ጀ "je") - (?\ጁ "ju") - (?\ጂ "ji") - (?\ጃ "ja") - (?\ጄ "jE") - (?\ጅ "j") - (?\ጆ "jo") - (?\ጇ "jWa") - (?\ገ "ga") - (?\ጉ "gu") - (?\ጊ "gi") - (?\ጋ "ga") - (?\ጌ "gE") - (?\ግ "g") - (?\ጎ "go") - (?\ጐ "gWu") - (?\ጒ "gWi") - (?\ጓ "gWa") - (?\ጔ "gWE") - (?\ጕ "gW") - (?\ጘ "Ge") - (?\ጙ "Gu") - (?\ጚ "Gi") - (?\ጛ "Ga") - (?\ጜ "GE") - (?\ጝ "G") - (?\ጞ "Go") - (?\ጟ "GWa") - (?\ጠ "Te") - (?\ጡ "Tu") - (?\ጢ "Ti") - (?\ጣ "Ta") - (?\ጤ "TE") - (?\ጥ "T") - (?\ጦ "To") - (?\ጧ "TWa") - (?\ጨ "Ce") - (?\ጩ "Ca") - (?\ጪ "Cu") - (?\ጫ "Ca") - (?\ጬ "CE") - (?\ጭ "C") - (?\ጮ "Co") - (?\ጯ "CWa") - (?\ጰ "Pe") - (?\ጱ "Pu") - (?\ጲ "Pi") - (?\ጳ "Pa") - (?\ጴ "PE") - (?\ጵ "P") - (?\ጶ "Po") - (?\ጷ "PWa") - (?\ጸ "SWe") - (?\ጹ "SWu") - (?\ጺ "SWi") - (?\ጻ "SWa") - (?\ጼ "SWE") - (?\ጽ "SW") - (?\ጾ "SWo") - (?\ጿ "SWa") - (?\ፀ "`Sa") - (?\ፁ "`Su") - (?\ፂ "`Si") - (?\ፃ "`Sa") - (?\ፄ "`SE") - (?\ፅ "`S") - (?\ፆ "`So") - (?\ፈ "fa") - (?\ፉ "fu") - (?\ፊ "fi") - (?\ፋ "fa") - (?\ፌ "fE") - (?\ፍ "o") - (?\ፎ "fo") - (?\ፏ "fWa") - (?\ፐ "pe") - (?\ፑ "pu") - (?\ፒ "pi") - (?\ፓ "pa") - (?\ፔ "pE") - (?\ፕ "p") - (?\ፖ "po") - (?\ፗ "pWa") - (?\ፘ "mYa") - (?\ፙ "rYa") - (?\ፚ "fYa") - (?\፠ " ") - (?\፡ ":") - (?\። "::") - (?\፣ ",") - (?\፤ ";") - (?\፥ "-:") - (?\፦ ":-") - (?\፧ "`?") - (?\፨ ":|:") - (?\፩ "`1") - (?\፪ "`2") - (?\፫ "`3") - (?\፬ "`4") - (?\፭ "`5") - (?\፮ "`6") - (?\፯ "`7") - (?\፰ "`8") - (?\፱ "`9") - (?\፲ "`10") - (?\፳ "`20") - (?\፴ "`30") - (?\፵ "`40") - (?\፶ "`50") - (?\፷ "`60") - (?\፸ "`70") - (?\፹ "`80") - (?\፺ "`90") - (?\፻ "`100") - (?\፼ "`10000") - (?\Ḁ "A-0") - (?\ḁ "a-0") - (?\Ḃ "B.") - (?\ḃ "b.") - (?\Ḅ "B-.") - (?\ḅ "b-.") - (?\Ḇ "B_") - (?\ḇ "b_") - (?\Ḉ "C,'") - (?\ḉ "c,'") - (?\Ḋ "D.") - (?\ḋ "d.") - (?\Ḍ "D-.") - (?\ḍ "d-.") - (?\Ḏ "D_") - (?\ḏ "d_") - (?\Ḑ "D,") - (?\ḑ "d,") - (?\Ḓ "D->") - (?\ḓ "d->") - (?\Ḕ "E-!") - (?\ḕ "e-!") - (?\Ḗ "E-'") - (?\ḗ "e-'") - (?\Ḙ "E->") - (?\ḙ "e->") - (?\Ḛ "E-?") - (?\ḛ "e-?") - (?\Ḝ "E,(") - (?\ḝ "e,(") - (?\Ḟ "F.") - (?\ḟ "f.") - (?\Ḡ "G-") - (?\ḡ "g-") - (?\Ḣ "H.") - (?\ḣ "h.") - (?\Ḥ "H-.") - (?\ḥ "h-.") - (?\Ḧ "H:") - (?\ḧ "h:") - (?\Ḩ "H,") - (?\ḩ "h,") - (?\Ḫ "H-(") - (?\ḫ "h-(") - (?\Ḭ "I-?") - (?\ḭ "i-?") - (?\Ḯ "I:'") - (?\ḯ "i:'") - (?\Ḱ "K'") - (?\ḱ "k'") - (?\Ḳ "K-.") - (?\ḳ "k-.") - (?\Ḵ "K_") - (?\ḵ "k_") - (?\Ḷ "L-.") - (?\ḷ "l-.") - (?\Ḹ "L--.") - (?\ḹ "l--.") - (?\Ḻ "L_") - (?\ḻ "l_") - (?\Ḽ "L->") - (?\ḽ "l->") - (?\Ḿ "M'") - (?\ḿ "m'") - (?\Ṁ "M.") - (?\ṁ "m.") - (?\Ṃ "M-.") - (?\ṃ "m-.") - (?\Ṅ "N.") - (?\ṅ "n.") - (?\Ṇ "N-.") - (?\ṇ "n-.") - (?\Ṉ "N_") - (?\ṉ "n_") - (?\Ṋ "N->") - (?\ṋ "n->") - (?\Ṍ "O?'") - (?\ṍ "o?'") - (?\Ṏ "O?:") - (?\ṏ "o?:") - (?\Ṑ "O-!") - (?\ṑ "o-!") - (?\Ṓ "O-'") - (?\ṓ "o-'") - (?\Ṕ "P'") - (?\ṕ "p'") - (?\Ṗ "P.") - (?\ṗ "p.") - (?\Ṙ "R.") - (?\ṙ "r.") - (?\Ṛ "R-.") - (?\ṛ "r-.") - (?\Ṝ "R--.") - (?\ṝ "r--.") - (?\Ṟ "R_") - (?\ṟ "r_") - (?\Ṡ "S.") - (?\ṡ "s.") - (?\Ṣ "S-.") - (?\ṣ "s-.") - (?\Ṥ "S'.") - (?\ṥ "s'.") - (?\Ṧ "S<.") - (?\ṧ "s<.") - (?\Ṩ "S.-.") - (?\ṩ "s.-.") - (?\Ṫ "T.") - (?\ṫ "t.") - (?\Ṭ "T-.") - (?\ṭ "t-.") - (?\Ṯ "T_") - (?\ṯ "t_") - (?\Ṱ "T->") - (?\ṱ "t->") - (?\Ṳ "U--:") - (?\ṳ "u--:") - (?\Ṵ "U-?") - (?\ṵ "u-?") - (?\Ṷ "U->") - (?\ṷ "u->") - (?\Ṹ "U?'") - (?\ṹ "u?'") - (?\Ṻ "U-:") - (?\ṻ "u-:") - (?\Ṽ "V?") - (?\ṽ "v?") - (?\Ṿ "V-.") - (?\ṿ "v-.") - (?\Ẁ "W!") - (?\ẁ "w!") - (?\Ẃ "W'") - (?\ẃ "w'") - (?\Ẅ "W:") - (?\ẅ "w:") - (?\Ẇ "W.") - (?\ẇ "w.") - (?\Ẉ "W-.") - (?\ẉ "w-.") - (?\Ẋ "X.") - (?\ẋ "x.") - (?\Ẍ "X:") - (?\ẍ "x:") - (?\Ẏ "Y.") - (?\ẏ "y.") - (?\Ẑ "Z>") - (?\ẑ "z>") - (?\Ẓ "Z-.") - (?\ẓ "z-.") - (?\Ẕ "Z_") - (?\ẕ "z_") - (?\ẖ "h_") - (?\ẗ "t:") - (?\ẘ "w0") - (?\ẙ "y0") - (?\Ạ "A-.") - (?\ạ "a-.") - (?\Ả "A2") - (?\ả "a2") - (?\Ấ "A>'") - (?\ấ "a>'") - (?\Ầ "A>!") - (?\ầ "a>!") - (?\Ẩ "A>2") - (?\ẩ "a>2") - (?\Ẫ "A>?") - (?\ẫ "a>?") - (?\Ậ "A>-.") - (?\ậ "a>-.") - (?\Ắ "A('") - (?\ắ "a('") - (?\Ằ "A(!") - (?\ằ "a(!") - (?\Ẳ "A(2") - (?\ẳ "a(2") - (?\Ẵ "A(?") - (?\ẵ "a(?") - (?\Ặ "A(-.") - (?\ặ "a(-.") - (?\Ẹ "E-.") - (?\ẹ "e-.") - (?\Ẻ "E2") - (?\ẻ "e2") - (?\Ẽ "E?") - (?\ẽ "e?") - (?\Ế "E>'") - (?\ế "e>'") - (?\Ề "E>!") - (?\ề "e>!") - (?\Ể "E>2") - (?\ể "e>2") - (?\Ễ "E>?") - (?\ễ "e>?") - (?\Ệ "E>-.") - (?\ệ "e>-.") - (?\Ỉ "I2") - (?\ỉ "i2") - (?\Ị "I-.") - (?\ị "i-.") - (?\Ọ "O-.") - (?\ọ "o-.") - (?\Ỏ "O2") - (?\ỏ "o2") - (?\Ố "O>'") - (?\ố "o>'") - (?\Ồ "O>!") - (?\ồ "o>!") - (?\Ổ "O>2") - (?\ổ "o>2") - (?\Ỗ "O>?") - (?\ỗ "o>?") - (?\Ộ "O>-.") - (?\ộ "o>-.") - (?\Ớ "O9'") - (?\ớ "o9'") - (?\Ờ "O9!") - (?\ờ "o9!") - (?\Ở "O92") - (?\ở "o92") - (?\Ỡ "O9?") - (?\ỡ "o9?") - (?\Ợ "O9-.") - (?\ợ "o9-.") - (?\Ụ "U-.") - (?\ụ "u-.") - (?\Ủ "U2") - (?\ủ "u2") - (?\Ứ "U9'") - (?\ứ "u9'") - (?\Ừ "U9!") - (?\ừ "u9!") - (?\Ử "U92") - (?\ử "u92") - (?\Ữ "U9?") - (?\ữ "u9?") - (?\Ự "U9-.") - (?\ự "u9-.") - (?\Ỳ "Y!") - (?\ỳ "y!") - (?\Ỵ "Y-.") - (?\ỵ "y-.") - (?\Ỷ "Y2") - (?\ỷ "y2") - (?\Ỹ "Y?") - (?\ỹ "y?") - (?\ἀ "a") - (?\ἁ "ha") - (?\ἂ "`a") - (?\ἃ "h`a") - (?\ἄ "a'") - (?\ἅ "ha'") - (?\ἆ "a~") - (?\ἇ "ha~") - (?\Ἀ "A") - (?\Ἁ "hA") - (?\Ἂ "`A") - (?\Ἃ "h`A") - (?\Ἄ "A'") - (?\Ἅ "hA'") - (?\Ἆ "A~") - (?\Ἇ "hA~") - (?\ἑ "he") - (?\Ἑ "hE") - (?\ἱ "hi") - (?\Ἱ "hI") - (?\ὁ "ho") - (?\Ὁ "hO") - (?\ὑ "hu") - (?\Ὑ "hU") - (?\᾿ ",,") - (?\῀ "?*") - (?\῁ "?:") - (?\῍ ",!") - (?\῎ ",'") - (?\῏ "?,") - (?\῝ ";!") - (?\῞ ";'") - (?\῟ "?;") - (?\ῥ "rh") - (?\Ῥ "Rh") - (?\῭ "!:") - (?\` "!*") - (?\῾ ";;") - (?\ " ") - (?\ " ") - (?\ " ") - (?\ " ") - (?\ " ") - (?\ " ") - (?\ " ") - (?\ " ") - (?\ " ") - (?\ " ") - (?\‐ "-") - (?\‑ "-") - (?\– "-") - (?\— "--") - (?\― "-") - (?\‖ "||") - (?\‗ "=2") - (?\‘ "`") - (?\’ "'") - (?\‚ "'") - (?\‛ "'") - (?\“ "\"") - (?\” "\"") - (?\„ "\"") - (?\‟ "\"") - (?\† "/-") - (?\‡ "/=") - (?\• " o ") - (?\․ ".") - (?\‥ "..") - (?\… "...") - (?\‧ "·") - (?\‰ " 0/00") - (?\′ "'") - (?\″ "''") - (?\‴ "'''") - (?\‵ "`") - (?\‶ "``") - (?\‷ "```") - (?\‸ "Ca") - (?\‹ "<") - (?\› ">") - (?\※ ":X") - (?\‼ "!!") - (?\‾ "'-") - (?\⁃ "-") - (?\⁄ "/") - (?\⁈ "?!") - (?\⁉ "!?") - (?\⁰ "^0") - (?\⁴ "^4") - (?\⁵ "^5") - (?\⁶ "^6") - (?\⁷ "^7") - (?\⁸ "^8") - (?\⁹ "^9") - (?\⁺ "^+") - (?\⁻ "^-") - (?\⁼ "^=") - (?\⁽ "^(") - (?\⁾ "^)") - (?\ⁿ "^n") - (?\₀ "_0") - (?\₁ "_1") - (?\₂ "_2") - (?\₃ "_3") - (?\₄ "_4") - (?\₅ "_5") - (?\₆ "_6") - (?\₇ "_7") - (?\₈ "_8") - (?\₉ "_9") - (?\₊ "_+") - (?\₋ "_-") - (?\₌ "_=") - (?\₍ "(") - (?\₎ ")") - (?\₣ "Ff") - (?\₤ "Li") - (?\₧ "Pt") - (?\₩ "W=") - (?\€ "EUR") - (?\℀ "a/c") - (?\℁ "a/s") - (?\℃ "oC") - (?\℅ "c/o") - (?\℆ "c/u") - (?\℉ "oF") - (?\ℊ "g") - (?\ℎ "h") - (?\ℏ "\\hbar") - (?\ℑ "Im") - (?\ℓ "l") - (?\№ "No.") - (?\℗ "PO") - (?\℘ "P") - (?\ℜ "Re") - (?\℞ "Rx") - (?\℠ "(SM)") - (?\℡ "TEL") - (?\™ "(TM)") - (?\Ω "Ohm") - (?\K "K") - (?\Å "Ang.") - (?\℮ "est.") - (?\ℴ "o") - (?\ℵ "Aleph ") - (?\ℶ "Bet ") - (?\ℷ "Gimel ") - (?\ℸ "Dalet ") - (?\⅓ " 1/3") - (?\⅔ " 2/3") - (?\⅕ " 1/5") - (?\⅖ " 2/5") - (?\⅗ " 3/5") - (?\⅘ " 4/5") - (?\⅙ " 1/6") - (?\⅚ " 5/6") - (?\⅛ " 1/8") - (?\⅜ " 3/8") - (?\⅝ " 5/8") - (?\⅞ " 7/8") - (?\⅟ " 1/") - (?\Ⅰ "I") - (?\Ⅱ "II") - (?\Ⅲ "III") - (?\Ⅳ "IV") - (?\Ⅴ "V") - (?\Ⅵ "VI") - (?\Ⅶ "VII") - (?\Ⅷ "VIII") - (?\Ⅸ "IX") - (?\Ⅹ "X") - (?\Ⅺ "XI") - (?\Ⅻ "XII") - (?\Ⅼ "L") - (?\Ⅽ "C") - (?\Ⅾ "D") - (?\Ⅿ "M") - (?\ⅰ "i") - (?\ⅱ "ii") - (?\ⅲ "iii") - (?\ⅳ "iv") - (?\ⅴ "v") - (?\ⅵ "vi") - (?\ⅶ "vii") - (?\ⅷ "viii") - (?\ⅸ "ix") - (?\ⅹ "x") - (?\ⅺ "xi") - (?\ⅻ "xii") - (?\ⅼ "l") - (?\ⅽ "c") - (?\ⅾ "d") - (?\ⅿ "m") - (?\ↀ "1000RCD") - (?\ↁ "5000R") - (?\ↂ "10000R") - (?\← "<-") - (?\↑ "-^") - (?\→ "->") - (?\↓ "-v") - (?\↔ "<->") - (?\↕ "UD") - (?\↖ "<!!") - (?\↗ "//>") - (?\↘ "!!>") - (?\↙ "<//") - (?\↨ "UD-") - (?\↵ "RET") - (?\⇀ ">V") - (?\⇐ "<=") - (?\⇑ "^^") - (?\⇒ "=>") - (?\⇓ "vv") - (?\⇔ "<=>") - (?\∀ "FA") - (?\∂ "\\partial") - (?\∃ "TE") - (?\∅ "{}") - (?\∆ "Delta") - (?\∇ "Nabla") - (?\∈ "(-") - (?\∉ "!(-") - (?\∊ "(-") - (?\∋ "-)") - (?\∌ "!-)") - (?\∍ "-)") - (?\∎ " qed") - (?\∏ "\\prod") - (?\∑ "\\sum") - (?\− " -") - (?\∓ "-/+") - (?\∔ ".+") - (?\∕ "/") - (?\∖ " - ") - (?\∗ "*") - (?\∘ " ° ") - (?\∙ "sb") - (?\√ " SQRT ") - (?\∛ " ROOT³ ") - (?\∜ " ROOT4 ") - (?\∝ "0(") - (?\∞ "infty") - (?\∟ "-L") - (?\∠ "-V") - (?\∥ "PP") - (?\∦ " !PP ") - (?\∧ "AND") - (?\∨ "OR") - (?\∩ "(U") - (?\∪ ")U") - (?\∫ "\\int ") - (?\∬ "DI") - (?\∮ "Io") - (?\∴ ".:") - (?\∵ ":.") - (?\∶ ":R") - (?\∷ "::") - (?\∼ "?1") - (?\∾ "CG") - (?\≃ "?-") - (?\≅ "?=") - (?\≈ "~=") - (?\≉ " !~= ") - (?\≌ "=?") - (?\≓ "HI") - (?\≔ ":=") - (?\≕ "=:") - (?\≠ "!=") - (?\≡ "=3") - (?\≢ " !=3 ") - (?\≤ "=<") - (?\≥ ">=") - (?\≦ ".LE.") - (?\≧ ".GE.") - (?\≨ ".LT.NOT.EQ.") - (?\≩ ".GT.NOT.EQ.") - (?\≪ "<<") - (?\≫ ">>") - (?\≮ "!<") - (?\≯ "!>") - (?\≶ " <> ") - (?\≷ " >< ") - (?\⊂ "(C") - (?\⊃ ")C") - (?\⊄ " !(C ") - (?\⊅ " !)C ") - (?\⊆ "(_") - (?\⊇ ")_") - (?\⊕ "(+)") - (?\⊖ "(-)") - (?\⊗ "(×)") - (?\⊘ "(/)") - (?\⊙ "(·)") - (?\⊚ "(°)") - (?\⊛ "(*)") - (?\⊜ "(=)") - (?\⊝ "(-)") - (?\⊞ "[+]") - (?\⊟ "[-]") - (?\⊠ "[×]") - (?\⊡ "[·]") - (?\⊥ "-T") - (?\⊧ " MODELS ") - (?\⊨ " TRUE ") - (?\⊩ " FORCES ") - (?\⊬ " !PROVES ") - (?\⊭ " NOT TRUE ") - (?\⊮ " !FORCES ") - (?\⊲ " NORMAL SUBGROUP OF ") - (?\⊳ " CONTAINS AS NORMAL SUBGROUP ") - (?\⊴ " NORMAL SUBGROUP OF OR EQUAL TO ") - (?\⊵ " CONTAINS AS NORMAL SUBGROUP OR EQUAL TO ") - (?\⊸ " MULTIMAP ") - (?\⊺ " INTERCALATE ") - (?\⊻ " XOR ") - (?\⊼ " NAND ") - (?\⋅ " · ") - (?\⋖ "<.") - (?\⋗ ">.") - (?\⋘ "<<<") - (?\⋙ ">>>") - (?\⋮ ":3") - (?\⋯ ".3") - (?\⌂ "Eh") - (?\⌇ "~~") - (?\⌈ "<7") - (?\⌉ ">7") - (?\⌊ "7<") - (?\⌋ "7>") - (?\⌐ "NI") - (?\⌒ "(A") - (?\⌕ "TR") - (?\⌘ "88") - (?\⌠ "Iu") - (?\⌡ "Il") - (?\⌢ ":(") - (?\⌣ ":)") - (?\⌤ "|^|") - (?\⌧ "[X]") - (?\〈 "</") - (?\〉 "/>") - (?\␣ "Vs") - (?\⑀ "1h") - (?\⑁ "3h") - (?\⑂ "2h") - (?\⑃ "4h") - (?\⑆ "1j") - (?\⑇ "2j") - (?\⑈ "3j") - (?\⑉ "4j") - (?\① "1-o") - (?\② "2-o") - (?\③ "3-o") - (?\④ "4-o") - (?\⑤ "5-o") - (?\⑥ "6-o") - (?\⑦ "7-o") - (?\⑧ "8-o") - (?\⑨ "9-o") - (?\⑩ "10-o") - (?\⑪ "11-o") - (?\⑫ "12-o") - (?\⑬ "13-o") - (?\⑭ "14-o") - (?\⑮ "15-o") - (?\⑯ "16-o") - (?\⑰ "17-o") - (?\⑱ "18-o") - (?\⑲ "19-o") - (?\⑳ "20-o") - (?\⑴ "(1)") - (?\⑵ "(2)") - (?\⑶ "(3)") - (?\⑷ "(4)") - (?\⑸ "(5)") - (?\⑹ "(6)") - (?\⑺ "(7)") - (?\⑻ "(8)") - (?\⑼ "(9)") - (?\⑽ "(10)") - (?\⑾ "(11)") - (?\⑿ "(12)") - (?\⒀ "(13)") - (?\⒁ "(14)") - (?\⒂ "(15)") - (?\⒃ "(16)") - (?\⒄ "(17)") - (?\⒅ "(18)") - (?\⒆ "(19)") - (?\⒇ "(20)") - (?\⒈ "1.") - (?\⒉ "2.") - (?\⒊ "3.") - (?\⒋ "4.") - (?\⒌ "5.") - (?\⒍ "6.") - (?\⒎ "7.") - (?\⒏ "8.") - (?\⒐ "9.") - (?\⒑ "10.") - (?\⒒ "11.") - (?\⒓ "12.") - (?\⒔ "13.") - (?\⒕ "14.") - (?\⒖ "15.") - (?\⒗ "16.") - (?\⒘ "17.") - (?\⒙ "18.") - (?\⒚ "19.") - (?\⒛ "20.") - (?\⒜ "(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)") - (?\Ⓐ "A-o") - (?\Ⓑ "B-o") - (?\Ⓒ "C-o") - (?\Ⓓ "D-o") - (?\Ⓔ "E-o") - (?\Ⓕ "F-o") - (?\Ⓖ "G-o") - (?\Ⓗ "H-o") - (?\Ⓘ "I-o") - (?\Ⓙ "J-o") - (?\Ⓚ "K-o") - (?\Ⓛ "L-o") - (?\Ⓜ "M-o") - (?\Ⓝ "N-o") - (?\Ⓞ "O-o") - (?\Ⓟ "P-o") - (?\Ⓠ "Q-o") - (?\Ⓡ "R-o") - (?\Ⓢ "S-o") - (?\Ⓣ "T-o") - (?\Ⓤ "U-o") - (?\Ⓥ "V-o") - (?\Ⓦ "W-o") - (?\Ⓧ "X-o") - (?\Ⓨ "Y-o") - (?\Ⓩ "Z-o") - (?\ⓐ "a-o") - (?\ⓑ "b-o") - (?\ⓒ "c-o") - (?\ⓓ "d-o") - (?\ⓔ "e-o") - (?\ⓕ "f-o") - (?\ⓖ "g-o") - (?\ⓗ "h-o") - (?\ⓘ "i-o") - (?\ⓙ "j-o") - (?\ⓚ "k-o") - (?\ⓛ "l-o") - (?\ⓜ "m-o") - (?\ⓝ "n-o") - (?\ⓞ "o-o") - (?\ⓟ "p-o") - (?\ⓠ "q-o") - (?\ⓡ "r-o") - (?\ⓢ "s-o") - (?\ⓣ "t-o") - (?\ⓤ "u-o") - (?\ⓥ "v-o") - (?\ⓦ "w-o") - (?\ⓧ "x-o") - (?\ⓨ "y-o") - (?\ⓩ "z-o") - (?\⓪ "0-o") - (?\─ "-") - (?\━ "=") - (?\│ "|") - (?\┃ "|") - (?\┄ "-") - (?\┅ "=") - (?\┆ "|") - (?\┇ "|") - (?\┈ "-") - (?\┉ "=") - (?\┊ "|") - (?\┋ "|") - (?\┌ "+") - (?\┍ "+") - (?\┎ "+") - (?\┏ "+") - (?\┐ "+") - (?\┑ "+") - (?\┒ "+") - (?\┓ "+") - (?\└ "+") - (?\┕ "+") - (?\┖ "+") - (?\┗ "+") - (?\┘ "+") - (?\┙ "+") - (?\┚ "+") - (?\┛ "+") - (?\├ "+") - (?\┝ "+") - (?\┞ "+") - (?\┟ "+") - (?\┠ "+") - (?\┡ "+") - (?\┢ "+") - (?\┣ "+") - (?\┤ "+") - (?\┥ "+") - (?\┦ "+") - (?\┧ "+") - (?\┨ "+") - (?\┩ "+") - (?\┪ "+") - (?\┫ "+") - (?\┬ "+") - (?\┭ "+") - (?\┮ "+") - (?\┯ "+") - (?\┰ "+") - (?\┱ "+") - (?\┲ "+") - (?\┳ "+") - (?\┴ "+") - (?\┵ "+") - (?\┶ "+") - (?\┷ "+") - (?\┸ "+") - (?\┹ "+") - (?\┺ "+") - (?\┻ "+") - (?\┼ "+") - (?\┽ "+") - (?\┾ "+") - (?\┿ "+") - (?\╀ "+") - (?\╁ "+") - (?\╂ "+") - (?\╃ "+") - (?\╄ "+") - (?\╅ "+") - (?\╆ "+") - (?\╇ "+") - (?\╈ "+") - (?\╉ "+") - (?\╊ "+") - (?\╋ "+") - (?\╌ "+") - (?\╍ "+") - (?\╎ "+") - (?\╏ "+") - (?\═ "+") - (?\║ "+") - (?\╒ "+") - (?\╓ "+") - (?\╔ "+") - (?\╕ "+") - (?\╖ "+") - (?\╗ "+") - (?\╘ "+") - (?\╙ "+") - (?\╚ "+") - (?\╛ "+") - (?\╜ "+") - (?\╝ "+") - (?\╞ "+") - (?\╟ "+") - (?\╠ "+") - (?\╡ "+") - (?\╢ "+") - (?\╣ "+") - (?\╤ "+") - (?\╥ "+") - (?\╦ "+") - (?\╧ "+") - (?\╨ "+") - (?\╩ "+") - (?\╪ "+") - (?\╫ "+") - (?\╬ "+") - (?\╱ "/") - (?\╲ "\\") - (?\▀ "TB") - (?\▄ "LB") - (?\█ "FB") - (?\▌ "lB") - (?\▐ "RB") - (?\░ ".S") - (?\▒ ":S") - (?\▓ "?S") - (?\■ "fS") - (?\□ "OS") - (?\▢ "RO") - (?\▣ "Rr") - (?\▤ "RF") - (?\▥ "RY") - (?\▦ "RH") - (?\▧ "RZ") - (?\▨ "RK") - (?\▩ "RX") - (?\▪ "sB") - (?\▬ "SR") - (?\▭ "Or") - (?\▲ "^") - (?\△ "uT") - (?\▶ "|>") - (?\▷ "Tr") - (?\► "|>") - (?\▼ "v") - (?\▽ "dT") - (?\◀ "<|") - (?\◁ "Tl") - (?\◄ "<|") - (?\◆ "Db") - (?\◇ "Dw") - (?\◊ "LZ") - (?\○ "0m") - (?\◎ "0o") - (?\● "0M") - (?\◐ "0L") - (?\◑ "0R") - (?\◘ "Sn") - (?\◙ "Ic") - (?\◢ "Fd") - (?\◣ "Bd") - (?\◯ "Ci") - (?\★ "*2") - (?\☆ "*1") - (?\☎ "TEL") - (?\☏ "tel") - (?\☜ "<--") - (?\☞ "-->") - (?\☡ "CAUTION ") - (?\☧ "XP") - (?\☹ ":-(") - (?\☺ ":-)") - (?\☻ "(-:") - (?\☼ "SU") - (?\♀ "f.") - (?\♂ "m.") - (?\♠ "cS") - (?\♡ "cH") - (?\♢ "cD") - (?\♣ "cC") - (?\♤ "cS-") - (?\♥ "cH-") - (?\♦ "cD-") - (?\♧ "cC-") - (?\♩ "Md") - (?\♪ "M8") - (?\♫ "M2") - (?\♬ "M16") - (?\♭ "b") - (?\♮ "Mx") - (?\♯ "#") - (?\✓ "X") - (?\✗ "X") - (?\✠ "-X") - (?\ " ") - (?\、 ",_") - (?\。 "._") - (?\〃 "+\"") - (?\〄 "JIS") - (?\々 "*_") - (?\〆 ";_") - (?\〇 "0_") - (?\《 "<+") - (?\》 ">+") - (?\「 "<'") - (?\」 ">'") - (?\『 "<\"") - (?\』 ">\"") - (?\【 "(\"") - (?\】 ")\"") - (?\〒 "=T") - (?\〓 "=_") - (?\〔 "('") - (?\〕 ")'") - (?\〖 "(I") - (?\〗 ")I") - (?\〚 "[[") - (?\〛 "]]") - (?\〜 "-?") - (?\〠 "=T:)") - (?\〿 " ") - (?\ぁ "A5") - (?\あ "a5") - (?\ぃ "I5") - (?\い "i5") - (?\ぅ "U5") - (?\う "u5") - (?\ぇ "E5") - (?\え "e5") - (?\ぉ "O5") - (?\お "o5") - (?\か "ka") - (?\が "ga") - (?\き "ki") - (?\ぎ "gi") - (?\く "ku") - (?\ぐ "gu") - (?\け "ke") - (?\げ "ge") - (?\こ "ko") - (?\ご "go") - (?\さ "sa") - (?\ざ "za") - (?\し "si") - (?\じ "zi") - (?\す "su") - (?\ず "zu") - (?\せ "se") - (?\ぜ "ze") - (?\そ "so") - (?\ぞ "zo") - (?\た "ta") - (?\だ "da") - (?\ち "ti") - (?\ぢ "di") - (?\っ "tU") - (?\つ "tu") - (?\づ "du") - (?\て "te") - (?\で "de") - (?\と "to") - (?\ど "do") - (?\な "na") - (?\に "ni") - (?\ぬ "nu") - (?\ね "ne") - (?\の "no") - (?\は "ha") - (?\ば "ba") - (?\ぱ "pa") - (?\ひ "hi") - (?\び "bi") - (?\ぴ "pi") - (?\ふ "hu") - (?\ぶ "bu") - (?\ぷ "pu") - (?\へ "he") - (?\べ "be") - (?\ぺ "pe") - (?\ほ "ho") - (?\ぼ "bo") - (?\ぽ "po") - (?\ま "ma") - (?\み "mi") - (?\む "mu") - (?\め "me") - (?\も "mo") - (?\ゃ "yA") - (?\や "ya") - (?\ゅ "yU") - (?\ゆ "yu") - (?\ょ "yO") - (?\よ "yo") - (?\ら "ra") - (?\り "ri") - (?\る "ru") - (?\れ "re") - (?\ろ "ro") - (?\ゎ "wA") - (?\わ "wa") - (?\ゐ "wi") - (?\ゑ "we") - (?\を "wo") - (?\ん "n5") - (?\ゔ "vu") - (?\゛ "\"5") - (?\゜ "05") - (?\ゝ "*5") - (?\ゞ "+5") - (?\ァ "a6") - (?\ア "A6") - (?\ィ "i6") - (?\イ "I6") - (?\ゥ "u6") - (?\ウ "U6") - (?\ェ "e6") - (?\エ "E6") - (?\ォ "o6") - (?\オ "O6") - (?\カ "Ka") - (?\ガ "Ga") - (?\キ "Ki") - (?\ギ "Gi") - (?\ク "Ku") - (?\グ "Gu") - (?\ケ "Ke") - (?\ゲ "Ge") - (?\コ "Ko") - (?\ゴ "Go") - (?\サ "Sa") - (?\ザ "Za") - (?\シ "Si") - (?\ジ "Zi") - (?\ス "Su") - (?\ズ "Zu") - (?\セ "Se") - (?\ゼ "Ze") - (?\ソ "So") - (?\ゾ "Zo") - (?\タ "Ta") - (?\ダ "Da") - (?\チ "Ti") - (?\ヂ "Di") - (?\ッ "TU") - (?\ツ "Tu") - (?\ヅ "Du") - (?\テ "Te") - (?\デ "De") - (?\ト "To") - (?\ド "Do") - (?\ナ "Na") - (?\ニ "Ni") - (?\ヌ "Nu") - (?\ネ "Ne") - (?\ノ "No") - (?\ハ "Ha") - (?\バ "Ba") - (?\パ "Pa") - (?\ヒ "Hi") - (?\ビ "Bi") - (?\ピ "Pi") - (?\フ "Hu") - (?\ブ "Bu") - (?\プ "Pu") - (?\ヘ "He") - (?\ベ "Be") - (?\ペ "Pe") - (?\ホ "Ho") - (?\ボ "Bo") - (?\ポ "Po") - (?\マ "Ma") - (?\ミ "Mi") - (?\ム "Mu") - (?\メ "Me") - (?\モ "Mo") - (?\ャ "YA") - (?\ヤ "Ya") - (?\ュ "YU") - (?\ユ "Yu") - (?\ョ "YO") - (?\ヨ "Yo") - (?\ラ "Ra") - (?\リ "Ri") - (?\ル "Ru") - (?\レ "Re") - (?\ロ "Ro") - (?\ヮ "WA") - (?\ワ "Wa") - (?\ヰ "Wi") - (?\ヱ "We") - (?\ヲ "Wo") - (?\ン "N6") - (?\ヴ "Vu") - (?\ヵ "KA") - (?\ヶ "KE") - (?\ヷ "Va") - (?\ヸ "Vi") - (?\ヹ "Ve") - (?\ヺ "Vo") - (?\・ ".6") - (?\ー "-6") - (?\ヽ "*6") - (?\ヾ "+6") - (?\ㄅ "b4") - (?\ㄆ "p4") - (?\ㄇ "m4") - (?\ㄈ "f4") - (?\ㄉ "d4") - (?\ㄊ "t4") - (?\ㄋ "n4") - (?\ㄌ "l4") - (?\ㄍ "g4") - (?\ㄎ "k4") - (?\ㄏ "h4") - (?\ㄐ "j4") - (?\ㄑ "q4") - (?\ㄒ "x4") - (?\ㄓ "zh") - (?\ㄔ "ch") - (?\ㄕ "sh") - (?\ㄖ "r4") - (?\ㄗ "z4") - (?\ㄘ "c4") - (?\ㄙ "s4") - (?\ㄚ "a4") - (?\ㄛ "o4") - (?\ㄜ "e4") - (?\ㄝ "eh4") - (?\ㄞ "ai") - (?\ㄟ "ei") - (?\ㄠ "au") - (?\ㄡ "ou") - (?\ㄢ "an") - (?\ㄣ "en") - (?\ㄤ "aN") - (?\ㄥ "eN") - (?\ㄦ "er") - (?\ㄧ "i4") - (?\ㄨ "u4") - (?\ㄩ "iu") - (?\ㄪ "v4") - (?\ㄫ "nG") - (?\ㄬ "gn") - (?\㈜ "(JU)") - (?\㈠ "1c") - (?\㈡ "2c") - (?\㈢ "3c") - (?\㈣ "4c") - (?\㈤ "5c") - (?\㈥ "6c") - (?\㈦ "7c") - (?\㈧ "8c") - (?\㈨ "9c") - (?\㈩ "10c") - (?\㉿ "KSC") - (?\㏂ "am") - (?\㏘ "pm") - (?\ff "ff") - (?\fi "fi") - (?\fl "fl") - (?\ffi "ffi") - (?\ffl "ffl") - (?\ſt "St") - (?\st "st") - (?\ﹽ "3+;") - (?\ﺂ "aM.") - (?\ﺄ "aH.") - (?\ﺈ "ah.") - (?\ﺍ "a+-") - (?\ﺎ "a+.") - (?\ﺏ "b+-") - (?\ﺐ "b+.") - (?\ﺑ "b+,") - (?\ﺒ "b+;") - (?\ﺓ "tm-") - (?\ﺔ "tm.") - (?\ﺕ "t+-") - (?\ﺖ "t+.") - (?\ﺗ "t+,") - (?\ﺘ "t+;") - (?\ﺙ "tk-") - (?\ﺚ "tk.") - (?\ﺛ "tk,") - (?\ﺜ "tk;") - (?\ﺝ "g+-") - (?\ﺞ "g+.") - (?\ﺟ "g+,") - (?\ﺠ "g+;") - (?\ﺡ "hk-") - (?\ﺢ "hk.") - (?\ﺣ "hk,") - (?\ﺤ "hk;") - (?\ﺥ "x+-") - (?\ﺦ "x+.") - (?\ﺧ "x+,") - (?\ﺨ "x+;") - (?\ﺩ "d+-") - (?\ﺪ "d+.") - (?\ﺫ "dk-") - (?\ﺬ "dk.") - (?\ﺭ "r+-") - (?\ﺮ "r+.") - (?\ﺯ "z+-") - (?\ﺰ "z+.") - (?\ﺱ "s+-") - (?\ﺲ "s+.") - (?\ﺳ "s+,") - (?\ﺴ "s+;") - (?\ﺵ "sn-") - (?\ﺶ "sn.") - (?\ﺷ "sn,") - (?\ﺸ "sn;") - (?\ﺹ "c+-") - (?\ﺺ "c+.") - (?\ﺻ "c+,") - (?\ﺼ "c+;") - (?\ﺽ "dd-") - (?\ﺾ "dd.") - (?\ﺿ "dd,") - (?\ﻀ "dd;") - (?\ﻁ "tj-") - (?\ﻂ "tj.") - (?\ﻃ "tj,") - (?\ﻄ "tj;") - (?\ﻅ "zH-") - (?\ﻆ "zH.") - (?\ﻇ "zH,") - (?\ﻈ "zH;") - (?\ﻉ "e+-") - (?\ﻊ "e+.") - (?\ﻋ "e+,") - (?\ﻌ "e+;") - (?\ﻍ "i+-") - (?\ﻎ "i+.") - (?\ﻏ "i+,") - (?\ﻐ "i+;") - (?\ﻑ "f+-") - (?\ﻒ "f+.") - (?\ﻓ "f+,") - (?\ﻔ "f+;") - (?\ﻕ "q+-") - (?\ﻖ "q+.") - (?\ﻗ "q+,") - (?\ﻘ "q+;") - (?\ﻙ "k+-") - (?\ﻚ "k+.") - (?\ﻛ "k+,") - (?\ﻜ "k+;") - (?\ﻝ "l+-") - (?\ﻞ "l+.") - (?\ﻟ "l+,") - (?\ﻠ "l+;") - (?\ﻡ "m+-") - (?\ﻢ "m+.") - (?\ﻣ "m+,") - (?\ﻤ "m+;") - (?\ﻥ "n+-") - (?\ﻦ "n+.") - (?\ﻧ "n+,") - (?\ﻨ "n+;") - (?\ﻩ "h+-") - (?\ﻪ "h+.") - (?\ﻫ "h+,") - (?\ﻬ "h+;") - (?\ﻭ "w+-") - (?\ﻮ "w+.") - (?\ﻯ "j+-") - (?\ﻰ "j+.") - (?\ﻱ "y+-") - (?\ﻲ "y+.") - (?\ﻳ "y+,") - (?\ﻴ "y+;") - (?\ﻵ "lM-") - (?\ﻶ "lM.") - (?\ﻷ "lH-") - (?\ﻸ "lH.") - (?\ﻹ "lh-") - (?\ﻺ "lh.") - (?\ﻻ "la-") - (?\ﻼ "la.") - (?\! "!") - (?\" "\"") - (?\# "#") - (?\$ "$") - (?\% "%") - (?\& "&") - (?\' "'") - (?\( "(") - (?\) ")") - (?\* "*") - (?\+ "+") - (?\, ",") - (?\- "-") - (?\. ".") - (?\/ "/") - (?\0 "0") - (?\1 "1") - (?\2 "2") - (?\3 "3") - (?\4 "4") - (?\5 "5") - (?\6 "6") - (?\7 "7") - (?\8 "8") - (?\9 "9") - (?\: ":") - (?\; ";") - (?\< "<") - (?\= "=") - (?\> ">") - (?\? "?") - (?\@ "@") - (?\A "A") - (?\B "B") - (?\C "C") - (?\D "D") - (?\E "E") - (?\F "F") - (?\G "G") - (?\H "H") - (?\I "I") - (?\J "J") - (?\K "K") - (?\L "L") - (?\M "M") - (?\N "N") - (?\O "O") - (?\P "P") - (?\Q "Q") - (?\R "R") - (?\S "S") - (?\T "T") - (?\U "U") - (?\V "V") - (?\W "W") - (?\X "X") - (?\Y "Y") - (?\Z "Z") - (?\[ "[") - (?\\ "\\") - (?\] "]") - (?\^ "^") - (?\_ "_") - (?\` "`") - (?\a "a") - (?\b "b") - (?\c "c") - (?\d "d") - (?\e "e") - (?\f "f") - (?\g "g") - (?\h "h") - (?\i "i") - (?\j "j") - (?\k "k") - (?\l "l") - (?\m "m") - (?\n "n") - (?\o "o") - (?\p "p") - (?\q "q") - (?\r "r") - (?\s "s") - (?\t "t") - (?\u "u") - (?\v "v") - (?\w "w") - (?\x "x") - (?\y "y") - (?\z "z") - (?\{ "{") - (?\| "|") - (?\} "}") - (?\~ "~") - (?\。 ".") - (?\「 "\"") - (?\」 "\"") - (?\、 ",") - ;; Not from Lynx - (? "") - (?� "?"))))) + (let ((latin1-display-format "%s")) + (mapc + (lambda (l) + (or (char-displayable-p (car l)) + (apply 'latin1-display-char l))) + ;; Table derived by running Lynx on a suitable list of + ;; characters in a utf-8 file, except for some added by + ;; hand at the end. + '((?\Ā "A") + (?\ā "a") + (?\Ă "A") + (?\ă "a") + (?\Ą "A") + (?\ą "a") + (?\Ć "C") + (?\ć "c") + (?\Ĉ "C") + (?\ĉ "c") + (?\Ċ "C") + (?\ċ "c") + (?\Č "C") + (?\č "c") + (?\Ď "D") + (?\ď "d") + (?\Đ "Ð") + (?\đ "d/") + (?\Ē "E") + (?\ē "e") + (?\Ĕ "E") + (?\ĕ "e") + (?\Ė "E") + (?\ė "e") + (?\Ę "E") + (?\ę "e") + (?\Ě "E") + (?\ě "e") + (?\Ĝ "G") + (?\ĝ "g") + (?\Ğ "G") + (?\ğ "g") + (?\Ġ "G") + (?\ġ "g") + (?\Ģ "G") + (?\ģ "g") + (?\Ĥ "H") + (?\ĥ "h") + (?\Ħ "H/") + (?\ħ "H") + (?\Ĩ "I") + (?\ĩ "i") + (?\Ī "I") + (?\ī "i") + (?\Ĭ "I") + (?\ĭ "i") + (?\Į "I") + (?\į "i") + (?\İ "I") + (?\ı "i") + (?\IJ "IJ") + (?\ij "ij") + (?\Ĵ "J") + (?\ĵ "j") + (?\Ķ "K") + (?\ķ "k") + (?\ĸ "kk") + (?\Ĺ "L") + (?\ĺ "l") + (?\Ļ "L") + (?\ļ "l") + (?\Ľ "L") + (?\ľ "l") + (?\Ŀ "L.") + (?\ŀ "l.") + (?\Ł "L/") + (?\ł "l/") + (?\Ń "N") + (?\ń "n") + (?\Ņ "N") + (?\ņ "n") + (?\Ň "N") + (?\ň "n") + (?\ʼn "'n") + (?\Ŋ "NG") + (?\ŋ "N") + (?\Ō "O") + (?\ō "o") + (?\Ŏ "O") + (?\ŏ "o") + (?\Ő "O\"") + (?\ő "o\"") + (?\Œ "OE") + (?\œ "oe") + (?\Ŕ "R") + (?\ŕ "r") + (?\Ŗ "R") + (?\ŗ "r") + (?\Ř "R") + (?\ř "r") + (?\Ś "S") + (?\ś "s") + (?\Ŝ "S") + (?\ŝ "s") + (?\Ş "S") + (?\ş "s") + (?\Š "S") + (?\š "s") + (?\Ţ "T") + (?\ţ "t") + (?\Ť "T") + (?\ť "t") + (?\Ŧ "T/") + (?\ŧ "t/") + (?\Ũ "U") + (?\ũ "u") + (?\Ū "U") + (?\ū "u") + (?\Ŭ "U") + (?\ŭ "u") + (?\Ů "U") + (?\ů "u") + (?\Ű "U\"") + (?\ű "u\"") + (?\Ų "U") + (?\ų "u") + (?\Ŵ "W") + (?\ŵ "w") + (?\Ŷ "Y") + (?\ŷ "y") + (?\Ÿ "Y") + (?\Ź "Z") + (?\ź "z") + (?\Ż "Z") + (?\ż "z") + (?\Ž "Z") + (?\ž "z") + (?\ſ "s1") + (?\Ƈ "C2") + (?\ƈ "c2") + (?\Ƒ "F2") + (?\ƒ " f") + (?\Ƙ "K2") + (?\ƙ "k2") + (?\Ơ "O9") + (?\ơ "o9") + (?\Ƣ "OI") + (?\ƣ "oi") + (?\Ʀ "yr") + (?\Ư "U9") + (?\ư "u9") + (?\Ƶ "Z/") + (?\ƶ "z/") + (?\Ʒ "ED") + (?\Ǎ "A") + (?\ǎ "a") + (?\Ǐ "I") + (?\ǐ "i") + (?\Ǒ "O") + (?\ǒ "o") + (?\Ǔ "U") + (?\ǔ "u") + (?\Ǖ "U:-") + (?\ǖ "u:-") + (?\Ǘ "U:'") + (?\ǘ "u:'") + (?\Ǚ "U:<") + (?\ǚ "u:<") + (?\Ǜ "U:!") + (?\ǜ "u:!") + (?\Ǟ "A1") + (?\ǟ "a1") + (?\Ǡ "A7") + (?\ǡ "a7") + (?\Ǣ "A3") + (?\ǣ "a3") + (?\Ǥ "G/") + (?\ǥ "g/") + (?\Ǧ "G") + (?\ǧ "g") + (?\Ǩ "K") + (?\ǩ "k") + (?\Ǫ "O") + (?\ǫ "o") + (?\Ǭ "O1") + (?\ǭ "o1") + (?\Ǯ "EZ") + (?\ǯ "ez") + (?\ǰ "j") + (?\Ǵ "G") + (?\ǵ "g") + (?\Ǻ "AA'") + (?\ǻ "aa'") + (?\Ǽ "AE'") + (?\ǽ "ae'") + (?\Ǿ "O/'") + (?\ǿ "o/'") + (?\Ȁ "A!!") + (?\ȁ "a!!") + (?\Ȃ "A)") + (?\ȃ "a)") + (?\Ȅ "E!!") + (?\ȅ "e!!") + (?\Ȇ "E)") + (?\ȇ "e)") + (?\Ȉ "I!!") + (?\ȉ "i!!") + (?\Ȋ "I)") + (?\ȋ "i)") + (?\Ȍ "O!!") + (?\ȍ "o!!") + (?\Ȏ "O)") + (?\ȏ "o)") + (?\Ȑ "R!!") + (?\ȑ "r!!") + (?\Ȓ "R)") + (?\ȓ "r)") + (?\Ȕ "U!!") + (?\ȕ "u!!") + (?\Ȗ "U)") + (?\ȗ "u)") + (?\ȝ "Z") + (?\ɑ "A") + (?\ɒ "A.") + (?\ɓ "b`") + (?\ɔ "O") + (?\ɖ "d.") + (?\ɗ "d`") + (?\ɘ "@<umd>") + (?\ə "@") + (?\ɚ "R") + (?\ɛ "E") + (?\ɜ "V\"") + (?\ɝ "R<umd>") + (?\ɞ "O\"") + (?\ɟ "J") + (?\ɠ "g`") + (?\ɡ "g") + (?\ɢ "G") + (?\ɣ "Q") + (?\ɤ "o-") + (?\ɥ "j<rnd>") + (?\ɦ "h<?>") + (?\ɨ "i\"") + (?\ɩ "I") + (?\ɪ "I") + (?\ɫ "L") + (?\ɬ "L") + (?\ɭ "l.") + (?\ɮ "z<lat>") + (?\ɯ "u-") + (?\ɰ "j<vel>") + (?\ɱ "M") + (?\ɳ "n.") + (?\ɴ "n\"") + (?\ɵ "@.") + (?\ɶ "&.") + (?\ɷ "U") + (?\ɹ "r") + (?\ɺ "*<lat>") + (?\ɻ "r.") + (?\ɽ "*.") + (?\ɾ "*") + (?\ʀ "R") + (?\ʁ "g\"") + (?\ʂ "s.") + (?\ʃ "S") + (?\ʄ "J`") + (?\ʇ "t!") + (?\ʈ "t.") + (?\ʉ "u\"") + (?\ʊ "U") + (?\ʋ "r<lbd>") + (?\ʌ "V") + (?\ʍ "w<vls>") + (?\ʎ "l^") + (?\ʏ "I.") + (?\ʐ "z.") + (?\ʒ "Z") + (?\ʔ "?") + (?\ʕ "H<vcd>") + (?\ʖ "l!") + (?\ʗ "c!") + (?\ʘ "p!") + (?\ʙ "b<trl>") + (?\ʛ "G`") + (?\ʝ "j") + (?\ʞ "k!") + (?\ʟ "L") + (?\ʠ "q`") + (?\ʤ "d3") + (?\ʦ "ts") + (?\ʧ "tS") + (?\ʰ "<h>") + (?\ʱ "<?>") + (?\ʲ ";") + (?\ʳ "<r>") + (?\ʷ "<w>") + (?\ʻ ";S") + (?\ʼ "`") + (?\ˆ "^") + (?\ˇ "'<") + (?\ˈ "|") + (?\ˉ "1-") + (?\ˋ "1!") + (?\ː ":") + (?\ˑ ":\\") + (?\˖ "+") + (?\˗ "-") + (?\˘ "'(") + (?\˙ "'.") + (?\˚ "'0") + (?\˛ "';") + (?\˜ "~") + (?\˝ "'\"") + (?\˥ "_T") + (?\˦ "_H") + (?\˧ "_M") + (?\˨ "_L") + (?\˩ "_B") + (?\ˬ "_v") + (?\ˮ "''") + (?\̀ "`") + (?\́ "'") + (?\̂ "^") + (?\̃ "~") + (?\̄ "¯") + (?\̇ "·") + (?\̈ "¨") + (?\̊ "°") + (?\̋ "''") + (?\̍ "|") + (?\̎ "||") + (?\̏ "``") + (?\̡ ";") + (?\̢ ".") + (?\̣ ".") + (?\̤ "<?>") + (?\̥ "<o>") + (?\̦ ",") + (?\̧ "¸") + (?\̩ "-") + (?\̪ "[") + (?\̫ "<w>") + (?\̴ "~") + (?\̷ "/") + (?\̸ "/") + (?\̀ "`") + (?\́ "'") + (?\͂ "~") + (?\̈́ "'%") + (?\ͅ "j3") + (?\͇ "=") + (?\͠ "~~") + (?\ʹ "'") + (?\͵ ",") + (?\ͺ "j3") + (?\; "?%") + (?\΄ "'*") + (?\΅ "'%") + (?\Ά "A'") + (?\· "·") + (?\Έ "E'") + (?\Ή "Y%") + (?\Ί "I'") + (?\Ό "O'") + (?\Ύ "U%") + (?\Ώ "W%") + (?\ΐ "i3") + (?\Α "A") + (?\Β "B") + (?\Γ "G") + (?\Δ "D") + (?\Ε "E") + (?\Ζ "Z") + (?\Η "Y") + (?\Θ "TH") + (?\Ι "I") + (?\Κ "K") + (?\Λ "L") + (?\Μ "M") + (?\Ν "N") + (?\Ξ "C") + (?\Ο "O") + (?\Π "P") + (?\Ρ "R") + (?\Σ "S") + (?\Τ "T") + (?\Υ "U") + (?\Φ "F") + (?\Χ "X") + (?\Ψ "Q") + (?\Ω "W*") + (?\Ϊ "J") + (?\Ϋ "V*") + (?\ά "a'") + (?\έ "e'") + (?\ή "y%") + (?\ί "i'") + (?\ΰ "u3") + (?\α "a") + (?\β "b") + (?\γ "g") + (?\δ "d") + (?\ε "e") + (?\ζ "z") + (?\η "y") + (?\θ "th") + (?\ι "i") + (?\κ "k") + (?\λ "l") + (?\μ "µ") + (?\ν "n") + (?\ξ "c") + (?\ο "o") + (?\π "p") + (?\ρ "r") + (?\ς "*s") + (?\σ "s") + (?\τ "t") + (?\υ "u") + (?\φ "f") + (?\χ "x") + (?\ψ "q") + (?\ω "w") + (?\ϊ "j") + (?\ϋ "v*") + (?\ό "o'") + (?\ύ "u%") + (?\ώ "w%") + (?\ϐ "beta ") + (?\ϑ "theta ") + (?\ϒ "upsi ") + (?\ϕ "phi ") + (?\ϖ "pi ") + (?\ϗ "k.") + (?\Ϛ "T3") + (?\ϛ "t3") + (?\Ϝ "M3") + (?\ϝ "m3") + (?\Ϟ "K3") + (?\ϟ "k3") + (?\Ϡ "P3") + (?\ϡ "p3") + (?\ϰ "kappa ") + (?\ϱ "rho ") + (?\ϳ "J") + (?\ϴ "'%") + (?\ϵ "j3") + (?\Ё "IO") + (?\Ђ "D%") + (?\Ѓ "G%") + (?\Є "IE") + (?\Ѕ "DS") + (?\І "II") + (?\Ї "YI") + (?\Ј "J%") + (?\Љ "LJ") + (?\Њ "NJ") + (?\Ћ "Ts") + (?\Ќ "KJ") + (?\Ў "V%") + (?\Џ "DZ") + (?\А "A") + (?\Б "B") + (?\В "V") + (?\Г "G") + (?\Д "D") + (?\Е "E") + (?\Ж "ZH") + (?\З "Z") + (?\И "I") + (?\Й "J") + (?\К "K") + (?\Л "L") + (?\М "M") + (?\Н "N") + (?\О "O") + (?\П "P") + (?\Р "R") + (?\С "S") + (?\Т "T") + (?\У "U") + (?\Ф "F") + (?\Х "H") + (?\Ц "C") + (?\Ч "CH") + (?\Ш "SH") + (?\Щ "SCH") + (?\Ъ "\"") + (?\Ы "Y") + (?\Ь "'") + (?\Э "`E") + (?\Ю "YU") + (?\Я "YA") + (?\а "a") + (?\б "b") + (?\в "v") + (?\г "g") + (?\д "d") + (?\е "e") + (?\ж "zh") + (?\з "z") + (?\и "i") + (?\й "j") + (?\к "k") + (?\л "l") + (?\м "m") + (?\н "n") + (?\о "o") + (?\п "p") + (?\р "r") + (?\с "s") + (?\т "t") + (?\у "u") + (?\ф "f") + (?\х "h") + (?\ц "c") + (?\ч "ch") + (?\ш "sh") + (?\щ "sch") + (?\ъ "\"") + (?\ы "y") + (?\ь "'") + (?\э "`e") + (?\ю "yu") + (?\я "ya") + (?\ё "io") + (?\ђ "d%") + (?\ѓ "g%") + (?\є "ie") + (?\ѕ "ds") + (?\і "ii") + (?\ї "yi") + (?\ј "j%") + (?\љ "lj") + (?\њ "nj") + (?\ћ "ts") + (?\ќ "kj") + (?\ў "v%") + (?\џ "dz") + (?\Ѣ "Y3") + (?\ѣ "y3") + (?\Ѫ "O3") + (?\ѫ "o3") + (?\Ѳ "F3") + (?\ѳ "f3") + (?\Ѵ "V3") + (?\ѵ "v3") + (?\Ҁ "C3") + (?\ҁ "c3") + (?\Ґ "G3") + (?\ґ "g3") + (?\Ӕ "AE") + (?\ӕ "ae") + (?\ִ "i") + (?\ַ "a") + (?\ָ "o") + (?\ּ "u") + (?\ֿ "h") + (?\ׂ ":") + (?\א "#") + (?\ב "B+") + (?\ג "G+") + (?\ד "D+") + (?\ה "H+") + (?\ו "W+") + (?\ז "Z+") + (?\ח "X+") + (?\ט "Tj") + (?\י "J+") + (?\ך "K%") + (?\כ "K+") + (?\ל "L+") + (?\ם "M%") + (?\מ "M+") + (?\ן "N%") + (?\נ "N+") + (?\ס "S+") + (?\ע "E+") + (?\ף "P%") + (?\פ "P+") + (?\ץ "Zj") + (?\צ "ZJ") + (?\ק "Q+") + (?\ר "R+") + (?\ש "Sh") + (?\ת "T+") + (?\װ "v") + (?\ױ "oy") + (?\ײ "ey") + (?\، ",+") + (?\؛ ";+") + (?\؟ "?+") + (?\ء "H'") + (?\آ "aM") + (?\أ "aH") + (?\ؤ "wH") + (?\إ "ah") + (?\ئ "yH") + (?\ا "a+") + (?\ب "b+") + (?\ة "tm") + (?\ت "t+") + (?\ث "tk") + (?\ج "g+") + (?\ح "hk") + (?\خ "x+") + (?\د "d+") + (?\ذ "dk") + (?\ر "r+") + (?\ز "z+") + (?\س "s+") + (?\ش "sn") + (?\ص "c+") + (?\ض "dd") + (?\ط "tj") + (?\ظ "zH") + (?\ع "e+") + (?\غ "i+") + (?\ـ "++") + (?\ف "f+") + (?\ق "q+") + (?\ك "k+") + (?\ل "l+") + (?\م "m+") + (?\ن "n+") + (?\ه "h+") + (?\و "w+") + (?\ى "j+") + (?\ي "y+") + (?\ً ":+") + (?\ٌ "\"+") + (?\ٍ "=+") + (?\َ "/+") + (?\ُ "'+") + (?\ِ "1+") + (?\ّ "3+") + (?\ْ "0+") + (?\٠ "0a") + (?\١ "1a") + (?\٢ "2a") + (?\٣ "3a") + (?\٤ "4a") + (?\٥ "5a") + (?\٦ "6a") + (?\٧ "7a") + (?\٨ "8a") + (?\٩ "9a") + (?\ٰ "aS") + (?\پ "p+") + (?\ځ "hH") + (?\چ "tc") + (?\ژ "zj") + (?\ڤ "v+") + (?\گ "gf") + (?\۰ "0a") + (?\۱ "1a") + (?\۲ "2a") + (?\۳ "3a") + (?\۴ "4a") + (?\۵ "5a") + (?\۶ "6a") + (?\۷ "7a") + (?\۸ "8a") + (?\۹ "9a") + (?\ሀ "he") + (?\ሁ "hu") + (?\ሂ "hi") + (?\ሃ "ha") + (?\ሄ "hE") + (?\ህ "h") + (?\ሆ "ho") + (?\ለ "le") + (?\ሉ "lu") + (?\ሊ "li") + (?\ላ "la") + (?\ሌ "lE") + (?\ል "l") + (?\ሎ "lo") + (?\ሏ "lWa") + (?\ሐ "He") + (?\ሑ "Hu") + (?\ሒ "Hi") + (?\ሓ "Ha") + (?\ሔ "HE") + (?\ሕ "H") + (?\ሖ "Ho") + (?\ሗ "HWa") + (?\መ "me") + (?\ሙ "mu") + (?\ሚ "mi") + (?\ማ "ma") + (?\ሜ "mE") + (?\ም "m") + (?\ሞ "mo") + (?\ሟ "mWa") + (?\ሠ "`se") + (?\ሡ "`su") + (?\ሢ "`si") + (?\ሣ "`sa") + (?\ሤ "`sE") + (?\ሥ "`s") + (?\ሦ "`so") + (?\ሧ "`sWa") + (?\ረ "re") + (?\ሩ "ru") + (?\ሪ "ri") + (?\ራ "ra") + (?\ሬ "rE") + (?\ር "r") + (?\ሮ "ro") + (?\ሯ "rWa") + (?\ሰ "se") + (?\ሱ "su") + (?\ሲ "si") + (?\ሳ "sa") + (?\ሴ "sE") + (?\ስ "s") + (?\ሶ "so") + (?\ሷ "sWa") + (?\ሸ "xe") + (?\ሹ "xu") + (?\ሺ "xi") + (?\ሻ "xa") + (?\ሼ "xE") + (?\ሽ "xa") + (?\ሾ "xo") + (?\ሿ "xWa") + (?\ቀ "qe") + (?\ቁ "qu") + (?\ቂ "qi") + (?\ቃ "qa") + (?\ቄ "qE") + (?\ቅ "q") + (?\ቆ "qo") + (?\ቈ "qWe") + (?\ቊ "qWi") + (?\ቋ "qWa") + (?\ቌ "qWE") + (?\ቍ "qW") + (?\ቐ "Qe") + (?\ቑ "Qu") + (?\ቒ "Qi") + (?\ቓ "Qa") + (?\ቔ "QE") + (?\ቕ "Q") + (?\ቖ "Qo") + (?\ቘ "QWe") + (?\ቚ "QWi") + (?\ቛ "QWa") + (?\ቜ "QWE") + (?\ቝ "QW") + (?\በ "be") + (?\ቡ "bu") + (?\ቢ "bi") + (?\ባ "ba") + (?\ቤ "bE") + (?\ብ "b") + (?\ቦ "bo") + (?\ቧ "bWa") + (?\ቨ "ve") + (?\ቩ "vu") + (?\ቪ "vi") + (?\ቫ "va") + (?\ቬ "vE") + (?\ቭ "v") + (?\ቮ "vo") + (?\ቯ "vWa") + (?\ተ "te") + (?\ቱ "tu") + (?\ቲ "ti") + (?\ታ "ta") + (?\ቴ "tE") + (?\ት "t") + (?\ቶ "to") + (?\ቷ "tWa") + (?\ቸ "ce") + (?\ቹ "cu") + (?\ቺ "ci") + (?\ቻ "ca") + (?\ቼ "cE") + (?\ች "c") + (?\ቾ "co") + (?\ቿ "cWa") + (?\ኀ "`he") + (?\ኁ "`hu") + (?\ኂ "`hi") + (?\ኃ "`ha") + (?\ኄ "`hE") + (?\ኅ "`h") + (?\ኆ "`ho") + (?\ኈ "hWe") + (?\ኊ "hWi") + (?\ኋ "hWa") + (?\ኌ "hWE") + (?\ኍ "hW") + (?\ነ "na") + (?\ኑ "nu") + (?\ኒ "ni") + (?\ና "na") + (?\ኔ "nE") + (?\ን "n") + (?\ኖ "no") + (?\ኗ "nWa") + (?\ኘ "Ne") + (?\ኙ "Nu") + (?\ኚ "Ni") + (?\ኛ "Na") + (?\ኜ "NE") + (?\ኝ "N") + (?\ኞ "No") + (?\ኟ "NWa") + (?\አ "e") + (?\ኡ "u") + (?\ኢ "i") + (?\ኣ "a") + (?\ኤ "E") + (?\እ "I") + (?\ኦ "o") + (?\ኧ "e3") + (?\ከ "ke") + (?\ኩ "ku") + (?\ኪ "ki") + (?\ካ "ka") + (?\ኬ "kE") + (?\ክ "k") + (?\ኮ "ko") + (?\ኰ "kWe") + (?\ኲ "kWi") + (?\ኳ "kWa") + (?\ኴ "kWE") + (?\ኵ "kW") + (?\ኸ "Ke") + (?\ኹ "Ku") + (?\ኺ "Ki") + (?\ኻ "Ka") + (?\ኼ "KE") + (?\ኽ "K") + (?\ኾ "Ko") + (?\ዀ "KWe") + (?\ዂ "KWi") + (?\ዃ "KWa") + (?\ዄ "KWE") + (?\ዅ "KW") + (?\ወ "we") + (?\ዉ "wu") + (?\ዊ "wi") + (?\ዋ "wa") + (?\ዌ "wE") + (?\ው "w") + (?\ዎ "wo") + (?\ዐ "`e") + (?\ዑ "`u") + (?\ዒ "`i") + (?\ዓ "`a") + (?\ዔ "`E") + (?\ዕ "`I") + (?\ዖ "`o") + (?\ዘ "ze") + (?\ዙ "zu") + (?\ዚ "zi") + (?\ዛ "za") + (?\ዜ "zE") + (?\ዝ "z") + (?\ዞ "zo") + (?\ዟ "zWa") + (?\ዠ "Ze") + (?\ዡ "Zu") + (?\ዢ "Zi") + (?\ዣ "Za") + (?\ዤ "ZE") + (?\ዥ "Z") + (?\ዦ "Zo") + (?\ዧ "ZWa") + (?\የ "ye") + (?\ዩ "yu") + (?\ዪ "yi") + (?\ያ "ya") + (?\ዬ "yE") + (?\ይ "y") + (?\ዮ "yo") + (?\ዯ "yWa") + (?\ደ "de") + (?\ዱ "du") + (?\ዲ "di") + (?\ዳ "da") + (?\ዴ "dE") + (?\ድ "d") + (?\ዶ "do") + (?\ዷ "dWa") + (?\ዸ "De") + (?\ዹ "Du") + (?\ዺ "Di") + (?\ዻ "Da") + (?\ዼ "DE") + (?\ዽ "D") + (?\ዾ "Do") + (?\ዿ "DWa") + (?\ጀ "je") + (?\ጁ "ju") + (?\ጂ "ji") + (?\ጃ "ja") + (?\ጄ "jE") + (?\ጅ "j") + (?\ጆ "jo") + (?\ጇ "jWa") + (?\ገ "ga") + (?\ጉ "gu") + (?\ጊ "gi") + (?\ጋ "ga") + (?\ጌ "gE") + (?\ግ "g") + (?\ጎ "go") + (?\ጐ "gWu") + (?\ጒ "gWi") + (?\ጓ "gWa") + (?\ጔ "gWE") + (?\ጕ "gW") + (?\ጘ "Ge") + (?\ጙ "Gu") + (?\ጚ "Gi") + (?\ጛ "Ga") + (?\ጜ "GE") + (?\ጝ "G") + (?\ጞ "Go") + (?\ጟ "GWa") + (?\ጠ "Te") + (?\ጡ "Tu") + (?\ጢ "Ti") + (?\ጣ "Ta") + (?\ጤ "TE") + (?\ጥ "T") + (?\ጦ "To") + (?\ጧ "TWa") + (?\ጨ "Ce") + (?\ጩ "Ca") + (?\ጪ "Cu") + (?\ጫ "Ca") + (?\ጬ "CE") + (?\ጭ "C") + (?\ጮ "Co") + (?\ጯ "CWa") + (?\ጰ "Pe") + (?\ጱ "Pu") + (?\ጲ "Pi") + (?\ጳ "Pa") + (?\ጴ "PE") + (?\ጵ "P") + (?\ጶ "Po") + (?\ጷ "PWa") + (?\ጸ "SWe") + (?\ጹ "SWu") + (?\ጺ "SWi") + (?\ጻ "SWa") + (?\ጼ "SWE") + (?\ጽ "SW") + (?\ጾ "SWo") + (?\ጿ "SWa") + (?\ፀ "`Sa") + (?\ፁ "`Su") + (?\ፂ "`Si") + (?\ፃ "`Sa") + (?\ፄ "`SE") + (?\ፅ "`S") + (?\ፆ "`So") + (?\ፈ "fa") + (?\ፉ "fu") + (?\ፊ "fi") + (?\ፋ "fa") + (?\ፌ "fE") + (?\ፍ "o") + (?\ፎ "fo") + (?\ፏ "fWa") + (?\ፐ "pe") + (?\ፑ "pu") + (?\ፒ "pi") + (?\ፓ "pa") + (?\ፔ "pE") + (?\ፕ "p") + (?\ፖ "po") + (?\ፗ "pWa") + (?\ፘ "mYa") + (?\ፙ "rYa") + (?\ፚ "fYa") + (?\፠ " ") + (?\፡ ":") + (?\። "::") + (?\፣ ",") + (?\፤ ";") + (?\፥ "-:") + (?\፦ ":-") + (?\፧ "`?") + (?\፨ ":|:") + (?\፩ "`1") + (?\፪ "`2") + (?\፫ "`3") + (?\፬ "`4") + (?\፭ "`5") + (?\፮ "`6") + (?\፯ "`7") + (?\፰ "`8") + (?\፱ "`9") + (?\፲ "`10") + (?\፳ "`20") + (?\፴ "`30") + (?\፵ "`40") + (?\፶ "`50") + (?\፷ "`60") + (?\፸ "`70") + (?\፹ "`80") + (?\፺ "`90") + (?\፻ "`100") + (?\፼ "`10000") + (?\Ḁ "A-0") + (?\ḁ "a-0") + (?\Ḃ "B.") + (?\ḃ "b.") + (?\Ḅ "B-.") + (?\ḅ "b-.") + (?\Ḇ "B_") + (?\ḇ "b_") + (?\Ḉ "C,'") + (?\ḉ "c,'") + (?\Ḋ "D.") + (?\ḋ "d.") + (?\Ḍ "D-.") + (?\ḍ "d-.") + (?\Ḏ "D_") + (?\ḏ "d_") + (?\Ḑ "D,") + (?\ḑ "d,") + (?\Ḓ "D->") + (?\ḓ "d->") + (?\Ḕ "E-!") + (?\ḕ "e-!") + (?\Ḗ "E-'") + (?\ḗ "e-'") + (?\Ḙ "E->") + (?\ḙ "e->") + (?\Ḛ "E-?") + (?\ḛ "e-?") + (?\Ḝ "E,(") + (?\ḝ "e,(") + (?\Ḟ "F.") + (?\ḟ "f.") + (?\Ḡ "G-") + (?\ḡ "g-") + (?\Ḣ "H.") + (?\ḣ "h.") + (?\Ḥ "H-.") + (?\ḥ "h-.") + (?\Ḧ "H:") + (?\ḧ "h:") + (?\Ḩ "H,") + (?\ḩ "h,") + (?\Ḫ "H-(") + (?\ḫ "h-(") + (?\Ḭ "I-?") + (?\ḭ "i-?") + (?\Ḯ "I:'") + (?\ḯ "i:'") + (?\Ḱ "K'") + (?\ḱ "k'") + (?\Ḳ "K-.") + (?\ḳ "k-.") + (?\Ḵ "K_") + (?\ḵ "k_") + (?\Ḷ "L-.") + (?\ḷ "l-.") + (?\Ḹ "L--.") + (?\ḹ "l--.") + (?\Ḻ "L_") + (?\ḻ "l_") + (?\Ḽ "L->") + (?\ḽ "l->") + (?\Ḿ "M'") + (?\ḿ "m'") + (?\Ṁ "M.") + (?\ṁ "m.") + (?\Ṃ "M-.") + (?\ṃ "m-.") + (?\Ṅ "N.") + (?\ṅ "n.") + (?\Ṇ "N-.") + (?\ṇ "n-.") + (?\Ṉ "N_") + (?\ṉ "n_") + (?\Ṋ "N->") + (?\ṋ "n->") + (?\Ṍ "O?'") + (?\ṍ "o?'") + (?\Ṏ "O?:") + (?\ṏ "o?:") + (?\Ṑ "O-!") + (?\ṑ "o-!") + (?\Ṓ "O-'") + (?\ṓ "o-'") + (?\Ṕ "P'") + (?\ṕ "p'") + (?\Ṗ "P.") + (?\ṗ "p.") + (?\Ṙ "R.") + (?\ṙ "r.") + (?\Ṛ "R-.") + (?\ṛ "r-.") + (?\Ṝ "R--.") + (?\ṝ "r--.") + (?\Ṟ "R_") + (?\ṟ "r_") + (?\Ṡ "S.") + (?\ṡ "s.") + (?\Ṣ "S-.") + (?\ṣ "s-.") + (?\Ṥ "S'.") + (?\ṥ "s'.") + (?\Ṧ "S<.") + (?\ṧ "s<.") + (?\Ṩ "S.-.") + (?\ṩ "s.-.") + (?\Ṫ "T.") + (?\ṫ "t.") + (?\Ṭ "T-.") + (?\ṭ "t-.") + (?\Ṯ "T_") + (?\ṯ "t_") + (?\Ṱ "T->") + (?\ṱ "t->") + (?\Ṳ "U--:") + (?\ṳ "u--:") + (?\Ṵ "U-?") + (?\ṵ "u-?") + (?\Ṷ "U->") + (?\ṷ "u->") + (?\Ṹ "U?'") + (?\ṹ "u?'") + (?\Ṻ "U-:") + (?\ṻ "u-:") + (?\Ṽ "V?") + (?\ṽ "v?") + (?\Ṿ "V-.") + (?\ṿ "v-.") + (?\Ẁ "W!") + (?\ẁ "w!") + (?\Ẃ "W'") + (?\ẃ "w'") + (?\Ẅ "W:") + (?\ẅ "w:") + (?\Ẇ "W.") + (?\ẇ "w.") + (?\Ẉ "W-.") + (?\ẉ "w-.") + (?\Ẋ "X.") + (?\ẋ "x.") + (?\Ẍ "X:") + (?\ẍ "x:") + (?\Ẏ "Y.") + (?\ẏ "y.") + (?\Ẑ "Z>") + (?\ẑ "z>") + (?\Ẓ "Z-.") + (?\ẓ "z-.") + (?\Ẕ "Z_") + (?\ẕ "z_") + (?\ẖ "h_") + (?\ẗ "t:") + (?\ẘ "w0") + (?\ẙ "y0") + (?\Ạ "A-.") + (?\ạ "a-.") + (?\Ả "A2") + (?\ả "a2") + (?\Ấ "A>'") + (?\ấ "a>'") + (?\Ầ "A>!") + (?\ầ "a>!") + (?\Ẩ "A>2") + (?\ẩ "a>2") + (?\Ẫ "A>?") + (?\ẫ "a>?") + (?\Ậ "A>-.") + (?\ậ "a>-.") + (?\Ắ "A('") + (?\ắ "a('") + (?\Ằ "A(!") + (?\ằ "a(!") + (?\Ẳ "A(2") + (?\ẳ "a(2") + (?\Ẵ "A(?") + (?\ẵ "a(?") + (?\Ặ "A(-.") + (?\ặ "a(-.") + (?\Ẹ "E-.") + (?\ẹ "e-.") + (?\Ẻ "E2") + (?\ẻ "e2") + (?\Ẽ "E?") + (?\ẽ "e?") + (?\Ế "E>'") + (?\ế "e>'") + (?\Ề "E>!") + (?\ề "e>!") + (?\Ể "E>2") + (?\ể "e>2") + (?\Ễ "E>?") + (?\ễ "e>?") + (?\Ệ "E>-.") + (?\ệ "e>-.") + (?\Ỉ "I2") + (?\ỉ "i2") + (?\Ị "I-.") + (?\ị "i-.") + (?\Ọ "O-.") + (?\ọ "o-.") + (?\Ỏ "O2") + (?\ỏ "o2") + (?\Ố "O>'") + (?\ố "o>'") + (?\Ồ "O>!") + (?\ồ "o>!") + (?\Ổ "O>2") + (?\ổ "o>2") + (?\Ỗ "O>?") + (?\ỗ "o>?") + (?\Ộ "O>-.") + (?\ộ "o>-.") + (?\Ớ "O9'") + (?\ớ "o9'") + (?\Ờ "O9!") + (?\ờ "o9!") + (?\Ở "O92") + (?\ở "o92") + (?\Ỡ "O9?") + (?\ỡ "o9?") + (?\Ợ "O9-.") + (?\ợ "o9-.") + (?\Ụ "U-.") + (?\ụ "u-.") + (?\Ủ "U2") + (?\ủ "u2") + (?\Ứ "U9'") + (?\ứ "u9'") + (?\Ừ "U9!") + (?\ừ "u9!") + (?\Ử "U92") + (?\ử "u92") + (?\Ữ "U9?") + (?\ữ "u9?") + (?\Ự "U9-.") + (?\ự "u9-.") + (?\Ỳ "Y!") + (?\ỳ "y!") + (?\Ỵ "Y-.") + (?\ỵ "y-.") + (?\Ỷ "Y2") + (?\ỷ "y2") + (?\Ỹ "Y?") + (?\ỹ "y?") + (?\ἀ "a") + (?\ἁ "ha") + (?\ἂ "`a") + (?\ἃ "h`a") + (?\ἄ "a'") + (?\ἅ "ha'") + (?\ἆ "a~") + (?\ἇ "ha~") + (?\Ἀ "A") + (?\Ἁ "hA") + (?\Ἂ "`A") + (?\Ἃ "h`A") + (?\Ἄ "A'") + (?\Ἅ "hA'") + (?\Ἆ "A~") + (?\Ἇ "hA~") + (?\ἑ "he") + (?\Ἑ "hE") + (?\ἱ "hi") + (?\Ἱ "hI") + (?\ὁ "ho") + (?\Ὁ "hO") + (?\ὑ "hu") + (?\Ὑ "hU") + (?\᾿ ",,") + (?\῀ "?*") + (?\῁ "?:") + (?\῍ ",!") + (?\῎ ",'") + (?\῏ "?,") + (?\῝ ";!") + (?\῞ ";'") + (?\῟ "?;") + (?\ῥ "rh") + (?\Ῥ "Rh") + (?\῭ "!:") + (?\` "!*") + (?\῾ ";;") + (?\ " ") + (?\ " ") + (?\ " ") + (?\ " ") + (?\ " ") + (?\ " ") + (?\ " ") + (?\ " ") + (?\ " ") + (?\ " ") + (?\‐ "-") + (?\‑ "-") + (?\– "-") + (?\— "--") + (?\― "-") + (?\‖ "||") + (?\‗ "=2") + (?\‘ "`") + (?\’ "'") + (?\‚ "'") + (?\‛ "'") + (?\“ "\"") + (?\” "\"") + (?\„ "\"") + (?\‟ "\"") + (?\† "/-") + (?\‡ "/=") + (?\• " o ") + (?\․ ".") + (?\‥ "..") + (?\… "...") + (?\‧ "·") + (?\‰ " 0/00") + (?\′ "'") + (?\″ "''") + (?\‴ "'''") + (?\‵ "`") + (?\‶ "``") + (?\‷ "```") + (?\‸ "Ca") + (?\‹ "<") + (?\› ">") + (?\※ ":X") + (?\‼ "!!") + (?\‾ "'-") + (?\⁃ "-") + (?\⁄ "/") + (?\⁈ "?!") + (?\⁉ "!?") + (?\⁰ "^0") + (?\⁴ "^4") + (?\⁵ "^5") + (?\⁶ "^6") + (?\⁷ "^7") + (?\⁸ "^8") + (?\⁹ "^9") + (?\⁺ "^+") + (?\⁻ "^-") + (?\⁼ "^=") + (?\⁽ "^(") + (?\⁾ "^)") + (?\ⁿ "^n") + (?\₀ "_0") + (?\₁ "_1") + (?\₂ "_2") + (?\₃ "_3") + (?\₄ "_4") + (?\₅ "_5") + (?\₆ "_6") + (?\₇ "_7") + (?\₈ "_8") + (?\₉ "_9") + (?\₊ "_+") + (?\₋ "_-") + (?\₌ "_=") + (?\₍ "(") + (?\₎ ")") + (?\₣ "Ff") + (?\₤ "Li") + (?\₧ "Pt") + (?\₩ "W=") + (?\€ "EUR") + (?\℀ "a/c") + (?\℁ "a/s") + (?\℃ "oC") + (?\℅ "c/o") + (?\℆ "c/u") + (?\℉ "oF") + (?\ℊ "g") + (?\ℎ "h") + (?\ℏ "\\hbar") + (?\ℑ "Im") + (?\ℓ "l") + (?\№ "No.") + (?\℗ "PO") + (?\℘ "P") + (?\ℜ "Re") + (?\℞ "Rx") + (?\℠ "(SM)") + (?\℡ "TEL") + (?\™ "(TM)") + (?\Ω "Ohm") + (?\K "K") + (?\Å "Ang.") + (?\℮ "est.") + (?\ℴ "o") + (?\ℵ "Aleph ") + (?\ℶ "Bet ") + (?\ℷ "Gimel ") + (?\ℸ "Dalet ") + (?\⅓ " 1/3") + (?\⅔ " 2/3") + (?\⅕ " 1/5") + (?\⅖ " 2/5") + (?\⅗ " 3/5") + (?\⅘ " 4/5") + (?\⅙ " 1/6") + (?\⅚ " 5/6") + (?\⅛ " 1/8") + (?\⅜ " 3/8") + (?\⅝ " 5/8") + (?\⅞ " 7/8") + (?\⅟ " 1/") + (?\Ⅰ "I") + (?\Ⅱ "II") + (?\Ⅲ "III") + (?\Ⅳ "IV") + (?\Ⅴ "V") + (?\Ⅵ "VI") + (?\Ⅶ "VII") + (?\Ⅷ "VIII") + (?\Ⅸ "IX") + (?\Ⅹ "X") + (?\Ⅺ "XI") + (?\Ⅻ "XII") + (?\Ⅼ "L") + (?\Ⅽ "C") + (?\Ⅾ "D") + (?\Ⅿ "M") + (?\ⅰ "i") + (?\ⅱ "ii") + (?\ⅲ "iii") + (?\ⅳ "iv") + (?\ⅴ "v") + (?\ⅵ "vi") + (?\ⅶ "vii") + (?\ⅷ "viii") + (?\ⅸ "ix") + (?\ⅹ "x") + (?\ⅺ "xi") + (?\ⅻ "xii") + (?\ⅼ "l") + (?\ⅽ "c") + (?\ⅾ "d") + (?\ⅿ "m") + (?\ↀ "1000RCD") + (?\ↁ "5000R") + (?\ↂ "10000R") + (?\← "<-") + (?\↑ "-^") + (?\→ "->") + (?\↓ "-v") + (?\↔ "<->") + (?\↕ "UD") + (?\↖ "<!!") + (?\↗ "//>") + (?\↘ "!!>") + (?\↙ "<//") + (?\↨ "UD-") + (?\↵ "RET") + (?\⇀ ">V") + (?\⇐ "<=") + (?\⇑ "^^") + (?\⇒ "=>") + (?\⇓ "vv") + (?\⇔ "<=>") + (?\∀ "FA") + (?\∂ "\\partial") + (?\∃ "TE") + (?\∅ "{}") + (?\∆ "Delta") + (?\∇ "Nabla") + (?\∈ "(-") + (?\∉ "!(-") + (?\∊ "(-") + (?\∋ "-)") + (?\∌ "!-)") + (?\∍ "-)") + (?\∎ " qed") + (?\∏ "\\prod") + (?\∑ "\\sum") + (?\− " -") + (?\∓ "-/+") + (?\∔ ".+") + (?\∕ "/") + (?\∖ " - ") + (?\∗ "*") + (?\∘ " ° ") + (?\∙ "sb") + (?\√ " SQRT ") + (?\∛ " ROOT³ ") + (?\∜ " ROOT4 ") + (?\∝ "0(") + (?\∞ "infty") + (?\∟ "-L") + (?\∠ "-V") + (?\∥ "PP") + (?\∦ " !PP ") + (?\∧ "AND") + (?\∨ "OR") + (?\∩ "(U") + (?\∪ ")U") + (?\∫ "\\int ") + (?\∬ "DI") + (?\∮ "Io") + (?\∴ ".:") + (?\∵ ":.") + (?\∶ ":R") + (?\∷ "::") + (?\∼ "?1") + (?\∾ "CG") + (?\≃ "?-") + (?\≅ "?=") + (?\≈ "~=") + (?\≉ " !~= ") + (?\≌ "=?") + (?\≓ "HI") + (?\≔ ":=") + (?\≕ "=:") + (?\≠ "!=") + (?\≡ "=3") + (?\≢ " !=3 ") + (?\≤ "=<") + (?\≥ ">=") + (?\≦ ".LE.") + (?\≧ ".GE.") + (?\≨ ".LT.NOT.EQ.") + (?\≩ ".GT.NOT.EQ.") + (?\≪ "<<") + (?\≫ ">>") + (?\≮ "!<") + (?\≯ "!>") + (?\≶ " <> ") + (?\≷ " >< ") + (?\⊂ "(C") + (?\⊃ ")C") + (?\⊄ " !(C ") + (?\⊅ " !)C ") + (?\⊆ "(_") + (?\⊇ ")_") + (?\⊕ "(+)") + (?\⊖ "(-)") + (?\⊗ "(×)") + (?\⊘ "(/)") + (?\⊙ "(·)") + (?\⊚ "(°)") + (?\⊛ "(*)") + (?\⊜ "(=)") + (?\⊝ "(-)") + (?\⊞ "[+]") + (?\⊟ "[-]") + (?\⊠ "[×]") + (?\⊡ "[·]") + (?\⊥ "-T") + (?\⊧ " MODELS ") + (?\⊨ " TRUE ") + (?\⊩ " FORCES ") + (?\⊬ " !PROVES ") + (?\⊭ " NOT TRUE ") + (?\⊮ " !FORCES ") + (?\⊲ " NORMAL SUBGROUP OF ") + (?\⊳ " CONTAINS AS NORMAL SUBGROUP ") + (?\⊴ " NORMAL SUBGROUP OF OR EQUAL TO ") + (?\⊵ " CONTAINS AS NORMAL SUBGROUP OR EQUAL TO ") + (?\⊸ " MULTIMAP ") + (?\⊺ " INTERCALATE ") + (?\⊻ " XOR ") + (?\⊼ " NAND ") + (?\⋅ " · ") + (?\⋖ "<.") + (?\⋗ ">.") + (?\⋘ "<<<") + (?\⋙ ">>>") + (?\⋮ ":3") + (?\⋯ ".3") + (?\⌂ "Eh") + (?\⌇ "~~") + (?\⌈ "<7") + (?\⌉ ">7") + (?\⌊ "7<") + (?\⌋ "7>") + (?\⌐ "NI") + (?\⌒ "(A") + (?\⌕ "TR") + (?\⌘ "88") + (?\⌠ "Iu") + (?\⌡ "Il") + (?\⌢ ":(") + (?\⌣ ":)") + (?\⌤ "|^|") + (?\⌧ "[X]") + (?\〈 "</") + (?\〉 "/>") + (?\␣ "Vs") + (?\⑀ "1h") + (?\⑁ "3h") + (?\⑂ "2h") + (?\⑃ "4h") + (?\⑆ "1j") + (?\⑇ "2j") + (?\⑈ "3j") + (?\⑉ "4j") + (?\① "1-o") + (?\② "2-o") + (?\③ "3-o") + (?\④ "4-o") + (?\⑤ "5-o") + (?\⑥ "6-o") + (?\⑦ "7-o") + (?\⑧ "8-o") + (?\⑨ "9-o") + (?\⑩ "10-o") + (?\⑪ "11-o") + (?\⑫ "12-o") + (?\⑬ "13-o") + (?\⑭ "14-o") + (?\⑮ "15-o") + (?\⑯ "16-o") + (?\⑰ "17-o") + (?\⑱ "18-o") + (?\⑲ "19-o") + (?\⑳ "20-o") + (?\⑴ "(1)") + (?\⑵ "(2)") + (?\⑶ "(3)") + (?\⑷ "(4)") + (?\⑸ "(5)") + (?\⑹ "(6)") + (?\⑺ "(7)") + (?\⑻ "(8)") + (?\⑼ "(9)") + (?\⑽ "(10)") + (?\⑾ "(11)") + (?\⑿ "(12)") + (?\⒀ "(13)") + (?\⒁ "(14)") + (?\⒂ "(15)") + (?\⒃ "(16)") + (?\⒄ "(17)") + (?\⒅ "(18)") + (?\⒆ "(19)") + (?\⒇ "(20)") + (?\⒈ "1.") + (?\⒉ "2.") + (?\⒊ "3.") + (?\⒋ "4.") + (?\⒌ "5.") + (?\⒍ "6.") + (?\⒎ "7.") + (?\⒏ "8.") + (?\⒐ "9.") + (?\⒑ "10.") + (?\⒒ "11.") + (?\⒓ "12.") + (?\⒔ "13.") + (?\⒕ "14.") + (?\⒖ "15.") + (?\⒗ "16.") + (?\⒘ "17.") + (?\⒙ "18.") + (?\⒚ "19.") + (?\⒛ "20.") + (?\⒜ "(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)") + (?\Ⓐ "A-o") + (?\Ⓑ "B-o") + (?\Ⓒ "C-o") + (?\Ⓓ "D-o") + (?\Ⓔ "E-o") + (?\Ⓕ "F-o") + (?\Ⓖ "G-o") + (?\Ⓗ "H-o") + (?\Ⓘ "I-o") + (?\Ⓙ "J-o") + (?\Ⓚ "K-o") + (?\Ⓛ "L-o") + (?\Ⓜ "M-o") + (?\Ⓝ "N-o") + (?\Ⓞ "O-o") + (?\Ⓟ "P-o") + (?\Ⓠ "Q-o") + (?\Ⓡ "R-o") + (?\Ⓢ "S-o") + (?\Ⓣ "T-o") + (?\Ⓤ "U-o") + (?\Ⓥ "V-o") + (?\Ⓦ "W-o") + (?\Ⓧ "X-o") + (?\Ⓨ "Y-o") + (?\Ⓩ "Z-o") + (?\ⓐ "a-o") + (?\ⓑ "b-o") + (?\ⓒ "c-o") + (?\ⓓ "d-o") + (?\ⓔ "e-o") + (?\ⓕ "f-o") + (?\ⓖ "g-o") + (?\ⓗ "h-o") + (?\ⓘ "i-o") + (?\ⓙ "j-o") + (?\ⓚ "k-o") + (?\ⓛ "l-o") + (?\ⓜ "m-o") + (?\ⓝ "n-o") + (?\ⓞ "o-o") + (?\ⓟ "p-o") + (?\ⓠ "q-o") + (?\ⓡ "r-o") + (?\ⓢ "s-o") + (?\ⓣ "t-o") + (?\ⓤ "u-o") + (?\ⓥ "v-o") + (?\ⓦ "w-o") + (?\ⓧ "x-o") + (?\ⓨ "y-o") + (?\ⓩ "z-o") + (?\⓪ "0-o") + (?\─ "-") + (?\━ "=") + (?\│ "|") + (?\┃ "|") + (?\┄ "-") + (?\┅ "=") + (?\┆ "|") + (?\┇ "|") + (?\┈ "-") + (?\┉ "=") + (?\┊ "|") + (?\┋ "|") + (?\┌ "+") + (?\┍ "+") + (?\┎ "+") + (?\┏ "+") + (?\┐ "+") + (?\┑ "+") + (?\┒ "+") + (?\┓ "+") + (?\└ "+") + (?\┕ "+") + (?\┖ "+") + (?\┗ "+") + (?\┘ "+") + (?\┙ "+") + (?\┚ "+") + (?\┛ "+") + (?\├ "+") + (?\┝ "+") + (?\┞ "+") + (?\┟ "+") + (?\┠ "+") + (?\┡ "+") + (?\┢ "+") + (?\┣ "+") + (?\┤ "+") + (?\┥ "+") + (?\┦ "+") + (?\┧ "+") + (?\┨ "+") + (?\┩ "+") + (?\┪ "+") + (?\┫ "+") + (?\┬ "+") + (?\┭ "+") + (?\┮ "+") + (?\┯ "+") + (?\┰ "+") + (?\┱ "+") + (?\┲ "+") + (?\┳ "+") + (?\┴ "+") + (?\┵ "+") + (?\┶ "+") + (?\┷ "+") + (?\┸ "+") + (?\┹ "+") + (?\┺ "+") + (?\┻ "+") + (?\┼ "+") + (?\┽ "+") + (?\┾ "+") + (?\┿ "+") + (?\╀ "+") + (?\╁ "+") + (?\╂ "+") + (?\╃ "+") + (?\╄ "+") + (?\╅ "+") + (?\╆ "+") + (?\╇ "+") + (?\╈ "+") + (?\╉ "+") + (?\╊ "+") + (?\╋ "+") + (?\╌ "+") + (?\╍ "+") + (?\╎ "+") + (?\╏ "+") + (?\═ "+") + (?\║ "+") + (?\╒ "+") + (?\╓ "+") + (?\╔ "+") + (?\╕ "+") + (?\╖ "+") + (?\╗ "+") + (?\╘ "+") + (?\╙ "+") + (?\╚ "+") + (?\╛ "+") + (?\╜ "+") + (?\╝ "+") + (?\╞ "+") + (?\╟ "+") + (?\╠ "+") + (?\╡ "+") + (?\╢ "+") + (?\╣ "+") + (?\╤ "+") + (?\╥ "+") + (?\╦ "+") + (?\╧ "+") + (?\╨ "+") + (?\╩ "+") + (?\╪ "+") + (?\╫ "+") + (?\╬ "+") + (?\╱ "/") + (?\╲ "\\") + (?\▀ "TB") + (?\▄ "LB") + (?\█ "FB") + (?\▌ "lB") + (?\▐ "RB") + (?\░ ".S") + (?\▒ ":S") + (?\▓ "?S") + (?\■ "fS") + (?\□ "OS") + (?\▢ "RO") + (?\▣ "Rr") + (?\▤ "RF") + (?\▥ "RY") + (?\▦ "RH") + (?\▧ "RZ") + (?\▨ "RK") + (?\▩ "RX") + (?\▪ "sB") + (?\▬ "SR") + (?\▭ "Or") + (?\▲ "^") + (?\△ "uT") + (?\▶ "|>") + (?\▷ "Tr") + (?\► "|>") + (?\▼ "v") + (?\▽ "dT") + (?\◀ "<|") + (?\◁ "Tl") + (?\◄ "<|") + (?\◆ "Db") + (?\◇ "Dw") + (?\◊ "LZ") + (?\○ "0m") + (?\◎ "0o") + (?\● "0M") + (?\◐ "0L") + (?\◑ "0R") + (?\◘ "Sn") + (?\◙ "Ic") + (?\◢ "Fd") + (?\◣ "Bd") + (?\◯ "Ci") + (?\★ "*2") + (?\☆ "*1") + (?\☎ "TEL") + (?\☏ "tel") + (?\☜ "<--") + (?\☞ "-->") + (?\☡ "CAUTION ") + (?\☧ "XP") + (?\☹ ":-(") + (?\☺ ":-)") + (?\☻ "(-:") + (?\☼ "SU") + (?\♀ "f.") + (?\♂ "m.") + (?\♠ "cS") + (?\♡ "cH") + (?\♢ "cD") + (?\♣ "cC") + (?\♤ "cS-") + (?\♥ "cH-") + (?\♦ "cD-") + (?\♧ "cC-") + (?\♩ "Md") + (?\♪ "M8") + (?\♫ "M2") + (?\♬ "M16") + (?\♭ "b") + (?\♮ "Mx") + (?\♯ "#") + (?\✓ "X") + (?\✗ "X") + (?\✠ "-X") + (?\ " ") + (?\、 ",_") + (?\。 "._") + (?\〃 "+\"") + (?\〄 "JIS") + (?\々 "*_") + (?\〆 ";_") + (?\〇 "0_") + (?\《 "<+") + (?\》 ">+") + (?\「 "<'") + (?\」 ">'") + (?\『 "<\"") + (?\』 ">\"") + (?\【 "(\"") + (?\】 ")\"") + (?\〒 "=T") + (?\〓 "=_") + (?\〔 "('") + (?\〕 ")'") + (?\〖 "(I") + (?\〗 ")I") + (?\〚 "[[") + (?\〛 "]]") + (?\〜 "-?") + (?\〠 "=T:)") + (?\〿 " ") + (?\ぁ "A5") + (?\あ "a5") + (?\ぃ "I5") + (?\い "i5") + (?\ぅ "U5") + (?\う "u5") + (?\ぇ "E5") + (?\え "e5") + (?\ぉ "O5") + (?\お "o5") + (?\か "ka") + (?\が "ga") + (?\き "ki") + (?\ぎ "gi") + (?\く "ku") + (?\ぐ "gu") + (?\け "ke") + (?\げ "ge") + (?\こ "ko") + (?\ご "go") + (?\さ "sa") + (?\ざ "za") + (?\し "si") + (?\じ "zi") + (?\す "su") + (?\ず "zu") + (?\せ "se") + (?\ぜ "ze") + (?\そ "so") + (?\ぞ "zo") + (?\た "ta") + (?\だ "da") + (?\ち "ti") + (?\ぢ "di") + (?\っ "tU") + (?\つ "tu") + (?\づ "du") + (?\て "te") + (?\で "de") + (?\と "to") + (?\ど "do") + (?\な "na") + (?\に "ni") + (?\ぬ "nu") + (?\ね "ne") + (?\の "no") + (?\は "ha") + (?\ば "ba") + (?\ぱ "pa") + (?\ひ "hi") + (?\び "bi") + (?\ぴ "pi") + (?\ふ "hu") + (?\ぶ "bu") + (?\ぷ "pu") + (?\へ "he") + (?\べ "be") + (?\ぺ "pe") + (?\ほ "ho") + (?\ぼ "bo") + (?\ぽ "po") + (?\ま "ma") + (?\み "mi") + (?\む "mu") + (?\め "me") + (?\も "mo") + (?\ゃ "yA") + (?\や "ya") + (?\ゅ "yU") + (?\ゆ "yu") + (?\ょ "yO") + (?\よ "yo") + (?\ら "ra") + (?\り "ri") + (?\る "ru") + (?\れ "re") + (?\ろ "ro") + (?\ゎ "wA") + (?\わ "wa") + (?\ゐ "wi") + (?\ゑ "we") + (?\を "wo") + (?\ん "n5") + (?\ゔ "vu") + (?\゛ "\"5") + (?\゜ "05") + (?\ゝ "*5") + (?\ゞ "+5") + (?\ァ "a6") + (?\ア "A6") + (?\ィ "i6") + (?\イ "I6") + (?\ゥ "u6") + (?\ウ "U6") + (?\ェ "e6") + (?\エ "E6") + (?\ォ "o6") + (?\オ "O6") + (?\カ "Ka") + (?\ガ "Ga") + (?\キ "Ki") + (?\ギ "Gi") + (?\ク "Ku") + (?\グ "Gu") + (?\ケ "Ke") + (?\ゲ "Ge") + (?\コ "Ko") + (?\ゴ "Go") + (?\サ "Sa") + (?\ザ "Za") + (?\シ "Si") + (?\ジ "Zi") + (?\ス "Su") + (?\ズ "Zu") + (?\セ "Se") + (?\ゼ "Ze") + (?\ソ "So") + (?\ゾ "Zo") + (?\タ "Ta") + (?\ダ "Da") + (?\チ "Ti") + (?\ヂ "Di") + (?\ッ "TU") + (?\ツ "Tu") + (?\ヅ "Du") + (?\テ "Te") + (?\デ "De") + (?\ト "To") + (?\ド "Do") + (?\ナ "Na") + (?\ニ "Ni") + (?\ヌ "Nu") + (?\ネ "Ne") + (?\ノ "No") + (?\ハ "Ha") + (?\バ "Ba") + (?\パ "Pa") + (?\ヒ "Hi") + (?\ビ "Bi") + (?\ピ "Pi") + (?\フ "Hu") + (?\ブ "Bu") + (?\プ "Pu") + (?\ヘ "He") + (?\ベ "Be") + (?\ペ "Pe") + (?\ホ "Ho") + (?\ボ "Bo") + (?\ポ "Po") + (?\マ "Ma") + (?\ミ "Mi") + (?\ム "Mu") + (?\メ "Me") + (?\モ "Mo") + (?\ャ "YA") + (?\ヤ "Ya") + (?\ュ "YU") + (?\ユ "Yu") + (?\ョ "YO") + (?\ヨ "Yo") + (?\ラ "Ra") + (?\リ "Ri") + (?\ル "Ru") + (?\レ "Re") + (?\ロ "Ro") + (?\ヮ "WA") + (?\ワ "Wa") + (?\ヰ "Wi") + (?\ヱ "We") + (?\ヲ "Wo") + (?\ン "N6") + (?\ヴ "Vu") + (?\ヵ "KA") + (?\ヶ "KE") + (?\ヷ "Va") + (?\ヸ "Vi") + (?\ヹ "Ve") + (?\ヺ "Vo") + (?\・ ".6") + (?\ー "-6") + (?\ヽ "*6") + (?\ヾ "+6") + (?\ㄅ "b4") + (?\ㄆ "p4") + (?\ㄇ "m4") + (?\ㄈ "f4") + (?\ㄉ "d4") + (?\ㄊ "t4") + (?\ㄋ "n4") + (?\ㄌ "l4") + (?\ㄍ "g4") + (?\ㄎ "k4") + (?\ㄏ "h4") + (?\ㄐ "j4") + (?\ㄑ "q4") + (?\ㄒ "x4") + (?\ㄓ "zh") + (?\ㄔ "ch") + (?\ㄕ "sh") + (?\ㄖ "r4") + (?\ㄗ "z4") + (?\ㄘ "c4") + (?\ㄙ "s4") + (?\ㄚ "a4") + (?\ㄛ "o4") + (?\ㄜ "e4") + (?\ㄝ "eh4") + (?\ㄞ "ai") + (?\ㄟ "ei") + (?\ㄠ "au") + (?\ㄡ "ou") + (?\ㄢ "an") + (?\ㄣ "en") + (?\ㄤ "aN") + (?\ㄥ "eN") + (?\ㄦ "er") + (?\ㄧ "i4") + (?\ㄨ "u4") + (?\ㄩ "iu") + (?\ㄪ "v4") + (?\ㄫ "nG") + (?\ㄬ "gn") + (?\㈜ "(JU)") + (?\㈠ "1c") + (?\㈡ "2c") + (?\㈢ "3c") + (?\㈣ "4c") + (?\㈤ "5c") + (?\㈥ "6c") + (?\㈦ "7c") + (?\㈧ "8c") + (?\㈨ "9c") + (?\㈩ "10c") + (?\㉿ "KSC") + (?\㏂ "am") + (?\㏘ "pm") + (?\ff "ff") + (?\fi "fi") + (?\fl "fl") + (?\ffi "ffi") + (?\ffl "ffl") + (?\ſt "St") + (?\st "st") + (?\ﹽ "3+;") + (?\ﺂ "aM.") + (?\ﺄ "aH.") + (?\ﺈ "ah.") + (?\ﺍ "a+-") + (?\ﺎ "a+.") + (?\ﺏ "b+-") + (?\ﺐ "b+.") + (?\ﺑ "b+,") + (?\ﺒ "b+;") + (?\ﺓ "tm-") + (?\ﺔ "tm.") + (?\ﺕ "t+-") + (?\ﺖ "t+.") + (?\ﺗ "t+,") + (?\ﺘ "t+;") + (?\ﺙ "tk-") + (?\ﺚ "tk.") + (?\ﺛ "tk,") + (?\ﺜ "tk;") + (?\ﺝ "g+-") + (?\ﺞ "g+.") + (?\ﺟ "g+,") + (?\ﺠ "g+;") + (?\ﺡ "hk-") + (?\ﺢ "hk.") + (?\ﺣ "hk,") + (?\ﺤ "hk;") + (?\ﺥ "x+-") + (?\ﺦ "x+.") + (?\ﺧ "x+,") + (?\ﺨ "x+;") + (?\ﺩ "d+-") + (?\ﺪ "d+.") + (?\ﺫ "dk-") + (?\ﺬ "dk.") + (?\ﺭ "r+-") + (?\ﺮ "r+.") + (?\ﺯ "z+-") + (?\ﺰ "z+.") + (?\ﺱ "s+-") + (?\ﺲ "s+.") + (?\ﺳ "s+,") + (?\ﺴ "s+;") + (?\ﺵ "sn-") + (?\ﺶ "sn.") + (?\ﺷ "sn,") + (?\ﺸ "sn;") + (?\ﺹ "c+-") + (?\ﺺ "c+.") + (?\ﺻ "c+,") + (?\ﺼ "c+;") + (?\ﺽ "dd-") + (?\ﺾ "dd.") + (?\ﺿ "dd,") + (?\ﻀ "dd;") + (?\ﻁ "tj-") + (?\ﻂ "tj.") + (?\ﻃ "tj,") + (?\ﻄ "tj;") + (?\ﻅ "zH-") + (?\ﻆ "zH.") + (?\ﻇ "zH,") + (?\ﻈ "zH;") + (?\ﻉ "e+-") + (?\ﻊ "e+.") + (?\ﻋ "e+,") + (?\ﻌ "e+;") + (?\ﻍ "i+-") + (?\ﻎ "i+.") + (?\ﻏ "i+,") + (?\ﻐ "i+;") + (?\ﻑ "f+-") + (?\ﻒ "f+.") + (?\ﻓ "f+,") + (?\ﻔ "f+;") + (?\ﻕ "q+-") + (?\ﻖ "q+.") + (?\ﻗ "q+,") + (?\ﻘ "q+;") + (?\ﻙ "k+-") + (?\ﻚ "k+.") + (?\ﻛ "k+,") + (?\ﻜ "k+;") + (?\ﻝ "l+-") + (?\ﻞ "l+.") + (?\ﻟ "l+,") + (?\ﻠ "l+;") + (?\ﻡ "m+-") + (?\ﻢ "m+.") + (?\ﻣ "m+,") + (?\ﻤ "m+;") + (?\ﻥ "n+-") + (?\ﻦ "n+.") + (?\ﻧ "n+,") + (?\ﻨ "n+;") + (?\ﻩ "h+-") + (?\ﻪ "h+.") + (?\ﻫ "h+,") + (?\ﻬ "h+;") + (?\ﻭ "w+-") + (?\ﻮ "w+.") + (?\ﻯ "j+-") + (?\ﻰ "j+.") + (?\ﻱ "y+-") + (?\ﻲ "y+.") + (?\ﻳ "y+,") + (?\ﻴ "y+;") + (?\ﻵ "lM-") + (?\ﻶ "lM.") + (?\ﻷ "lH-") + (?\ﻸ "lH.") + (?\ﻹ "lh-") + (?\ﻺ "lh.") + (?\ﻻ "la-") + (?\ﻼ "la.") + (?\! "!") + (?\" "\"") + (?\# "#") + (?\$ "$") + (?\% "%") + (?\& "&") + (?\' "'") + (?\( "(") + (?\) ")") + (?\* "*") + (?\+ "+") + (?\, ",") + (?\- "-") + (?\. ".") + (?\/ "/") + (?\0 "0") + (?\1 "1") + (?\2 "2") + (?\3 "3") + (?\4 "4") + (?\5 "5") + (?\6 "6") + (?\7 "7") + (?\8 "8") + (?\9 "9") + (?\: ":") + (?\; ";") + (?\< "<") + (?\= "=") + (?\> ">") + (?\? "?") + (?\@ "@") + (?\A "A") + (?\B "B") + (?\C "C") + (?\D "D") + (?\E "E") + (?\F "F") + (?\G "G") + (?\H "H") + (?\I "I") + (?\J "J") + (?\K "K") + (?\L "L") + (?\M "M") + (?\N "N") + (?\O "O") + (?\P "P") + (?\Q "Q") + (?\R "R") + (?\S "S") + (?\T "T") + (?\U "U") + (?\V "V") + (?\W "W") + (?\X "X") + (?\Y "Y") + (?\Z "Z") + (?\[ "[") + (?\\ "\\") + (?\] "]") + (?\^ "^") + (?\_ "_") + (?\` "`") + (?\a "a") + (?\b "b") + (?\c "c") + (?\d "d") + (?\e "e") + (?\f "f") + (?\g "g") + (?\h "h") + (?\i "i") + (?\j "j") + (?\k "k") + (?\l "l") + (?\m "m") + (?\n "n") + (?\o "o") + (?\p "p") + (?\q "q") + (?\r "r") + (?\s "s") + (?\t "t") + (?\u "u") + (?\v "v") + (?\w "w") + (?\x "x") + (?\y "y") + (?\z "z") + (?\{ "{") + (?\| "|") + (?\} "}") + (?\~ "~") + (?\。 ".") + (?\「 "\"") + (?\」 "\"") + (?\、 ",") + ;; Not from Lynx + (? "") + (?� "?")))) (aset standard-display-table (make-char 'mule-unicode-0100-24ff) nil) (aset standard-display-table diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el index 28be35d65d2..27defef6480 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 pgtk))) :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) @@ -3061,22 +3083,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.") @@ -3244,5 +3250,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 a056f49e07c..3f3ac6064ae 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 16c17b5efa9..6b630c73e8e 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 8978a97e793..ab74c2cffd9 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) @@ -297,13 +298,21 @@ attribute." (defvar hack-read-symbol-shorthands-function nil "Holds function to compute `read-symbol-shorthands'.") -(defun load-with-code-conversion (fullname file &optional noerror nomessage) +(defun load-with-code-conversion (fullname file &optional noerror nomessage + eval-function) "Execute a file of Lisp code named FILE whose absolute name is FULLNAME. The file contents are decoded before evaluation if necessary. -If optional third arg NOERROR is non-nil, - report no error if FILE doesn't exist. -Print messages at start and end of loading unless - optional fourth arg NOMESSAGE is non-nil. + +If optional third arg NOERROR is non-nil, report no error if FILE +doesn't exist. + +Print messages at start and end of loading unless optional fourth +arg NOMESSAGE is non-nil. + +If EVAL-FUNCTION, call that instead of calling `eval-buffer' +directly. It is called with two parameters: The buffer object +and the file name. + Return t if file exists." (if (null (file-readable-p fullname)) (and (null noerror) @@ -352,10 +361,13 @@ Return t if file exists." ;; Have the original buffer current while we eval, ;; but consider shorthands of the eval'ed one. (let ((read-symbol-shorthands shorthands)) - (eval-buffer buffer nil - ;; This is compatible with what `load' does. - (if dump-mode file fullname) - nil t))) + (if eval-function + (funcall eval-function buffer + (if dump-mode file fullname)) + (eval-buffer buffer nil + ;; This is compatible with what `load' does. + (if dump-mode file fullname) + nil t)))) (let (kill-buffer-hook kill-buffer-query-functions) (kill-buffer buffer))) (do-after-load-evaluation fullname) @@ -890,6 +902,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 +2333,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 +2408,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 9d9210e9010..529cf97215e 100644 --- a/lisp/international/quail.el +++ b/lisp/international/quail.el @@ -412,8 +412,8 @@ If it is nil, the current key is shown. DOCSTRING is the documentation string of this package. The command `describe-input-method' shows this string while replacing the form -\\=\\<VAR> in the string by the value of VAR. That value should be a -string. For instance, the form \\=\\<quail-translation-docstring> is +\\=\\=\\=\\<VAR> in the string by the value of VAR. That value should be a +string. For instance, the form \\=\\=\\=\\<quail-translation-docstring> is replaced by a description about how to select a translation from a list of candidates. @@ -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/textsec-check.el b/lisp/international/textsec-check.el new file mode 100644 index 00000000000..567ef73feb2 --- /dev/null +++ b/lisp/international/textsec-check.el @@ -0,0 +1,78 @@ +;;; textsec-check.el --- Check for suspicious texts -*- lexical-binding: t; -*- + +;; Copyright (C) 2022 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: + +(defgroup textsec nil + "Suspicious text identification." + :group 'security + :version "29.1") + +(defcustom textsec-check t + "If non-nil, perform some security-related checks on text objects. +If nil, these checks are disabled." + :type 'boolean + :version "29.1") + +(defface textsec-suspicious + '((t (:weight bold :background "red"))) + "Face used to highlight suspicious strings.") + +;;;###autoload +(defun textsec-suspicious-p (object type) + "Say whether OBJECT is suspicious for use as TYPE. +If OBJECT is suspicious, return a string explaining the reason +for considering it suspicious, otherwise return nil. + +Available values of TYPE and corresponding OBJECTs are: + + `url' -- a URL; OBJECT should be a URL string. + + `link' -- an HTML link; OBJECT should be a cons cell + of the form (URL . LINK-TEXT). + + `domain' -- a Web domain; OBJECT should be a string. + + `local-address' -- the local part of an email address; OBJECT + should be a string. + `name' -- the \"display name\" part of an email address; + OBJECT should be a string. + +`email-address' -- a full email address; OBJECT should be a string. + + `email-address-header' -- a raw email address header in RFC 2822 format; + OBJECT should be a string. + +If the user option `textsec-check' is nil, these checks are +disabled, and this function always returns nil." + (if (not textsec-check) + nil + (require 'textsec) + (let ((func (intern (format "textsec-%s-suspicious-p" type)))) + (unless (fboundp func) + (error "%s is not a valid function" func)) + (funcall func object)))) + +(provide 'textsec-check) + +;;; textsec-check.el ends here diff --git a/lisp/international/textsec.el b/lisp/international/textsec.el new file mode 100644 index 00000000000..82eba1b5d51 --- /dev/null +++ b/lisp/international/textsec.el @@ -0,0 +1,467 @@ +;;; textsec.el --- Functions for handling homoglyphs and the like -*- lexical-binding: t; -*- + +;; Copyright (C) 2022 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) +(require 'uni-confusable) +(require 'ucs-normalize) +(require 'idna-mapping) +(require 'puny) +(require 'mail-parse) +(require 'url) + +(defvar textsec--char-scripts nil) + +(eval-and-compile + (defun textsec--create-script-table (data) + "Create the textsec--char-scripts char table." + (setq textsec--char-scripts (make-char-table nil)) + (dolist (scripts data) + (dolist (range (cadr scripts)) + (set-char-table-range textsec--char-scripts + range (car scripts))))) + (require 'uni-scripts)) + +(defun textsec-scripts (string) + "Return a list of Unicode scripts used in STRING. +The scripts returned by this function use the Unicode Script property +as defined by the Unicode Standard Annex 24 (UAX#24)." + (seq-map (lambda (char) + (elt textsec--char-scripts char)) + string)) + +(defun textsec-single-script-p (string) + "Return non-nil if STRING is all in a single Unicode script. + +Note that the concept of \"single script\" used by this function +isn't obvious -- some mixtures of scripts count as a \"single +script\". See + + https://www.unicode.org/reports/tr39/#Mixed_Script_Detection + +for details. The Unicode scripts are as defined by the +Unicode Standard Annex 24 (UAX#24)." + (let ((scripts (mapcar + (lambda (s) + (append s + ;; Some scripts used in East Asia are + ;; commonly used across borders, so we add + ;; those. + (mapcan (lambda (script) + (copy-sequence + (textsec--augment-script script))) + s))) + (textsec-scripts string)))) + (catch 'empty + (cl-loop for s1 in scripts + do (cl-loop for s2 in scripts + ;; Common/inherited chars can be used in + ;; text with all scripts. + when (and (not (memq 'common s1)) + (not (memq 'common s2)) + (not (memq 'inherited s1)) + (not (memq 'inherited s2)) + (not (seq-intersection s1 s2))) + do (throw 'empty nil))) + t))) + +(defun textsec--augment-script (script) + (cond + ((eq script 'han) + '(hangul japan korea)) + ((or (eq script 'hiragana) + (eq script 'katakana)) + '(japan)) + ((or (eq script 'hangul) + (eq script 'bopomofo)) + '(korea)))) + +(defun textsec-covering-scripts (string) + "Return a minimal list of scripts used in STRING. +Note that a string may have several different minimal cover sets. +The scripts are as defined by the Unicode Standard Annex 24 (UAX#24)." + (let* ((scripts (textsec-scripts string)) + (set (car scripts))) + (dolist (s scripts) + (setq set (seq-union set (seq-difference s set)))) + (sort (delq 'common (delq 'inherited set)) #'string<))) + +(defun textsec-restriction-level (string) + "Say what restriction level STRING qualifies for. +Levels are (in decreasing order of restrictiveness) `ascii-only', +`single-script', `highly-restrictive', `moderately-restrictive', +`minimally-restrictive' and `unrestricted'." + (let ((scripts (textsec-covering-scripts string))) + (cond + ((string-match "\\`[[:ascii:]]+\\'" string) + 'ascii-only) + ((textsec-single-script-p string) + 'single-script) + ((or (null (seq-difference scripts '(latin han hiragana katakana))) + (null (seq-difference scripts '(latin han bopomofo))) + (null (seq-difference scripts '(latin han hangul)))) + 'highly-restrictive) + ((and (= (length scripts) 2) + (memq 'latin scripts) + ;; This list comes from + ;; https://www.unicode.org/reports/tr31/#Table_Recommended_Scripts + ;; (but without latin, cyrillic and greek). + (seq-intersection scripts + '(arabic + armenian + bengali + bopomofo + devanagari + ethiopic + georgian + gujarati + gurmukhi + hangul + han + hebrew + hiragana + katakana + kannada + khmer + lao + malayalam + myanmar + oriya + sinhala + tamil + telugu + thaana + thai + tibetan))) + ;; The string is covered by Latin and any one other Recommended + ;; script, except Cyrillic, Greek. + 'moderately-retrictive) + ;; Fixme `minimally-restrictive' -- needs well-formedness criteria + ;; and Identifier Profile. + (t + 'unrestricted)))) + +(defun textsec-mixed-numbers-p (string) + "Return non-nil if STRING includes numbers from different decimal systems." + (> + (length + (seq-uniq + (mapcar + (lambda (char) + ;; Compare zeros in the respective decimal systems. + (- char (get-char-code-property char 'numeric-value))) + (seq-filter (lambda (char) + ;; We're selecting the characters that + ;; have a numeric property. + (eq (get-char-code-property char 'general-category) + 'Nd)) + string)))) + 1)) + +(defun textsec-ascii-confusable-p (string) + "Return non-nil if non-ASCII STRING can be confused with ASCII on display." + (and (not (eq (textsec-restriction-level string) 'ascii-only)) + (eq (textsec-restriction-level (textsec-unconfuse-string string)) + 'ascii-only))) + +(defun textsec-unconfuse-string (string) + "Return a de-confused version of STRING. +This algorithm is described in: + + https://www.unicode.org/reports/tr39/#Confusable_Detection" + (ucs-normalize-NFD-string + (apply #'concat + (seq-map (lambda (char) + (or (gethash char uni-confusable-table) + (string char))) + (ucs-normalize-NFD-string string))))) + +(defun textsec-resolved-script-set (string) + "Return the resolved script set for STRING. +This is the minimal covering script set for STRING, but is nil is +STRING isn't a single script string. +The scripts are as defined by the Unicode Standard Annex 24 (UAX#24)." + (and (textsec-single-script-p string) + (textsec-covering-scripts string))) + +(defun textsec-single-script-confusable-p (string1 string2) + "Say whether STRING1 and STRING2 are single-script confusables. +The scripts are as defined by the Unicode Standard Annex 24 (UAX#24)." + (and (equal (textsec-unconfuse-string string1) + (textsec-unconfuse-string string2)) + ;; And they have to have at least one resolved script in + ;; common. + (seq-intersection (textsec-resolved-script-set string1) + (textsec-resolved-script-set string2)))) + +(defun textsec-mixed-script-confusable-p (string1 string2) + "Say whether STRING1 and STRING2 are mixed-script confusables. +The scripts are as defined by the Unicode Standard Annex 24 (UAX#24)." + (and (equal (textsec-unconfuse-string string1) + (textsec-unconfuse-string string2)) + ;; And they have no resolved scripts in common. + (null (seq-intersection (textsec-resolved-script-set string1) + (textsec-resolved-script-set string2))))) + +(defun textsec-whole-script-confusable-p (string1 string2) + "Say whether STRING1 and STRING2 are whole-script confusables. +The scripts are as defined by the Unicode Standard Annex 24 (UAX#24)." + (and (textsec-mixed-script-confusable-p string1 string2) + (textsec-single-script-p string1) + (textsec-single-script-p string2))) + +(defun textsec--ipvx-address-p (domain) + "Return non-nil if DOMAIN is an ipv4 or ipv6 address." + ;; This is a very relaxed pattern for IPv4 or IPv6 addresses. The + ;; assumption is that any malformed address accepted by this rule + ;; will be rejected by the actual address parser eventually. + (let ((case-fold-search t)) + (rx-let ((ipv4 (** 1 4 + (** 1 3 (in "0-9")) + (? "."))) + (ipv6 (: (** 1 7 + (** 0 4 (in "0-9a-f")) + ":") + (** 0 4 (in "0-9a-f")) + (? ":" ipv4)))) + (string-match-p (rx bos (or ipv4 ipv6 (: "[" ipv6 "]")) eos) domain)))) + +(defun textsec-domain-suspicious-p (domain) + "Say whether DOMAIN's name looks suspicious. +Return nil if it isn't suspicious. If it is, return a string explaining +the potential problem. + +Domain names are considered suspicious if they use characters +that can look similar to other characters when displayed, or +use characters that are not allowed by Unicode's IDNA mapping, +or use certain other unusual mixtures of characters." + (catch 'found + ;; Plain domains aren't suspicious. + (when (textsec--ipvx-address-p domain) + (throw 'found nil)) + (seq-do + (lambda (char) + (when (eq (elt idna-mapping-table char) t) + (throw 'found + (format "Disallowed character%s (#x%x, %s)" + (if (eq (get-char-code-property char 'general-category) + 'Cf) + "" + (concat ": " (string char))) + char + (get-char-code-property char 'name))))) + domain) + ;; Does IDNA allow it? + (unless (puny-highly-restrictive-domain-p domain) + (throw + 'found + (format "`%s' mixes characters from different scripts in suspicious ways" + domain))) + ;; Check whether any segment of the domain name is confusable with + ;; an ASCII-only segment. + (dolist (elem (split-string domain "\\.")) + (when (textsec-ascii-confusable-p elem) + (throw 'found (format "`%s' is confusable with ASCII" elem)))) + nil)) + +(defun textsec-local-address-suspicious-p (local) + "Say whether LOCAL part of an email address looks suspicious. +LOCAL is the bit before \"@\" in an email address. + +If it isn't suspicious, return nil. If it is, return a string explaining +the potential problem. + +Email addresses are considered suspicious if they use characters +that can look similar to other characters when displayed, or use +certain other unusual mixtures of characters." + (cond + ((not (equal local (ucs-normalize-NFKC-string local))) + (format "`%s' is not in normalized format `%s'" + local (ucs-normalize-NFKC-string local))) + ((textsec-mixed-numbers-p local) + (format "`%s' contains numbers from different number systems" local)) + ((eq (textsec-restriction-level local) 'unrestricted) + (format "`%s' isn't restrictive enough" local)) + ((string-match-p "\\`\\.\\|\\.\\'\\|\\.\\." local) + (format "`%s' contains invalid dots" local)))) + +(defun textsec-bidi-controls-suspicious-p (string) + "Return non-nil of STRING uses bidi controls in suspicious ways. +If STRING doesn't include any suspicious uses of bidirectional +formatting control characters, return nil. Otherwise, return the +index of the first character in STRING affected by such suspicious +use of bidi controls. If the returned value is beyond the length +of STRING, it means any text following STRING on display might be +affected by bidi controls in STRING." + (with-temp-buffer + ;; We add a string that's representative of some text that could + ;; follow STRING, with the purpose of detecting residual bidi + ;; state at end of STRING which could then affect the following + ;; text. + (insert string "a1א:!") + (let ((pos (bidi-find-overridden-directionality 1 (point-max) nil))) + (and (fixnump pos) + (1- pos))))) + +(defun textsec-name-suspicious-p (name) + "Say whether NAME looks suspicious. +NAME is (for instance) the free-text display name part of an +email address. + +If it isn't suspicious, return nil. If it is, return a string +explaining the potential problem. + +Names are considered suspicious if they use characters that can +look similar to other characters when displayed, or use certain +other unusual mixtures of characters." + (cond + ((not (equal name (ucs-normalize-NFC-string name))) + (format "`%s' is not in normalized format `%s'" + name (ucs-normalize-NFC-string name))) + ((and (seq-find (lambda (char) + (and (member char bidi-control-characters) + (not (member char + '( ?\N{left-to-right mark} + ?\N{right-to-left mark} + ?\N{arabic letter mark}))))) + name) + ;; We have bidirectional formatting characters, but check + ;; whether they affect any other characters in suspicious + ;; ways. If not, NAME is not suspicious. + (fixnump (textsec-bidi-controls-suspicious-p name))) + (format "`%s' contains suspicious uses of bidirectional control characters" + name)) + ((textsec-suspicious-nonspacing-p name)))) + +(defun textsec-suspicious-nonspacing-p (string) + "Say whether STRING uses nonspacing characters in suspicious ways. +If it doesn't, return nil. If it does, return a string explaining +the potential problem. + +Use of nonspacing characters is considered suspicious if there are +two or more consecutive identical nonspacing characters, or too many +consecutive nonspacing characters." + (let ((prev nil) + (nonspace-count 0)) + (catch 'found + (seq-do + (lambda (char) + (let ((nonspacing + (memq (get-char-code-property char 'general-category) + '(Mn Me)))) + (when (and nonspacing + (equal char prev)) + (throw 'found "Two identical consecutive nonspacing characters")) + (setq nonspace-count (if nonspacing + (1+ nonspace-count) + 0)) + (when (> nonspace-count 4) + (throw 'found + "Too many consecutive nonspacing characters")) + (setq prev char))) + string) + nil))) + +(defun textsec-email-address-suspicious-p (address) + "Say whether EMAIL address looks suspicious. +If it isn't, return nil. If it is, return a string explaining the +potential problem. + +An email address is considered suspicious if either of its two +parts -- the local address name or the domain -- are found to be +suspicious by, respectively, `textsec-local-address-suspicious-p' +and `textsec-domain-suspicious-p'." + (pcase-let ((`(,local ,domain) (split-string address "@"))) + (or + (textsec-domain-suspicious-p domain) + (textsec-local-address-suspicious-p local)))) + +(defun textsec-email-address-header-suspicious-p (email) + "Say whether EMAIL looks suspicious. +If it isn't, return nil. If it is, return a string explaining the +potential problem. + +Note that EMAIL has to be a valid email specification according +to RFC2047bis -- strings that can't be parsed will be flagged as +suspicious. + +An email specification is considered suspicious if either of its +two parts -- the address or the name -- are found to be +suspicious by, respectively, `textsec-email-address-suspicious-p' +and `textsec-name-suspicious-p'." + (catch 'end + (pcase-let ((`(,address . ,name) + (condition-case nil + (mail-header-parse-address email t) + (error (throw 'end "Email address can't be parsed."))))) + (or + (textsec-email-address-suspicious-p address) + (and name (textsec-name-suspicious-p name)))))) + +(defun textsec-url-suspicious-p (url) + "Say whether URL looks suspicious. +If it isn't, return nil. If it is, return a string explaining the +potential problem." + (let ((parsed (url-generic-parse-url url))) + ;; The URL may not have a domain. + (and (url-host parsed) + (textsec-domain-suspicious-p (url-host parsed))))) + +(defun textsec-link-suspicious-p (link) + "Say whether LINK is suspicious. +LINK should be a cons cell where the first element is the URL, +and the second element is the link text. + +This function will return non-nil if it seems like the link text +is misleading about where the URL takes you. This is typical +when the link text looks like an URL itself, but doesn't lead to +the same domain as the URL." + (let* ((url (car link)) + (text (string-trim (cdr link)))) + (catch 'found + (let ((udomain (url-host (url-generic-parse-url url))) + (tdomain (url-host (url-generic-parse-url text)))) + (cond + ((and udomain + tdomain + (not (equal udomain tdomain)) + ;; One may be a sub-domain of the other, but don't allow too + ;; short domains. + (not (or (and (string-suffix-p udomain tdomain) + (url-domsuf-cookie-allowed-p udomain)) + (and (string-suffix-p tdomain udomain) + (url-domsuf-cookie-allowed-p tdomain))))) + (throw 'found + (format "Text `%s' doesn't point to link URL `%s'" + text url))) + ((and tdomain + (textsec-domain-suspicious-p tdomain)) + (throw 'found + (format "Domain `%s' in the link text is suspicious" + (bidi-string-strip-control-characters + tdomain))))))))) + +(provide 'textsec) + +;;; textsec.el ends here diff --git a/lisp/international/ucs-normalize.el b/lisp/international/ucs-normalize.el index 8e79ff7fb7d..bc32b4f0737 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 a68c3a4748c..31fbdf01bf2 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -430,13 +430,13 @@ and doesn't remove full-buffer highlighting after a search." (defface lazy-highlight '((((class color) (min-colors 88) (background light)) - (:background "paleturquoise")) + (:background "paleturquoise" :distant-foreground "black")) (((class color) (min-colors 88) (background dark)) - (:background "paleturquoise4")) + (:background "paleturquoise4" :distant-foreground "white")) (((class color) (min-colors 16)) - (:background "turquoise3")) + (:background "turquoise3" :distant-foreground "white")) (((class color) (min-colors 8)) - (:background "turquoise3")) + (:background "turquoise3" :distant-foreground "white")) (t (:underline t))) "Face for lazy highlighting of matches other than the current one." :group 'lazy-highlight @@ -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, @@ -668,6 +668,7 @@ This is like `describe-bindings', but displays only Isearch keys." ;; The key translations defined in the C-x 8 prefix should add ;; characters to the search string. See iso-transl.el. (define-key map "\C-x8\r" 'isearch-char-by-name) + (define-key map "\C-x8e\r" 'isearch-emoji-by-name) map) "Keymap for `isearch-mode'.") @@ -758,6 +759,8 @@ This is like `describe-bindings', but displays only Isearch keys." :help "Search for literal char"] ["Search for char by name" isearch-char-by-name :help "Search for character by name"] + ["Search for Emoji by name" isearch-emoji-by-name + :help "Search for Emoji by its Unicode name"] "---" ["Toggle input method" isearch-toggle-input-method :help "Toggle input method for search"] @@ -865,14 +868,16 @@ This variable is set and changed during isearch. To change the default behavior used for searches, see `search-default-mode' instead.") -(defvar isearch-lax-whitespace t +(defcustom isearch-lax-whitespace t "If non-nil, a space will match a sequence of whitespace chars. When you enter a space or spaces in ordinary incremental search, it will match any sequence matched by the regexp defined by the variable `search-whitespace-regexp'. If the value is nil, each space you type matches literally, against one space. You can toggle the value of this variable by the command `isearch-toggle-lax-whitespace', usually bound to -`M-s SPC' during isearch.") +`M-s SPC' during isearch." + :type 'boolean + :version "25.1") (defvar isearch-regexp-lax-whitespace nil "If non-nil, a space will match a sequence of whitespace chars. @@ -1810,17 +1815,19 @@ The following additional command keys are active while editing. ;; Search string might have meta information on text properties. (minibuffer-allow-text-properties t)) (setq isearch-new-string - (read-from-minibuffer - (isearch-message-prefix nil isearch-nonincremental) - (cons isearch-string (1+ (or (isearch-fail-pos) - (length isearch-string)))) - minibuffer-local-isearch-map nil - (if isearch-regexp - (cons 'regexp-search-ring - (1+ (or regexp-search-ring-yank-pointer -1))) - (cons 'search-ring - (1+ (or search-ring-yank-pointer -1)))) - nil t) + (minibuffer-with-setup-hook + (minibuffer-lazy-highlight-setup) + (read-from-minibuffer + (isearch-message-prefix nil isearch-nonincremental) + (cons isearch-string (1+ (or (isearch-fail-pos) + (length isearch-string)))) + minibuffer-local-isearch-map nil + (if isearch-regexp + (cons 'regexp-search-ring + (1+ (or regexp-search-ring-yank-pointer -1))) + (cons 'search-ring + (1+ (or search-ring-yank-pointer -1)))) + nil t)) isearch-new-message (mapconcat 'isearch-text-char-description isearch-new-string ""))))) @@ -2063,7 +2070,7 @@ The command then executes BODY and updates the isearch prompt." #',function)) (setq isearch-regexp nil))) ,@body - (setq isearch-success t isearch-adjusted t) + (setq isearch-success t isearch-adjusted 'toggle) (isearch-update)) (define-key isearch-mode-map ,key #',command-name) ,@(when (and function (symbolp function)) @@ -2488,8 +2495,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'. @@ -2497,8 +2504,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 () @@ -2514,6 +2521,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) @@ -2629,9 +2641,10 @@ is bound to outside of Isearch." ;; Key search depends on mode (bug#47755) (isearch-mode nil)) (key-binding (this-command-keys-vector) t)))) - (if (and (window-minibuffer-p w) - (not (minibuffer-window-active-p w))) ; in echo area - (isearch-yank-x-selection) + (if (or mouse-yank-at-point + (and (window-minibuffer-p w) + (not (minibuffer-window-active-p w)))) ; in echo area + (isearch-yank-x-selection) (when (functionp binding) (call-interactively binding))))) @@ -2670,7 +2683,7 @@ or it might return the position of the end of the line." (interactive "p") (if (eobp) (insert - (with-current-buffer (cadr (buffer-list)) + (with-minibuffer-selected-window (buffer-substring-no-properties (point) (progn (forward-char arg) (point))))) (forward-char arg))) @@ -2752,6 +2765,24 @@ With argument, add COUNT copies of the character." (mapconcat 'isearch-text-char-description string "")))))))) +(defun isearch-emoji-by-name (&optional count) + "Read an Emoji name and add it to the search string COUNT times. +COUNT (interactively, the prefix argument) defaults to 1. +The command accepts Unicode names like \"smiling face\" or +\"heart with arrow\", and completion is available." + (interactive "p") + (with-isearch-suspended + (let ((emoji (with-temp-buffer + (emoji-search) + (if (and (integerp count) (> count 1)) + (apply 'concat (make-list count (buffer-string))) + (buffer-string))))) + (when emoji + (setq isearch-new-string (concat isearch-string emoji) + isearch-new-message (concat isearch-message + (mapconcat 'isearch-text-char-description + emoji ""))))))) + (defun isearch-search-and-update () "Do the search and update the display." (when (or isearch-success @@ -2918,6 +2949,7 @@ to the barrier." (put 'scroll-other-window-down 'isearch-scroll t) (put 'beginning-of-buffer-other-window 'isearch-scroll t) (put 'end-of-buffer-other-window 'isearch-scroll t) +(put 'recenter-other-window 'isearch-scroll t) ;; Commands which change the window layout (put 'delete-other-windows 'isearch-scroll t) @@ -2932,6 +2964,9 @@ to the barrier." (put 'mouse-drag-mode-line 'isearch-scroll t) (put 'mouse-drag-vertical-line 'isearch-scroll t) +;; For context menu with isearch submenu +(put 'context-menu-open 'isearch-scroll t) + ;; Aliases for split-window-* (put 'split-window-vertically 'isearch-scroll t) (put 'split-window-horizontally 'isearch-scroll t) @@ -3422,7 +3457,7 @@ the word mode." ;; If currently failing, display no ellipsis. (or isearch-success (setq ellipsis nil)) (let ((m (concat (if isearch-success "" "failing ") - (if isearch-adjusted "pending " "") + (if (eq isearch-adjusted t) "pending " "") (if (and isearch-wrapped (not isearch-wrap-function) (if isearch-forward @@ -3435,11 +3470,13 @@ the word mode." (if (and (not isearch-success) (not isearch-case-fold-search)) "case-sensitive ") (let ((prefix "")) - (advice-function-mapc - (lambda (_ props) - (let ((np (cdr (assq 'isearch-message-prefix props)))) - (if np (setq prefix (concat np prefix))))) - isearch-filter-predicate) + (dolist (advice-function (list isearch-filter-predicate + isearch-search-fun-function)) + (advice-function-mapc + (lambda (_ props) + (let ((np (cdr (assq 'isearch-message-prefix props)))) + (if np (setq prefix (concat np prefix))))) + advice-function)) prefix) (isearch--describe-regexp-mode isearch-regexp-function) (cond @@ -3526,10 +3563,10 @@ Can be changed via `isearch-search-fun-function' for special needs." ;; (Bug#35802). (regexp (cond (isearch-regexp-function - (let ((lax (and (not bound) + (let ((lax (and (not bound) ; not lazy-highlight (isearch--lax-regexp-function-p)))) (when lax - (setq isearch-adjusted t)) + (setq isearch-adjusted 'lax)) (if (functionp isearch-regexp-function) (funcall isearch-regexp-function string lax) (word-search-regexp string lax)))) @@ -3797,8 +3834,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 @@ -3969,6 +4007,8 @@ since they have special meaning in a regexp." (defvar isearch-lazy-count-current nil) (defvar isearch-lazy-count-total nil) (defvar isearch-lazy-count-hash (make-hash-table)) +(defvar lazy-count-update-hook nil + "Hook run after new lazy count results are computed.") (defun lazy-highlight-cleanup (&optional force procrastinate) "Stop lazy highlighting and remove extra highlighting from current buffer. @@ -4027,7 +4067,7 @@ by other Emacs features." isearch-lazy-highlight-window-end)))))) ;; something important did indeed change (lazy-highlight-cleanup t (not (equal isearch-string ""))) ;stop old timer - (when (and isearch-lazy-count isearch-mode (null isearch-message-function)) + (when isearch-lazy-count (when (or (equal isearch-string "") ;; Check if this place was reached by a condition above ;; other than changed window boundaries (that shouldn't @@ -4046,7 +4086,10 @@ by other Emacs features." (setq isearch-lazy-count-current nil isearch-lazy-count-total nil) ;; Delay updating the message if possible, to avoid flicker - (when (string-equal isearch-string "") (isearch-message)))) + (when (string-equal isearch-string "") + (when (and isearch-mode (null isearch-message-function)) + (isearch-message)) + (run-hooks 'lazy-count-update-hook)))) (setq isearch-lazy-highlight-window-start-changed nil) (setq isearch-lazy-highlight-window-end-changed nil) (setq isearch-lazy-highlight-error isearch-error) @@ -4099,13 +4142,15 @@ by other Emacs features." 'isearch-lazy-highlight-start)))) ;; Update the current match number only in isearch-mode and ;; unless isearch-mode is used specially with isearch-message-function - (when (and isearch-lazy-count isearch-mode (null isearch-message-function)) + (when isearch-lazy-count ;; Update isearch-lazy-count-current only when it was already set ;; at the end of isearch-lazy-highlight-buffer-update (when isearch-lazy-count-current (setq isearch-lazy-count-current (gethash (point) isearch-lazy-count-hash 0)) - (isearch-message)))) + (when (and isearch-mode (null isearch-message-function)) + (isearch-message)) + (run-hooks 'lazy-count-update-hook)))) (defun isearch-lazy-highlight-search (string bound) "Search ahead for the next or previous match, for lazy highlighting. @@ -4306,16 +4351,110 @@ Attempt to do the search exactly the way the pending Isearch would." (setq looping nil nomore t)))) (if nomore - (when (and isearch-lazy-count isearch-mode (null isearch-message-function)) + (when isearch-lazy-count (unless isearch-lazy-count-total (setq isearch-lazy-count-total 0)) (setq isearch-lazy-count-current (gethash opoint isearch-lazy-count-hash 0)) - (isearch-message)) + (when (and isearch-mode (null isearch-message-function)) + (isearch-message))) (setq isearch-lazy-highlight-timer (run-at-time lazy-highlight-interval nil - 'isearch-lazy-highlight-buffer-update))))))))) + 'isearch-lazy-highlight-buffer-update))))) + (when (and nomore isearch-lazy-count) + (run-hooks 'lazy-count-update-hook)))))) + +;; Reading from minibuffer with lazy highlight and match count + +(defcustom minibuffer-lazy-count-format "%s " + "Format of the total number of matches for the prompt prefix." + :type '(choice (const :tag "Don't display a count" nil) + (string :tag "Display match count" "%s ")) + :group 'lazy-count + :version "29.1") + +(cl-defun minibuffer-lazy-highlight-setup + (&key (highlight isearch-lazy-highlight) + (cleanup lazy-highlight-cleanup) + (transform #'identity) + (filter nil) + (regexp isearch-regexp) + (regexp-function isearch-regexp-function) + (case-fold isearch-case-fold-search) + (lax-whitespace (if regexp + isearch-regexp-lax-whitespace + isearch-lax-whitespace))) + "Set up minibuffer for lazy highlight of matches in the original window. + +This function return a closure intended to be added to +`minibuffer-setup-hook'. It accepts the following keyword +arguments, all of which have a default based on the current +isearch settings. + +HIGHLIGHT: Whether to perform lazy highlight. +CLEANUP: Whether to clean up the lazy highlight when the minibuffer +exits. +TRANSFORM: A function taking one argument, the minibuffer contents, +and returning the `isearch-string' to use for lazy highlighting. +FILTER: A function to add to `isearch-filter-predicate'. +REGEXP: The value of `isearch-regexp' to use for lazy highlighting. +REGEXP-FUNCTION: The value of `isearch-regexp-function' to use for +lazy highlighting. +CASE-FOLD: The value of `isearch-case-fold' to use for lazy +highlighting. +LAX-WHITESPACE: The value of `isearch-lax-whitespace' and +`isearch-regexp-lax-whitespace' to use for lazy highlighting." + (if (not highlight) + #'ignore + (let ((unwind (make-symbol "minibuffer-lazy-highlight--unwind")) + (after-change (make-symbol "minibuffer-lazy-highlight--after-change")) + (display-count (make-symbol "minibuffer-lazy-highlight--display-count")) + (buffer (current-buffer)) + overlay) + (fset unwind + (lambda () + (when filter + (with-current-buffer buffer + (remove-function (local 'isearch-filter-predicate) filter))) + (remove-hook 'lazy-count-update-hook display-count) + (when overlay (delete-overlay overlay)) + (remove-hook 'after-change-functions after-change t) + (remove-hook 'minibuffer-exit-hook unwind t) + (let ((lazy-highlight-cleanup cleanup)) + (lazy-highlight-cleanup)))) + (fset after-change + (lambda (_beg _end _len) + (let ((inhibit-redisplay t) ;; Avoid cursor flickering + (string (minibuffer-contents))) + (with-minibuffer-selected-window + (let* ((isearch-forward t) + (isearch-regexp regexp) + (isearch-regexp-function regexp-function) + (isearch-case-fold-search case-fold) + (isearch-lax-whitespace lax-whitespace) + (isearch-regexp-lax-whitespace lax-whitespace) + (isearch-string (funcall transform string))) + (isearch-lazy-highlight-new-loop)))))) + (fset display-count + (lambda () + (overlay-put overlay 'before-string + (and isearch-lazy-count-total + (not isearch-error) + (format minibuffer-lazy-count-format + isearch-lazy-count-total))))) + (lambda () + (add-hook 'minibuffer-exit-hook unwind nil t) + (add-hook 'after-change-functions after-change nil t) + (when minibuffer-lazy-count-format + (setq overlay (make-overlay (point-min) (point-min) (current-buffer) t)) + (add-hook 'lazy-count-update-hook display-count)) + (when filter + (with-current-buffer buffer + (add-function :after-while (local 'isearch-filter-predicate) filter))) + (funcall after-change nil nil nil))))) + + (defun isearch-resume (string regexp word forward message case-fold) "Resume an incremental search. STRING is the string or regexp searched for. @@ -4331,6 +4470,23 @@ CASE-FOLD non-nil means the search was case-insensitive." (isearch-search) (isearch-update)) + +(defvar isearch-fold-quotes-mode--state) +(define-minor-mode isearch-fold-quotes-mode + "Minor mode to aid searching for \\=` characters in help modes." + :lighter "" + (if isearch-fold-quotes-mode + (setq-local isearch-fold-quotes-mode--state + (buffer-local-set-state + search-default-mode + (lambda (string &optional _lax) + (thread-last + (regexp-quote string) + (replace-regexp-in-string "`" "[`‘]") + (replace-regexp-in-string "'" "['’]") + (replace-regexp-in-string "\"" "[\"“”]"))))) + (buffer-local-restore-state isearch-fold-quotes-mode--state))) + (provide 'isearch) ;;; isearch.el ends here diff --git a/lisp/jit-lock.el b/lisp/jit-lock.el index 20c12024745..17969d57620 100644 --- a/lisp/jit-lock.el +++ b/lisp/jit-lock.el @@ -217,6 +217,11 @@ If the system load rises above `jit-lock-stealth-load' percent, stealth fontification is suspended. Stealth fontification intensity is controlled via the variable `jit-lock-stealth-nice'. +`jit-lock-mode' is not a regular minor mode, and it doesn't +follow the regular conventions to switch the functionality on or +off. Instead, an ARG of nil will switch it off, and non-nil will +switch it on. + If you need to debug code run from jit-lock, see `jit-lock-debug-mode'." (setq jit-lock-mode arg) (cond diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el index 84d0ef9179b..b84e9b74b1f 100644 --- a/lisp/jsonrpc.el +++ b/lisp/jsonrpc.el @@ -4,7 +4,7 @@ ;; Author: João Távora <joaotavora@gmail.com> ;; Keywords: processes, languages, extensions -;; Version: 1.0.14 +;; Version: 1.0.15 ;; Package-Requires: ((emacs "25.2")) ;; This is a GNU ELPA :core package. Avoid functionality that is not @@ -698,7 +698,9 @@ TIMEOUT is nil)." (defun jsonrpc--debug (server format &rest args) "Debug message for SERVER with FORMAT and ARGS." (jsonrpc--log-event - server (if (stringp format)`(:message ,(format format args)) format))) + server (if (stringp format) + `(:message ,(apply #'format format args)) + format))) (defun jsonrpc--warn (format &rest args) "Warning message with FORMAT and ARGS." diff --git a/lisp/keymap.el b/lisp/keymap.el new file mode 100644 index 00000000000..71454eba5e5 --- /dev/null +++ b/lisp/keymap.el @@ -0,0 +1,580 @@ +;;; keymap.el --- Keymap functions -*- lexical-binding: t; -*- + +;; Copyright (C) 2021-2022 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 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)))))) + res))) + +(defun key-valid-p (keys) + "Say whether KEYS is a valid key. +A key is a string consisting of one or more key strokes. +The key strokes are separated by single space characters. + +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)) + (let ((case-fold-search nil)) + (and + (stringp keys) + (string-match-p "\\`[^ ]+\\( [^ ]+\\)*\\'" keys) + (save-match-data + (catch 'exit + (let ((prefixes + "\\(A-\\)?\\(C-\\)?\\(H-\\)?\\(M-\\)?\\(S-\\)?\\(s-\\)?")) + (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)) + + +;;; define-keymap and defvar-keymap + +(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-x (car args) "Invalid keyword: %s" (car args))) + (setq args (cdr args)) + (when (null args) + (byte-compile-warn-x form "Uneven number of keywords in %S" form)) + (setq args (cdr args))) + ;; Bindings. + (while args + (let* ((wargs args) + (key (pop args))) + (when (and (stringp key) (not (key-valid-p key))) + (byte-compile-warn-x wargs "Invalid `kbd' syntax: %S" key))) + (when (null args) + (byte-compile-warn-x form "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/DEFINITION pairs as key bindings. +The new keymap is returned. + +Options can be given as keywords before the KEY/DEFINITION +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))))) + +(provide 'keymap) + +;;; keymap.el ends here diff --git a/lisp/kmacro.el b/lisp/kmacro.el index 7478e97134f..5746b770a2e 100644 --- a/lisp/kmacro.el +++ b/lisp/kmacro.el @@ -362,9 +362,13 @@ information." ;;; Keyboard macro ring +(oclosure-define kmacro + "Keyboard macro." + keys (counter :mutable t) format) + (defvar kmacro-ring nil "The keyboard macro ring. -Each element is a list (MACRO COUNTER FORMAT). Actually, the head of +Each element is a `kmacro'. Actually, the head of the macro ring (when defining or executing) is not stored in the ring; instead it is available in the variables `last-kbd-macro', `kmacro-counter', and `kmacro-counter-format'.") @@ -378,20 +382,23 @@ and `kmacro-counter-format'.") (defun kmacro-ring-head () "Return pseudo head element in macro ring." (and last-kbd-macro - (list last-kbd-macro kmacro-counter kmacro-counter-format-start))) + (kmacro last-kbd-macro kmacro-counter kmacro-counter-format-start))) (defun kmacro-push-ring (&optional elt) "Push ELT or current macro onto `kmacro-ring'." (when (setq elt (or elt (kmacro-ring-head))) + (when (consp elt) + (message "Converting obsolete list form of kmacro: %S" elt) + (setq elt (apply #'kmacro elt))) (let ((history-delete-duplicates nil)) (add-to-history 'kmacro-ring elt kmacro-ring-max)))) (defun kmacro-split-ring-element (elt) - (setq last-kbd-macro (car elt) - kmacro-counter (nth 1 elt) - kmacro-counter-format-start (nth 2 elt))) + (setq last-kbd-macro (kmacro--keys elt) + kmacro-counter (kmacro--counter elt) + kmacro-counter-format-start (kmacro--format elt))) (defun kmacro-pop-ring1 (&optional raw) @@ -481,21 +488,16 @@ Optional arg EMPTY is message to print if no macros are defined." ;;;###autoload -(defun kmacro-exec-ring-item (item arg) +(define-obsolete-function-alias 'kmacro-exec-ring-item #'funcall "29.1" "Execute item ITEM from the macro ring. -ARG is the number of times to execute the item." - ;; Use counter and format specific to the macro on the ring! - (let ((kmacro-counter (nth 1 item)) - (kmacro-counter-format-start (nth 2 item))) - (execute-kbd-macro (car item) arg #'kmacro-loop-setup-function) - (setcar (cdr item) kmacro-counter))) +ARG is the number of times to execute the item.") (defun kmacro-call-ring-2nd (arg) "Execute second keyboard macro in macro ring." (interactive "P") (unless (kmacro-ring-empty-p) - (kmacro-exec-ring-item (car kmacro-ring) arg))) + (funcall (car kmacro-ring) arg))) (defun kmacro-call-ring-2nd-repeat (arg) @@ -515,7 +517,7 @@ without repeating the prefix." "Display the second macro in the keyboard macro ring." (interactive) (unless (kmacro-ring-empty-p) - (kmacro-display (car (car kmacro-ring)) nil "2nd macro"))) + (kmacro-display (kmacro--keys (car kmacro-ring)) nil "2nd macro"))) (defun kmacro-cycle-ring-next (&optional _arg) @@ -611,8 +613,7 @@ Use \\[kmacro-bind-to-key] to bind it to a key sequence." (let ((append (and arg (listp arg)))) (unless append (if last-kbd-macro - (kmacro-push-ring - (list last-kbd-macro kmacro-counter kmacro-counter-format-start))) + (kmacro-push-ring)) (setq kmacro-counter (or (if arg (prefix-numeric-value arg)) kmacro-initial-counter-value 0) @@ -748,9 +749,9 @@ With \\[universal-argument], call second macro in macro ring." (if kmacro-call-repeat-key (kmacro-call-macro arg no-repeat t) (kmacro-end-macro arg))) - ((and (eq this-command 'kmacro-view-macro) ;; We are in repeat mode! + ((and (eq this-command #'kmacro-view-macro) ;; We are in repeat mode! kmacro-view-last-item) - (kmacro-exec-ring-item (car kmacro-view-last-item) arg)) + (funcall (car kmacro-view-last-item) arg)) ((and arg (listp arg)) (kmacro-call-ring-2nd 1)) (t @@ -812,41 +813,67 @@ If kbd macro currently being defined end it before activating it." ;; executing the macro later on (but that's controversial...) ;;;###autoload +(defun kmacro (keys &optional counter format) + "Create a `kmacro' for macro bound to symbol or key. +KEYS should be a vector or a string that obeys `key-valid-p'." + (oclosure-lambda (kmacro (keys (if (stringp keys) (key-parse keys) keys)) + (counter (or counter 0)) + (format (or format "%d"))) + (&optional arg) + ;; Use counter and format specific to the macro on the ring! + (let ((kmacro-counter counter) + (kmacro-counter-format-start format)) + (execute-kbd-macro keys arg #'kmacro-loop-setup-function) + (setq counter kmacro-counter)))) + +(cl-defmethod oclosure-interactive-form ((_ kmacro)) '(interactive "p")) + +;;;###autoload (defun kmacro-lambda-form (mac &optional counter format) - "Create lambda form for macro bound to symbol or key." ;; Apparently, there are two different ways this is called: ;; either `counter' and `format' are both provided and `mac' is a vector, ;; or only `mac' is provided, as a list (MAC COUNTER FORMAT). ;; The first is used from `insert-kbd-macro' and `edmacro-finish-edit', ;; while the second is used from within this file. - (let ((mac (if counter (list mac counter format) mac))) - ;; FIXME: This should be a "funcallable struct"! - (lambda (&optional arg) - "Keyboard macro." - ;; We put an "unused prompt" as a special marker so - ;; `kmacro-extract-lambda' can see it's "one of us". - (interactive "pkmacro") - (if (eq arg 'kmacro--extract-lambda) - (cons 'kmacro--extract-lambda mac) - (kmacro-exec-ring-item mac arg))))) + (declare (obsolete kmacro "29.1")) + (if (kmacro-p mac) mac + (when (and (null counter) (consp mac)) + (setq format (nth 2 mac)) + (setq counter (nth 1 mac)) + (setq mac (nth 0 mac))) + (when (stringp mac) + ;; `kmacro' interprets a string according to `key-parse'. + (require 'macros) + (declare-function macro--string-to-vector "macros") + (setq mac (macro--string-to-vector mac))) + (kmacro mac counter format))) (defun kmacro-extract-lambda (mac) "Extract kmacro from a kmacro lambda form." - (let ((mac (cond - ((eq (car-safe mac) 'lambda) - (let ((e (assoc 'kmacro-exec-ring-item mac))) - (car-safe (cdr-safe (car-safe (cdr-safe e)))))) - ((and (functionp mac) - (equal (interactive-form mac) '(interactive "pkmacro"))) - (let ((r (funcall mac 'kmacro--extract-lambda))) - (and (eq (car-safe r) 'kmacro--extract-lambda) (cdr r))))))) - (and (consp mac) - (= (length mac) 3) - (arrayp (car mac)) - mac))) - -(defalias 'kmacro-p #'kmacro-extract-lambda - "Return non-nil if MAC is a kmacro keyboard macro.") + (declare (obsolete nil "29.1")) + (when (kmacro-p mac) + (list (kmacro--keys mac) + (kmacro--counter mac) + (kmacro--format mac)))) + +(defun kmacro-p (x) + "Return non-nil if MAC is a kmacro keyboard macro." + (cl-typep x 'kmacro)) + +(cl-defmethod cl-print-object ((object kmacro) stream) + (princ "#f(kmacro " stream) + (require 'macros) + (declare-function macros--insert-vector-macro "macros" (definition)) + (let ((vecdef (kmacro--keys object)) + (counter (kmacro--counter object)) + (format (kmacro--format object))) + (prin1 (key-description vecdef) stream) + (unless (and (equal counter 0) (equal format "%d")) + (princ " " stream) + (prin1 counter stream) + (princ " " stream) + (prin1 format stream)) + (princ ")" stream))) (defun kmacro-bind-to-key (_arg) "When not defining or executing a macro, offer to bind last macro to a key. @@ -884,16 +911,15 @@ The ARG parameter is unused." (yes-or-no-p (format "%s runs command %S. Bind anyway? " (format-kbd-macro key-seq) cmd)))) - (define-key global-map key-seq - (kmacro-lambda-form (kmacro-ring-head))) + (define-key global-map key-seq (kmacro-ring-head)) (message "Keyboard macro bound to %s" (format-kbd-macro key-seq)))))) (defun kmacro-keyboard-macro-p (symbol) "Return non-nil if SYMBOL is the name of some sort of keyboard macro." (let ((f (symbol-function symbol))) (when f - (or (stringp f) - (vectorp f) + (or (stringp f) ;FIXME: Really deprecated. + (vectorp f) ;FIXME: Deprecated. (kmacro-p f))))) (defun kmacro-name-last-macro (symbol) @@ -910,9 +936,7 @@ Such a \"function\" cannot be called from Lisp, but it is a valid editor command symbol)) (if (string-equal symbol "") (error "No command name given")) - ;; FIXME: Use plain old `last-kbd-macro' for kmacros where it doesn't - ;; make a difference? - (fset symbol (kmacro-lambda-form (kmacro-ring-head))) + (fset symbol (kmacro-ring-head)) ;; This used to be used to detect when a symbol corresponds to a kmacro. ;; Nowadays it's unused because we used `kmacro-p' instead to see if the ;; symbol's function definition matches that of a kmacro, which is more @@ -930,7 +954,7 @@ Such a \"function\" cannot be called from Lisp, but it is a valid editor command (cl-defmethod register-val-describe ((data kmacro-register) _verbose) (princ (format "a keyboard macro:\n %s" - (format-kbd-macro (kmacro-register-macro data))))) + (key-description (kmacro-register-macro data))))) (cl-defmethod register-val-insert ((data kmacro-register)) (insert (format-kbd-macro (kmacro-register-macro data)))) @@ -953,7 +977,7 @@ The ARG parameter is unused." (interactive) (cond ((or (kmacro-ring-empty-p) - (not (eq last-command 'kmacro-view-macro))) + (not (eq last-command #'kmacro-view-macro))) (setq kmacro-view-last-item nil)) ((null kmacro-view-last-item) (setq kmacro-view-last-item kmacro-ring @@ -963,10 +987,10 @@ The ARG parameter is unused." kmacro-view-item-no (1+ kmacro-view-item-no))) (t (setq kmacro-view-last-item nil))) - (setq this-command 'kmacro-view-macro + (setq this-command #'kmacro-view-macro last-command this-command) ;; in case we repeat (kmacro-display (if kmacro-view-last-item - (car (car kmacro-view-last-item)) + (kmacro--keys (car kmacro-view-last-item)) last-kbd-macro) nil (if kmacro-view-last-item @@ -1068,21 +1092,27 @@ following additional answers: `insert', `insert-1', `replace', `replace-1', (concat (format "Macro: %s%s%s%s%s\n" (format-kbd-macro kmacro-step-edit-new-macro 1) - (if (and kmacro-step-edit-new-macro (> (length kmacro-step-edit-new-macro) 0)) " " "") + (if (and kmacro-step-edit-new-macro + (> (length kmacro-step-edit-new-macro) 0)) + " " "") (propertize (if keys (format-kbd-macro keys) - (if kmacro-step-edit-appending "<APPEND>" "<INSERT>")) 'face 'region) + (if kmacro-step-edit-appending + "<APPEND>" "<INSERT>")) + 'face 'region) (if future " " "") (if future (format-kbd-macro future) "")) (cond ((minibufferp) (format "%s\n%s\n" (propertize "\ - minibuffer " 'face 'header-line) + minibuffer " + 'face 'header-line) (buffer-substring (point-min) (point-max)))) (curmsg (format "%s\n%s\n" (propertize "\ - echo area " 'face 'header-line) + echo area " + 'face 'header-line) curmsg)) (t "")) (if keys @@ -1113,7 +1143,7 @@ following additional answers: `insert', `insert-1', `replace', `replace-1', ;; Handle commands which reads additional input using read-char. (cond - ((and (eq this-command 'quoted-insert) + ((and (eq this-command #'quoted-insert) (not (eq kmacro-step-edit-action t))) ;; Find the actual end of this key sequence. ;; Must be able to backtrack in case we actually execute it. @@ -1133,7 +1163,7 @@ following additional answers: `insert', `insert-1', `replace', `replace-1', (cond ((eq kmacro-step-edit-action t) ;; Reentry for actual command @ end of prefix arg. (cond - ((eq this-command 'quoted-insert) + ((eq this-command #'quoted-insert) (clear-this-command-keys) ;; recent-keys actually (let (unread-command-events) (quoted-insert (prefix-numeric-value current-prefix-arg)) @@ -1177,7 +1207,7 @@ following additional answers: `insert', `insert-1', `replace', `replace-1', ((eq act 'skip) nil) ((eq act 'skip-keep) - (setq this-command 'ignore) + (setq this-command #'ignore) t) ((eq act 'skip-rest) (setq kmacro-step-edit-active 'ignore) @@ -1227,7 +1257,7 @@ following additional answers: `insert', `insert-1', `replace', `replace-1', (if restore-index (setq executing-kbd-macro-index restore-index))) (t - (setq this-command 'ignore))) + (setq this-command #'ignore))) (setq kmacro-step-edit-key-index next-index))) (defun kmacro-step-edit-insert () @@ -1271,7 +1301,7 @@ following additional answers: `insert', `insert-1', `replace', `replace-1', (setq next-index kmacro-step-edit-key-index) t) (t nil)) - (setq this-command 'ignore) + (setq this-command #'ignore) (setq this-command cmd) (if (memq this-command '(self-insert-command digit-argument)) (setq last-command-event (aref keys (1- (length keys))))) @@ -1284,7 +1314,7 @@ following additional answers: `insert', `insert-1', `replace', `replace-1', (when kmacro-step-edit-active (cond ((eq kmacro-step-edit-active 'ignore) - (setq this-command 'ignore)) + (setq this-command #'ignore)) ((eq kmacro-step-edit-active 'append-end) (if (= executing-kbd-macro-index (length executing-kbd-macro)) (setq executing-kbd-macro (vconcat executing-kbd-macro [nil]) diff --git a/lisp/language/cyril-util.el b/lisp/language/cyril-util.el index e06339cc625..5482b3ea306 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/greek.el b/lisp/language/greek.el index 58f4fe6fc49..920cf67d871 100644 --- a/lisp/language/greek.el +++ b/lisp/language/greek.el @@ -79,7 +79,9 @@ (coding-priority greek-iso-8bit) (nonascii-translation . iso-8859-7) (input-method . "greek") - (documentation . t))) + (documentation . "Support for Greek ISO-8859-7 using the greek input method.") + (sample-text . "Greek (ελληνικά) Γειά σας") + (tutorial . "TUTORIAL.el_GR"))) (provide 'greek) diff --git a/lisp/language/hanja-util.el b/lisp/language/hanja-util.el index 7aa3f024a33..0c2419c91cd 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/ind-util.el b/lisp/language/ind-util.el index 8b1c3d69ae5..60ada03fa25 100644 --- a/lisp/language/ind-util.el +++ b/lisp/language/ind-util.el @@ -273,6 +273,29 @@ (;; Misc Symbols nil ?ஂ ?ஃ nil ?் nil nil) (;; Digits + nil nil nil nil nil nil nil nil nil nil) + (;; Inscript-extra (4) (#, $, ^, *, ]) + "்ர" "ர்" "த்ர" nil nil))) + +(defvar indian-tml-base-digits-table + '( + (;; VOWELS + (?அ nil) (?ஆ ?ா) (?இ ?ி) (?ஈ ?ீ) (?உ ?ு) (?ஊ ?ூ) + nil nil nil (?ஏ ?ே) (?எ ?ெ) (?ஐ ?ை) + nil (?ஓ ?ோ) (?ஒ ?ொ) (?ஔ ?ௌ) nil nil) + (;; CONSONANTS + ?க nil nil nil ?ங ;; GUTTRULS + ?ச nil ?ஜ nil ?ஞ ;; PALATALS + ?ட nil nil nil ?ண ;; CEREBRALS + ?த nil nil nil ?ந ?ன ;; DENTALS + ?ப nil nil nil ?ம ;; LABIALS + ?ய ?ர ?ற ?ல ?ள ?ழ ?வ ;; SEMIVOWELS + nil ?ஷ ?ஸ ?ஹ ;; SIBILANTS + nil nil nil nil nil nil nil nil ;; NUKTAS + "ஜ்ஞ" "க்ஷ") + (;; Misc Symbols + nil ?ஂ ?ஃ nil ?் nil nil) + (;; Digits ?௦ ?௧ ?௨ ?௩ ?௪ ?௫ ?௬ ?௭ ?௮ ?௯) (;; Inscript-extra (4) (#, $, ^, *, ]) "்ர" "ர்" "த்ர" nil nil))) @@ -557,6 +580,10 @@ (defvar indian-tml-itrans-v5-hash (indian-make-hash indian-tml-base-table indian-itrans-v5-table-for-tamil)) + +(defvar indian-tml-itrans-digits-v5-hash + (indian-make-hash indian-tml-base-digits-table + indian-itrans-v5-table-for-tamil)) ) (defmacro indian-translate-region (from to hashtable encode-p) diff --git a/lisp/language/indian.el b/lisp/language/indian.el index e0adb0de6c3..9329b43fea3 100644 --- a/lisp/language/indian.el +++ b/lisp/language/indian.el @@ -45,8 +45,9 @@ (coding-system utf-8) (coding-priority utf-8) (input-method . "devanagari-aiba") + (sample-text . "Devanagari (देवनागरी) नमस्ते / नमस्कार") (documentation . "\ -Such languages using Devanagari script as Hindi and Marathi +Such languages using Devanagari script as Hindi, Marathi and Nepali are supported in this language environment.")) '("Indian")) @@ -55,16 +56,18 @@ are supported in this language environment.")) (coding-system utf-8) (coding-priority utf-8) (input-method . "bengali-itrans") + (sample-text . "Bengali (বাংলা) নমস্কার") (documentation . "\ Such languages using Bengali script as Bengali and Assamese are supported in this language environment.")) '("Indian")) (set-language-info-alist - "Punjabi" '((charset unicode) + "Gurmukhi" '((charset unicode) (coding-system utf-8) (coding-priority utf-8) (input-method . "punjabi-itrans") + (sample-text . "Gurmukhi (ਗੁਰਮੁਖੀ) ਸਤ ਸ੍ਰੀ ਅਕਾਲ") (documentation . "\ North Indian language Punjabi is supported in this language environment.")) '("Indian")) @@ -74,17 +77,31 @@ North Indian language Punjabi is supported in this language environment.")) (coding-system utf-8) (coding-priority utf-8) (input-method . "gujarati-itrans") + (sample-text . "Gujarati (ગુજરાતી) નમસ્તે") (documentation . "\ North Indian language Gujarati is supported in this language environment.")) '("Indian")) (set-language-info-alist + "Odia" '((charset unicode) + (coding-system utf-8) + (coding-priority utf-8) + (input-method . "odia") + (sample-text . "Odia (ଓଡ଼ିଆ) ନମସ୍କାର") + (documentation . "\ +Such languages using the Odia script as Odia, Khonti, and Santali +are supported in this language environment. (This language +environment was formerly known as \"Oriya\").")) + '("Indian")) + +(set-language-info-alist "Oriya" '((charset unicode) - (coding-system utf-8) - (coding-priority utf-8) - (input-method . "oriya-itrans") - (documentation . "\ -Such languages using Oriya script as Oriya, Khonti, and Santali + (coding-system utf-8) + (coding-priority utf-8) + (input-method . "odia") + (sample-text . "Odia (ଓଡ଼ିଆ) ନମସ୍କାର") + (documentation . "\ +Such languages using the Odia script as Odia, Khonti, and Santali are supported in this language environment.")) '("Indian")) @@ -93,6 +110,7 @@ are supported in this language environment.")) (coding-system utf-8) (coding-priority utf-8) (input-method . "tamil-itrans") + (sample-text . "Tamil (தமிழ்) வணக்கம்") (documentation . "\ South Indian Language Tamil is supported in this language environment.")) '("Indian")) @@ -102,6 +120,7 @@ South Indian Language Tamil is supported in this language environment.")) (coding-system utf-8) (coding-priority utf-8) (input-method . "telugu-itrans") + (sample-text . "Telugu (తెలుగు) నమస్కారం") (documentation . "\ South Indian Language Telugu is supported in this language environment.")) '("Indian")) @@ -113,7 +132,7 @@ South Indian Language Telugu is supported in this language environment.")) (input-method . "kannada-itrans") (sample-text . "Kannada (ಕನ್ನಡ) ನಮಸ್ಕಾರ") (documentation . "\ -Kannada language and script is supported in this language +Kannada language and script are supported in this language environment.")) '("Indian")) @@ -122,10 +141,109 @@ environment.")) (coding-system utf-8) (coding-priority utf-8) (input-method . "malayalam-itrans") + (sample-text . "Malayalam (മലയാളം) നമസ്കാരം") (documentation . "\ South Indian language Malayalam is supported in this language environment.")) '("Indian")) +(set-language-info-alist + "Brahmi" '((charset unicode) + (coding-system utf-8) + (coding-priority utf-8) + (input-method . "brahmi") + (sample-text . "Brahmi (𑀩𑁆𑀭𑀸𑀳𑁆𑀫𑀻) 𑀦𑀫𑀲𑁆𑀢𑁂") + (documentation . "\ +The ancient Brahmi script is supported in this language environment.")) + '("Indian")) ; Should we have an "Old" category? + +(set-language-info-alist + "Kaithi" '((charset unicode) + (coding-system utf-8) + (coding-priority utf-8) + (input-method . "kaithi") + (sample-text . "Kaithi (𑂍𑂶𑂟𑂲) 𑂩𑂰𑂧𑂩𑂰𑂧") + (documentation . "\ +Languages such as Awadhi, Bhojpuri, Magahi and Maithili +which used the Kaithi script are supported in this language environment.")) + '("Indian")) + +(set-language-info-alist + "Tirhuta" '((charset unicode) + (coding-system utf-8) + (coding-priority utf-8) + (input-method . "tirhuta") + (sample-text . "Tirhuta (𑒞𑒱𑒩𑒯𑒳𑒞𑒰) 𑒣𑓂𑒩𑒢𑒰𑒧 / 𑒮𑒲𑒞𑒰𑒩𑒰𑒧") + (documentation . "\ +Maithili language and its script Tirhuta are supported in this +language environment.")) + '("Indian")) + +(set-language-info-alist + "Sharada" '((charset unicode) + (coding-system utf-8) + (coding-priority utf-8) + (input-method . "sharada") + (sample-text . "Sharada (𑆯𑆳𑆫𑆢𑆳) 𑆤𑆩𑆱𑇀𑆑𑆳𑆫") + (documentation . "\ +Kashmiri language and its script Sharada are supported in this +language environment.")) + '("Indian")) + +(set-language-info-alist + "Siddham" '((charset unicode) + (coding-system utf-8) + (coding-priority utf-8) + (input-method . "siddham") + (sample-text . "Siddham (𑖭𑖰𑖟𑖿𑖠𑖽) 𑖡𑖦𑖭𑖿𑖝𑖸") + (documentation . "\ +Sanskrit language and one of its script Siddham are supported +in this language environment.")) + '("Indian")) + +(set-language-info-alist + "Syloti Nagri" '((charset unicode) + (coding-system utf-8) + (coding-priority utf-8) + (input-method . "syloti-nagri") + (sample-text . "Syloti Nagri (ꠍꠤꠟꠐꠤ ꠘꠣꠉꠞꠤ) ꠀꠌ꠆ꠍꠣꠟꠣꠝꠥ ꠀꠟꠣꠁꠇꠥꠝ / ꠘꠝꠡ꠆ꠇꠣꠞ") + (documentation . "\ +Sylheti language and its script Syloti Nagri are supported +in this language environment.")) + '("Indian")) + +(set-language-info-alist + "Modi" '((charset unicode) + (coding-system utf-8) + (coding-priority utf-8) + (input-method . "modi") + (sample-text . "Modi (𑘦𑘻𑘚𑘲) 𑘡𑘦𑘭𑘿𑘎𑘰𑘨") + (documentation . "\ +Marathi language and one of its script Modi are supported +in this language environment.")) + '("Indian")) + +(set-language-info-alist + "Limbu" '((charset unicode) + (coding-system utf-8) + (coding-priority utf-8) + (input-method . "limbu") + (sample-text . "Limbu (ᤕᤠᤰᤌᤢᤱ ᤐᤠᤴ) ᤛᤣᤘᤠᤖᤥ") + (documentation . "\ +Limbu language and its script are supported in this +language environment.")) + '("Indian")) + +(set-language-info-alist + "Grantha" '((charset unicode) + (coding-system utf-8) + (coding-priority utf-8) + (input-method . "grantha") + (sample-text . "Grantha (𑌗𑍍𑌰𑌨𑍍𑌥) 𑌨𑌮𑌸𑍍𑌤𑍇 / 𑌨𑌮𑌸𑍍𑌕𑌾𑌰𑌃") + (documentation . "\ +Languages such as Sanskrit and Manipravalam, when they use the +Grantha script, are supported in this language environment.")) + '("Indian")) + ;; Replace mnemonic characters in REGEXP according to TABLE. TABLE is ;; an alist of (MNEMONIC-STRING . REPLACEMENT-STRING). @@ -147,6 +265,8 @@ South Indian language Malayalam is supported in this language environment.")) ("H" . "\u094D") ; HALANT ("s" . "[\u0951\u0952]") ; stress sign ("t" . "[\u0953\u0954]") ; accent + ("1" . "\u0967") ; numeral 1 + ("3" . "\u0969") ; numeral 3 ("N" . "\u200C") ; ZWNJ ("J" . "\u200D") ; ZWJ ("X" . "[\u0900-\u097F]")))) ; all coverage @@ -158,6 +278,8 @@ South Indian language Malayalam is supported in this language environment.")) "Cn?\\(?:J?HJ?Cn?\\)*\\(?:H[NJ]?\\|v*n?a?s?t?A?\\)\\|" ;; special consonant form, or "JHR\\|" + ;; vedic accents with numerals, or + "1ss?\\|3ss\\|s3ss\\|" ;; any other singleton characters "X") table)) @@ -168,14 +290,15 @@ South Indian language Malayalam is supported in this language environment.")) '(("a" . "\u0981") ; SIGN CANDRABINDU ("A" . "[\u0982\u0983]") ; SIGN ANUSVARA .. VISARGA ("V" . "[\u0985-\u0994\u09E0\u09E1]") ; independent vowel - ("C" . "[\u0995-\u09B9\u09DC-\u09DF\u09F1]") ; consonant + ("C" . "[\u0995-\u09B9\u09DC-\u09DF\u09F0\u09F1]") ; consonant ("B" . "[\u09AC\u09AF\u09B0\u09F0]") ; BA, YA, RA ("R" . "[\u09B0\u09F0]") ; RA ("n" . "\u09BC") ; NUKTA ("v" . "[\u09BE-\u09CC\u09D7\u09E2\u09E3]") ; vowel sign ("H" . "\u09CD") ; HALANT ("T" . "\u09CE") ; KHANDA TA - ("N" . "\u200C") ; ZWNJ + ("S" . "\u09FE") ; SANDHI MARK + ("N" . "\u200C") ; ZWNJ ("J" . "\u200D") ; ZWJ ("X" . "[\u0980-\u09FF]")))) ; all coverage (indian-compose-regexp @@ -183,7 +306,7 @@ South Indian language Malayalam is supported in this language environment.")) ;; syllables with an independent vowel, or "\\(?:RH\\)?Vn?\\(?:J?HB\\)?v*n?a?A?\\|" ;; consonant-based syllables, or - "Cn?\\(?:J?HJ?Cn?\\)*\\(?:H[NJ]?\\|v*[NJ]?v?a?A?\\)\\|" + "Cn?\\(?:J?HJ?Cn?\\)*\\(?:H[NJ]?\\|v*[NJ]?v?a?A?S?\\)\\|" ;; another syllables with an independent vowel, or "\\(?:RH\\)?T\\|" ;; special consonant form, or @@ -250,7 +373,7 @@ South Indian language Malayalam is supported in this language environment.")) '(("a" . "\u0B01") ; SIGN CANDRABINDU ("A" . "[\u0B02\u0B03]") ; SIGN ANUSVARA .. VISARGA ("V" . "[\u0B05-\u0B14\u0B60\u0B61]") ; independent vowel - ("C" . "[\u0B15-\u0B39\u0B5C\u0B5D\u0B71]") ; consonant + ("C" . "[\u0B15-\u0B39\u0B5C\u0B5D\u0B5F\u0B71]") ; consonant ("B" . "[\u0B15-\u0B17\u0B1B-\u0B1D\u0B1F-\u0B21\u0B23\u0B24\u0B27-\u0B30\u0B32-\u0B35\u0B38\u0B39]") ; consonant with below form ("R" . "\u0B30") ; RA ("n" . "\u0B3C") ; NUKTA @@ -384,6 +507,232 @@ South Indian language Malayalam is supported in this language environment.")) (list (vector (cdr slot) 0 #'font-shape-gstring)))))) char-script-table)) -(provide 'indian) +;; Brahmi composition rules +(let ((consonant "[\U00011013-\U00011034]") + (non-consonant "[^\U00011013-\U00011034\U00011046\U0001107F]") + (vowel "[\U00011038-\U00011045]") + (numeral "[\U00011052-\U00011065]") + (multiplier "[\U00011064\U00011065]") + (virama "\U00011046") + (number-joiner "\U0001107F")) + (set-char-table-range composition-function-table + '(#x11046 . #x11046) + (list (vector + ;; Consonant conjuncts + (concat consonant "\\(?:" virama consonant "\\)+" + vowel "?") + 1 'font-shape-gstring) + (vector + ;; Vowelless consonants + (concat consonant virama non-consonant) + 1 'font-shape-gstring))) + (set-char-table-range composition-function-table + '(#x1107F . #x1107F) + (list (vector + ;; Additive-multiplicative numerals + (concat multiplier number-joiner numeral) + 1 'font-shape-gstring)))) + +;; Kaithi composition rules +(let ((consonant "[\x1108D-\x110AF]") + (nukta "\x110BA") + (independent-vowel "[\x11083-\x1108C]") + (vowel "[\x1108D-\x110C2]") + (nasal "[\x11080\x11081]") + (virama "\x110B9") + (number-sign "\x110BD") + (number-sign-above "\x110CD") + (numerals "[\x966-\x96F]+") + (zwj "\x200D")) + (set-char-table-range composition-function-table + '(#x110B0 . #x110BA) + (list (vector + ;; Consonant based syllables + (concat consonant nukta "?\\(?:" virama zwj "?" consonant + nukta "?\\)*\\(?:" virama zwj "?\\|" vowel "*" nukta + "?" nasal "?\\)") + 1 'font-shape-gstring) + (vector + ;; Vowel based syllables + (concat independent-vowel nukta "?" virama "?" vowel "?") + 1 'font-shape-gstring))) + (set-char-table-range composition-function-table + '(#x110BD . #x110BD) + (list (vector + ;; Number sign + (concat number-sign numerals) + 0 'font-shape-gstring))) + (set-char-table-range composition-function-table + '(#x110CD . #x110CD) + (list (vector + ;; Number sign above + (concat number-sign-above numerals) + 0 'font-shape-gstring)))) + +;; Tirhuta composition rules +(let ((consonant "[\x1148F-\x114AF]") + (nukta "\x114C3") + (independent-vowel "[\x11481-\x1148E]") + (vowel "[\x114B0-\x114BE]") + (nasal "[\x114BF\x114C0]") + (virama "\x114C2")) + (set-char-table-range composition-function-table + '(#x114B0 . #x114C3) + (list (vector + ;; Consonant based syllables + (concat consonant nukta "?\\(?:" virama consonant nukta + "?\\)*\\(?:" virama "\\|" vowel "*" nukta "?" + nasal "?\\)") + 1 'font-shape-gstring) + (vector + ;; Vowel based syllables + (concat independent-vowel nukta "?" virama "?" vowel "?" nasal "?") + 1 'font-shape-gstring)))) + +;; Sharada composition rules +(let ((consonant "[\x11191-\x111B2]") + (nukta "\x111CA") + (independent-vowel "[\x11183-\x11190]") + (vowel "[\x111B3-\x111BF\x111CE]") + (vowel-modifier "\x111CB") + (extra-short-vowel-mark "\x111CC") + (nasal "[\x11181\x11180\x111CF]") + (virama "\x111C0") + (fricatives "[\x111C2\x111C3]") + (sandhi-mark "\x111C9") + (misc "[\x111C4-\x111C8\x111CD]")) + (set-char-table-range composition-function-table + '(#x111B3 . #x111CE) + (list (vector + ;; Consonant based syllables + (concat consonant nukta "?" vowel-modifier "?\\(?:" virama + consonant nukta "?" vowel-modifier "?\\)*\\(?:" virama + "\\|" vowel "*" nukta "?" nasal "?" extra-short-vowel-mark + "?" vowel-modifier "?" sandhi-mark "?+" misc "?\\)") + 1 'font-shape-gstring) + (vector + ;; Vowel based syllables + (concat independent-vowel nukta "?" vowel-modifier "?" virama "?" + vowel "?" extra-short-vowel-mark "?" sandhi-mark "?" + fricatives "?" misc "?") + 1 'font-shape-gstring) + (vector + ;; Fricatives with Consonants + (concat fricatives "?" consonant vowel "?") + 0 'font-shape-gstring)))) + +;; Siddham composition rules +(let ((consonant "[\x1158E-\x115AE]") + (nukta "\x115C0") + (independent-vowel "[\x11580-\x1158D\x115D8-\x115DB]") + (vowel "[\x115AF-\x115BB\x115DC\x115DD]") + (nasal "[\x115BC\x115BD]") + (visarga "\x115BE") + (virama "\x115BF")) + (set-char-table-range composition-function-table + '(#x115AF . #x115C0) + (list (vector + ;; Consonant based syllables + (concat consonant nukta "?" "\\(?:" virama consonant nukta + "?\\)*\\(?:" virama "\\|" vowel "*" nukta "?" nasal + "?" visarga "?\\)") + 1 'font-shape-gstring) + (vector + ;; Vowels based syllables + (concat independent-vowel nukta "?" virama "?" vowel "?" + nasal "?" visarga "?") + 1 'font-shape-gstring)))) + +;; Syloti Nagri composition rules +(let ((consonant "[\xA807-\xA80A\xA80C-\xA822]") + (vowel "[\xA802\xA823-\xA827]") + (nasal "[\xA80B]") + (virama "\xA806") + (alternate-virama "\xA82C")) + (set-char-table-range composition-function-table + '(#xA806 . #xA806) + (list (vector + ;; Consonant conjunct based syllables + (concat consonant "\\(?:" virama consonant "\\)+" + vowel "?" nasal "?") + 1 'font-shape-gstring))) + (set-char-table-range composition-function-table + '(#xA823 . #xA827) + (list (vector + ;; Non Consonant conjunct based syllables + (concat consonant vowel nasal "?") + 1 'font-shape-gstring))) + (set-char-table-range composition-function-table + '(#xA82C . #xA82C) + (list (vector + ;; Consonant with the alternate virama + (concat consonant "\\(?:" alternate-virama consonant "\\)+" + vowel "?" nasal "?") + 1 'font-shape-gstring)))) + +;; Modi composition rules +(let ((consonant "[\x1160E-\x1162F]") + (independent-vowel "[\x11600-\x1160D]") + (vowel "[\x11630-\x1163C]") + (nasal "\x1163D") + (visarga "\x1163E") + (virama "\x1163F") + (ardhacandra "\x11640")) + (set-char-table-range composition-function-table + '(#x11630 . #x11640) + (list (vector + ;; Consonant based syllables + (concat consonant "\\(?:" virama consonant "\\)*\\(?:" + virama "\\|" vowel "*" ardhacandra "?" nasal + "?" visarga "?\\)") + 1 'font-shape-gstring) + (vector + ;; Vowels based syllables + (concat independent-vowel virama "?" vowel "?" ardhacandra + nasal "?" visarga "?") + 1 'font-shape-gstring)))) + +;; Limbu composition rules +(let ((consonant "[\x1900-\x191E]") + (vowel "[\x1920-\x1928]") + (subjoined-letter "[\x1929-\x192B]") + (small-letter "[\x1930-\x1938]") + (other-signs "[\x1939\x193A]") + (sa-i "\x193B")) + (set-char-table-range composition-function-table + '(#x1920 . #x193B) + (list (vector + ;; Consonant based syllables + (concat consonant sa-i "?" subjoined-letter "?" small-letter + "?" vowel "?" other-signs "?") + 1 'font-shape-gstring)))) + +;; Grantha composition rules +(let ((consonant "[\x11315-\x11339]") + (nukta "\x1133C") + (independent-vowel "[\x11305-\x11314\x11360\x11361]") + (vowel "[\x1133E-\x1134C\x11357\x11362\x11363]") + (nasal "[\x11300-\x11302]") + (bindu "\x1133B") + (visarga "\x11303") + (virama "\x1134D") + (avagraha "\x1133D") + (modifier-above "[\x11366-\x11374]")) + (set-char-table-range composition-function-table + '(#x1133B . #x1134D) + (list (vector + ;; Consonant based syllables + (concat consonant nukta "?" "\\(?:" virama consonant nukta + "?\\)*\\(?:" virama "\\|" vowel "*" nukta "?" nasal + "?" bindu "?" visarga "?" modifier-above "?" + avagraha "?\\)") + 1 'font-shape-gstring) + (vector + ;; Vowels based syllables + (concat independent-vowel nukta "?" virama "?" vowel "?" + nasal "?" bindu "?" visarga "?" modifier-above + "?" avagraha "?") + 1 'font-shape-gstring)))) +(provide 'indian) ;;; indian.el ends here diff --git a/lisp/language/indonesian.el b/lisp/language/indonesian.el new file mode 100644 index 00000000000..699f8192543 --- /dev/null +++ b/lisp/language/indonesian.el @@ -0,0 +1,197 @@ +;;; indonesian.el --- Indonesian languages support -*- coding: utf-8; lexical-binding: t; -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; Author: समीर सिंह Sameer Singh <lumarzeli30@gmail.com> +;; Keywords: multilingual, input method, i18n, Indonesia + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This file contains definitions of Indonesia language environments, and +;; setups for displaying the scripts used there. + +;;; Code: + +(set-language-info-alist + "Balinese" '((charset unicode) + (coding-system utf-8) + (coding-priority utf-8) + (input-method . "balinese") + (sample-text . "Balinese (ᬅᬓ᭄ᬱᬭᬩᬮᬶ) ᬒᬁᬲ᭄ᬯᬲ᭄ᬢ᭄ᬬᬲ᭄ᬢᬸ") + (documentation . "\ +Balinese language and its script are supported in this language environment."))) + +(set-language-info-alist + "Javanese" '((charset unicode) + (coding-system utf-8) + (coding-priority utf-8) + (input-method . "javanese") + (sample-text . "Javanese (ꦲꦏ꧀ꦱꦫꦗꦮ) ꦲꦭꦺꦴ") + (documentation . "\ +Javanese language and its script are supported in this language environment."))) + +(set-language-info-alist + "Sundanese" '((charset unicode) + (coding-system utf-8) + (coding-priority utf-8) + (input-method . "sundanese") + (sample-text . "Sundanese (ᮃᮊ᮪ᮞᮛᮞᮥᮔ᮪ᮓ) ᮞᮙ᮪ᮕᮥᮛᮞᮥᮔ᮪") + (documentation . "\ +Sundanese language and its script are supported in this language environment."))) + +(set-language-info-alist + "Batak" '((charset unicode) + (coding-system utf-8) + (coding-priority utf-8) + (input-method . "batak") + (sample-text . "Batak (ᯘᯮᯒᯗ᯲ᯅᯗᯂ᯲) ᯂᯬᯒᯘ᯲ / ᯔᯧᯐᯬᯀᯱᯐᯬᯀᯱ") + (documentation . "\ +Languages that use the Batak script, such as Karo, Toba, Pakpak, Mandailing +and Simalungun, are supported in this language environment."))) + +(set-language-info-alist + "Rejang" '((charset unicode) + (coding-system utf-8) + (coding-priority utf-8) + (input-method . "rejang") + (sample-text . "Rejang (ꥆꤰ꥓ꤼꤽ ꤽꥍꤺꥏ) ꤸꥉꥐꤺꥉꥂꥎ") + (documentation . "\ +Rejang language and its script are supported in this language environment."))) + +(set-language-info-alist + "Makasar" '((charset unicode) + (coding-system utf-8) + (coding-priority utf-8) + (input-method . "makasar") + (sample-text . "Makasar (𑻪𑻢𑻪𑻢) 𑻦𑻤𑻵𑻱") + (documentation . "\ +Makassarese language and its script Makasar are supported in this language environment."))) + +(set-language-info-alist + "Buginese" '((charset unicode) + (coding-system utf-8) + (coding-priority utf-8) + (input-method . "lontara") + (sample-text . "Buginese (ᨒᨚᨈᨑ) ᨖᨒᨚ") + (documentation . "\ +Buginese language and its script Lontara are supported in this language environment."))) + +;; Balinese composition rules +(let ((consonant "[\x1B13-\x1B33\x1B45-\x1B4B]") + (independent-vowel "[\x1B05-\x1B12]") + (rerekan "\x1B34") + (vowel "[\x1B35-\x1B43]") + (modifier-above "[\x1B00-\x1B04]") + (adeg-adeg "\x1B44") + (musical-symbol "[\x1B6B-\x1B73]")) + (set-char-table-range composition-function-table + '(#x1B34 . #x1B44) + (list (vector + ;; Consonant based syllables + (concat consonant rerekan "?\\(?:" adeg-adeg consonant + rerekan "?\\)*\\(?:" adeg-adeg "\\|" vowel "*" rerekan + "?" modifier-above "?" musical-symbol "?\\)") + 1 'font-shape-gstring) + (vector + ;; Vowels based syllables + (concat independent-vowel rerekan "?" adeg-adeg "?" + vowel "?" modifier-above "?" musical-symbol "?") + 1 'font-shape-gstring)))) + +;; Javanese composition rules +(let ((consonant "[\xA98F-\xA9B2]") + (independent-vowel "[\xA984-\xA98E]") + (telu "\xA9B3") + (vowel "[\xA9B4-\xA9BC]") + (dependant-consonant "[\xA9BD-\xA9BF]") + (modifier-above "[\xA980-\xA983]") + (pangkon "\xA9C0")) + (set-char-table-range composition-function-table + '(#xA9B3 . #xA9C0) + (list (vector + ;; Consonant based syllables + (concat consonant telu "?\\(?:" pangkon consonant + telu "?\\)*\\(?:" pangkon "\\|" vowel "*" telu + "?" modifier-above "?" dependant-consonant "?\\)") + 1 'font-shape-gstring) + (vector + ;; Vowels based syllables + (concat independent-vowel telu "?" pangkon "?" + vowel "?" modifier-above "?" dependant-consonant "?") + 1 'font-shape-gstring)))) + +;; Sundanese composition rules +(let ((consonant "[\x1B8A-\x1BA0\x1BAE\x1BAF\x1BBB-\x1BBF]") + (independent-vowel "[\x1B83-\x1B89]") + (vowel "[\x1BA4-\x1BA9]") + (dependant-consonant "[\x1BA1-\x1BA3\x1BAC-\x1BAD]") + (modifier-above "[\x1B80-\x1B82]") + (virama "[\x1BAA\x1BAB]")) + (set-char-table-range composition-function-table + '(#x1BA1 . #x1BAD) + (list (vector + ;; Consonant based syllables + (concat consonant "\\(?:" virama consonant + "\\)*\\(?:" virama "\\|" vowel "*" + modifier-above "?" dependant-consonant "?\\)") + 1 'font-shape-gstring) + (vector + ;; Vowels based syllables + (concat independent-vowel virama "?" + vowel "?" modifier-above "?" dependant-consonant "?") + 1 'font-shape-gstring)))) + +;; Batak composition rules +(let ((akshara "[\x1BC0-\x1BE5]") + (vowel "[\x1BE7-\x1BEF]") + (dependant-consonant "[\x1BF0\x1BF1]") + (modifier-above "\x1BE6") + (virama "[\x1BF2\x1BF3]")) + (set-char-table-range composition-function-table + '(#x1BE6 . #x1BF3) + (list (vector + ;; Akshara based syllables + (concat akshara virama "?" vowel "*" modifier-above + "?" dependant-consonant "?") + 1 'font-shape-gstring)))) + +;; Rejang composition rules +(let ((akshara "[\xA930-\xA946]") + (vowel "[\xA947-\xA94E]") + (dependant-consonant "[\xA94F\xA952]") + (virama "\xA953")) + (set-char-table-range composition-function-table + '(#xA947 . #xA953) + (list (vector + ;; Akshara based syllables + (concat akshara virama "?" vowel "*" + dependant-consonant "?") + 1 'font-shape-gstring)))) + +;; Makasar composition rules +(let ((akshara "[\x11EE0-\x11EF2]") + (vowel "[\x11EF3-\x11EF6]")) + (set-char-table-range composition-function-table + '(#x11EF3 . #x11EF6) + (list (vector + ;; Akshara based syllables + (concat akshara vowel "*") + 1 'font-shape-gstring)))) + +(provide 'indonesian) +;;; indonesian.el ends here diff --git a/lisp/language/lao.el b/lisp/language/lao.el index 5c545df4840..1861eff15eb 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/language/misc-lang.el b/lisp/language/misc-lang.el index c8a4821abf7..46429a4380d 100644 --- a/lisp/language/misc-lang.el +++ b/lisp/language/misc-lang.el @@ -212,6 +212,28 @@ thin (i.e. 1-dot width) space." (list (vector "[\U00013000-\U0001342E]+" 0 #'font-shape-gstring)))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Hanifi Rohingya +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(set-language-info-alist + "Hanifi Rohingya" '((charset unicode) + (coding-system utf-8) + (coding-priority utf-8) + (input-method . "hanifi-rohingya") + (sample-text . "Hanifi Rohingya (𐴌𐴟𐴇𐴥𐴝𐴚𐴒𐴙𐴝 𐴇𐴝𐴕𐴞𐴉𐴞 𐴓𐴠𐴑𐴤𐴝) 𐴀𐴝𐴏𐴓𐴝𐴀𐴡𐴤𐴛𐴝𐴓𐴝𐴙𐴑𐴟𐴔") + (documentation . "\ +Rohingya language and its script Hanifi Rohingya are supported +in this language environment."))) + +;; Hanifi Rohingya composition rules +(set-char-table-range + composition-function-table + '(#x10D1D . #x10D27) + (list (vector + "[\x10D00-\x10D27]+" + 1 'font-shape-gstring))) + (provide 'misc-lang) ;;; misc-lang.el ends here diff --git a/lisp/language/philippine.el b/lisp/language/philippine.el new file mode 100644 index 00000000000..e52ad6912cd --- /dev/null +++ b/lisp/language/philippine.el @@ -0,0 +1,96 @@ +;;; philippine.el --- Philippine languages support -*- coding: utf-8; lexical-binding: t; -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; Author: समीर सिंह Sameer Singh <lumarzeli30@gmail.com> +;; Keywords: multilingual, input method, i18n, Philippines + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This file contains definitions of Philippine language environments, and +;; setups for displaying the scripts used there. + +;;; Code: + +(set-language-info-alist + "Tagalog" '((charset unicode) + (coding-system utf-8) + (coding-priority utf-8) + (input-method . "tagalog") + (sample-text . "Tagalog (ᜊᜌ᜔ᜊᜌᜒᜈ᜔) ᜃᜓᜋᜓᜐ᜔ᜆ") + (documentation . "\ +Tagalog language using the Baybayin script is supported in +this language environment."))) + +(set-language-info-alist + "Hanunoo" '((charset unicode) + (coding-system utf-8) + (coding-priority utf-8) + (input-method . "hanunoo") + (sample-text . "Hanunoo (ᜱᜨᜳᜨᜳᜢ) ᜫᜬᜧ᜴ ᜣᜭᜯᜥ᜴ ᜰᜲᜭᜥ᜴") + (documentation . "\ +Philippine Language Hanunoo is supported in this language environment."))) + +(set-language-info-alist + "Buhid" '((charset unicode) + (coding-system utf-8) + (coding-priority utf-8) + (input-method . "buhid") + (documentation . "\ +Philippine Language Buhid is supported in this language environment."))) + +(set-language-info-alist + "Tagbanwa" '((charset unicode) + (coding-system utf-8) + (coding-priority utf-8) + (input-method . "tagbanwa") + (sample-text . "Tagbanwa (ᝦᝪᝯ) ᝫᝩᝬᝥ ᝣᝮᝧᝯ") + (documentation . "\ +Philippine Languages Tagbanwa are supported in this language environment."))) + +;; Tagalog composition rules +(let ((akshara "[\x1700-\x1711\x171F]") + (vowel "[\x1712\x1713]") + (virama "\x1714") + (pamudpod "\x1715")) + (set-char-table-range composition-function-table + '(#x1714 . #x1714) + (list (vector + ;; Akshara virama syllables + (concat akshara virama vowel "?") + 1 'font-shape-gstring))) + (set-char-table-range composition-function-table + '(#x1715 . #x1715) + (list (vector + ;; Akshara pamudpod syllables + (concat akshara pamudpod vowel "?") + 1 'font-shape-gstring)))) + +;; Hanunoo composition rules +(let ((akshara "[\x1720-\x1731]") + (vowel "[\x1732\x1733]") + (pamudpod "\x1734")) + (set-char-table-range composition-function-table + '(#x1734 . #x1734) + (list (vector + ;; Akshara pamudpod syllables + (concat akshara pamudpod vowel "?") + 1 'font-shape-gstring)))) + +(provide 'philippine) +;;; philippine.el ends here diff --git a/lisp/language/thai-util.el b/lisp/language/thai-util.el index d11daf0f839..6c004e9495c 100644 --- a/lisp/language/thai-util.el +++ b/lisp/language/thai-util.el @@ -244,15 +244,13 @@ positions (integers or markers) specifying the region." ;; Thai-word-mode requires functions in the feature `thai-word'. (require 'thai-word) -(defvar thai-word-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [remap forward-word] 'thai-forward-word) - (define-key map [remap backward-word] 'thai-backward-word) - (define-key map [remap kill-word] 'thai-kill-word) - (define-key map [remap backward-kill-word] 'thai-backward-kill-word) - (define-key map [remap transpose-words] 'thai-transpose-words) - map) - "Keymap for `thai-word-mode'.") +(defvar-keymap thai-word-mode-map + :doc "Keymap for `thai-word-mode'." + "<remap> <forward-word>" #'thai-forward-word + "<remap> <backward-word>" #'thai-backward-word + "<remap> <kill-word>" #'thai-kill-word + "<remap> <backward-kill-word>" #'thai-backward-kill-word + "<remap> <transpose-words>" #'thai-transpose-words) (define-minor-mode thai-word-mode "Minor mode to make word-oriented commands aware of Thai words. diff --git a/lisp/language/thai.el b/lisp/language/thai.el index 6a6289a44c7..60f5f9d2a38 100644 --- a/lisp/language/thai.el +++ b/lisp/language/thai.el @@ -82,6 +82,43 @@ This is the same as `thai-tis620' with the addition of no-break-space." (aset composition-function-table (aref chars i) elt))) (aset composition-function-table ?ำ '(["[ก-ฯ]." 1 thai-composition-function])) +;; Tai-Tham + +(set-language-info-alist + "Northern Thai" '((charset unicode) + (coding-system utf-8) + (coding-priority utf-8) + (sample-text . + "Northern Thai (ᨣᩣᩴᨾᩮᩬᩥᨦ / ᨽᩣᩈᩣᩃ᩶ᩣ᩠ᨶᨶᩣ) ᩈ᩠ᩅᩢᩔ᩠ᨯᩦᨣᩕᩢ᩠ᨸ") + (documentation . t))) + +;; From Richard Wordingham <richard.wordingham@ntlworld.com>: +(defvar tai-tham-composable-pattern + (let ((table + ;; C is letters, independent vowels, digits, punctuation and symbols. + '(("C" . "[\u1A20-\u1A54\u1A80-\u1A89\u1A90-\u1A99\u1AA0-\u1AAD]") + ("M" . ; Marks, CGJ, ZWNJ, ZWJ + "[\u0324\u034F\u0E49\u0E4A\u0E4B\u1A55-\u1A57\u1A59-\u1A5E\u1A61-\u1A7C\u1A7F\u200C\200D]") + ("H" . "\u1A60") ; Sakot + ("S" . ; Marks commuting with sakot + "[\u0E49-\u0E4B\u0EC9\u0ECB\u1A75-\u1A7C]") + ("N" . "\u1A58"))) ; mai kang lai + (basic-syllable "C\\(N*\\(M\\|HS*C\\)\\)*") + (regexp "X\\(N\\(X\\)?\\)*H?")) ; where X is basic syllable + (let ((case-fold-search nil)) + (setq regexp (replace-regexp-in-string "X" basic-syllable regexp t t)) + (dolist (elt table) + (setq regexp (replace-regexp-in-string (car elt) (cdr elt) + regexp t t)))) + regexp)) + +(let ((elt (list (vector tai-tham-composable-pattern 0 'font-shape-gstring) + ))) + (set-char-table-range composition-function-table '(#x1A20 . #x1A54) elt) + (set-char-table-range composition-function-table '(#x1A80 . #x1A89) elt) + (set-char-table-range composition-function-table '(#x1A90 . #x1A99) elt) + (set-char-table-range composition-function-table '(#x1AA0 . #x1AAD) elt)) + (provide 'thai) ;;; thai.el ends here diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el index 78d6bb52017..d63c0066788 100644 --- a/lisp/ldefs-boot.el +++ b/lisp/ldefs-boot.el @@ -1,7 +1,11 @@ ;;; loaddefs.el --- automatically extracted autoloads -*- lexical-binding: t -*- +;; This file will be copied to ldefs-boot.el and checked in periodically. ;; ;;; Code: +(autoload 'loaddefs-generate "loaddefs-gen") +(autoload 'loaddefs-generate-batch "loaddefs-gen") + ;;;### (autoloads nil "5x5" "play/5x5.el" (0 0 0 0)) ;;; Generated autoloads from play/5x5.el @@ -338,11 +342,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 +375,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 +403,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-*\\\\)(\") @@ -513,20 +530,6 @@ Return t if `allout-mode' is active in current buffer." nil t) (autoload 'allout-mode "allout" "\ Toggle Allout outline mode. -This is a minor mode. If called interactively, toggle the `Allout -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 `allout-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - \\<allout-mode-map-value> Allout outline mode is a minor mode that provides extensive outline oriented formatting and manipulation. It enables @@ -787,6 +790,20 @@ CONCEALED: CLOSED: A TOPIC whose immediate OFFSPRING and body-text is CONCEALED. OPEN: A TOPIC that is not CLOSED, though its OFFSPRING or BODY may be. +This is a minor mode. If called interactively, toggle the +`Allout 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 `allout-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (defalias 'outlinify-sticky #'outlineify-sticky) @@ -837,20 +854,6 @@ See `allout-widgets-mode' for allout widgets mode features.") (autoload 'allout-widgets-mode "allout-widgets" "\ Toggle Allout Widgets mode. -This is a minor mode. If called interactively, toggle the -`Allout-Widgets 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 `allout-widgets-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Allout Widgets mode is an extension of Allout mode that provides graphical decoration of outline structure. It is meant to operate along with `allout-mode', via `allout-mode-hook'. @@ -869,6 +872,20 @@ The bullet-icon and guide line graphics provide keybindings and mouse bindings for easy outline navigation and exposure control, extending outline hot-spot navigation (see `allout-mode'). +This is a minor mode. If called interactively, toggle the +`Allout-Widgets 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 `allout-widgets-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 "allout-widgets" '("allout-")) @@ -1116,6 +1133,9 @@ consider all symbols (if they match PATTERN). Return list of symbols and documentation found. +The *Apropos* window will be selected if `help-window-select' is +non-nil. + \(fn PATTERN &optional DO-ALL)" t nil) (autoload 'apropos-library "apropos" "\ @@ -1272,20 +1292,6 @@ Entering array mode calls the function `array-mode-hook'. (autoload 'artist-mode "artist" "\ Toggle Artist mode. -This is a minor mode. If called interactively, toggle the `Artist -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 `artist-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Artist lets you draw lines, squares, rectangles and poly-lines, ellipses and circles with your mouse and/or keyboard. @@ -1481,6 +1487,20 @@ Keymap summary \\{artist-mode-map} +This is a minor mode. If called interactively, toggle the +`Artist 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 `artist-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 "artist" '("artist-")) @@ -1567,78 +1587,6 @@ key2: value2 ;;;*** -;;;### (autoloads nil "autoarg" "autoarg.el" (0 0 0 0)) -;;; Generated autoloads from autoarg.el - -(defvar autoarg-mode nil "\ -Non-nil if Autoarg mode is enabled. -See the `autoarg-mode' command -for a description of this minor mode.") - -(custom-autoload 'autoarg-mode "autoarg" nil) - -(autoload 'autoarg-mode "autoarg" "\ -Toggle Autoarg mode, a global minor mode. - -\\<autoarg-mode-map> -In Autoarg mode, digits are bound to `digit-argument', i.e. they -supply prefix arguments as C-DIGIT and M-DIGIT normally do. -Furthermore, C-DIGIT inserts DIGIT. -\\[autoarg-terminate] terminates the prefix sequence and inserts -the digits of the autoarg sequence into the buffer. -Without a numeric prefix arg, the normal binding of \\[autoarg-terminate] -is invoked, i.e. what it would be with Autoarg mode off. - -For example: -`6 9 \\[autoarg-terminate]' inserts `69' into the buffer, as does `C-6 C-9'. -`6 9 a' inserts 69 `a's into the buffer. -`6 9 \\[autoarg-terminate] \\[autoarg-terminate]' inserts `69' into the buffer and -then invokes the normal binding of \\[autoarg-terminate]. -`\\[universal-argument] \\[autoarg-terminate]' invokes the normal binding of \\[autoarg-terminate] four times. - -\\{autoarg-mode-map} - -\(fn &optional ARG)" t nil) - -(defvar autoarg-kp-mode nil "\ -Non-nil if Autoarg-Kp mode is enabled. -See the `autoarg-kp-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 `autoarg-kp-mode'.") - -(custom-autoload 'autoarg-kp-mode "autoarg" nil) - -(autoload 'autoarg-kp-mode "autoarg" "\ -Toggle Autoarg-KP mode, a global minor mode. - -This is a minor mode. If called interactively, toggle the `Autoarg-Kp -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 \\='autoarg-kp-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - -\\<autoarg-kp-mode-map> -This is similar to `autoarg-mode' but rebinds the keypad keys -`kp-1' etc. to supply digit arguments. - -\\{autoarg-kp-mode-map} - -\(fn &optional ARG)" t nil) - -(register-definition-prefixes "autoarg" '("autoarg-")) - -;;;*** - ;;;### (autoloads nil "autoconf" "progmodes/autoconf.el" (0 0 0 0)) ;;; Generated autoloads from progmodes/autoconf.el @@ -1665,6 +1613,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 @@ -1678,22 +1628,22 @@ or call the function `auto-insert-mode'.") (autoload 'auto-insert-mode "autoinsert" "\ Toggle Auto-insert mode, a global minor mode. -This is a minor mode. If called interactively, toggle the -`Auto-Insert mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +When Auto-insert mode is enabled, when new files are created you can +insert a template for the file depending on the mode of the buffer. -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. +This is a global minor mode. If called interactively, toggle the +`Auto-Insert 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 \\='auto-insert-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -When Auto-insert mode is enabled, when new files are created you can -insert a template for the file depending on the mode of the buffer. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -1774,20 +1724,6 @@ should be non-nil)." nil nil) (autoload 'auto-revert-mode "autorevert" "\ Toggle reverting buffer when the file changes (Auto-Revert Mode). -This is a minor mode. If called interactively, toggle the -`Auto-Revert 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 `auto-revert-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Auto-Revert Mode is a minor mode that affects only the current buffer. When enabled, it reverts the buffer when the file on disk changes. @@ -1803,6 +1739,20 @@ Use `global-auto-revert-mode' to automatically revert all buffers. Use `auto-revert-tail-mode' if you know that the file will only grow without being changed in the part that is already in the buffer. +This is a minor mode. If called interactively, toggle the +`Auto-Revert 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 `auto-revert-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'turn-on-auto-revert-mode "autorevert" "\ @@ -1814,20 +1764,6 @@ This function is designed to be added to hooks, for example: (autoload 'auto-revert-tail-mode "autorevert" "\ Toggle reverting tail of buffer when the file grows. -This is a minor mode. If called interactively, toggle the -`Auto-Revert-Tail 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 `auto-revert-tail-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - When Auto-Revert Tail Mode is enabled, the tail of the file is constantly followed, as with the shell command `tail -f'. This means that whenever the file grows on disk (presumably because @@ -1843,6 +1779,21 @@ suppressed by setting `auto-revert-verbose' to nil. Use `auto-revert-mode' for changes other than appends! +This is a minor mode. If called interactively, toggle the +`Auto-Revert-Tail 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 `auto-revert-tail-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'turn-on-auto-revert-tail-mode "autorevert" "\ @@ -1864,20 +1815,6 @@ or call the function `global-auto-revert-mode'.") (autoload 'global-auto-revert-mode "autorevert" "\ Toggle Global Auto-Revert Mode. -This is a minor mode. If called interactively, toggle the `Global -Auto-Revert 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 \\='global-auto-revert-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Global Auto-Revert Mode is a global minor mode that reverts any buffer associated with a file when the file changes on disk. Use `auto-revert-mode' to revert a particular buffer. @@ -1895,6 +1832,21 @@ This function calls the hook `global-auto-revert-mode-hook'. It displays the text that `global-auto-revert-mode-text' specifies in the mode line. +This is a global minor mode. If called interactively, toggle the +`Global Auto-Revert 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 \\='global-auto-revert-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 "autorevert" '("auto-revert-" "global-auto-revert-")) @@ -2003,24 +1955,24 @@ or call the function `display-battery-mode'.") (autoload 'display-battery-mode "battery" "\ Toggle battery status display in mode line (Display Battery mode). -This is a minor mode. If called interactively, toggle the +The text displayed in the mode line is controlled by +`battery-mode-line-format' and `battery-status-function'. +The mode line is be updated every `battery-update-interval' +seconds. + +This is a global minor mode. If called interactively, toggle the `Display-Battery 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. +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 \\='display-battery-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -The text displayed in the mode line is controlled by -`battery-mode-line-format' and `battery-status-function'. -The mode line is be updated every `battery-update-interval' -seconds. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -2366,12 +2318,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" "\ @@ -2712,27 +2659,6 @@ The optional argument IGNORED is not used. \(fn URL &optional IGNORED)" t nil) -(autoload 'browse-url-netscape "browse-url" "\ -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'. - -\(fn URL &optional NEW-WINDOW)" t nil) - -(make-obsolete 'browse-url-netscape 'nil '"25.1") - (autoload 'browse-url-mozilla "browse-url" "\ Ask the Mozilla WWW browser to load URL. Default to the URL around or before point. The strings in variable @@ -2779,27 +2705,19 @@ The optional argument NEW-WINDOW is not used. \(fn URL &optional NEW-WINDOW)" t nil) -(autoload 'browse-url-galeon "browse-url" "\ -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'. +(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. -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. +\(fn URL &optional NEW-WINDOW)" t nil) -When called non-interactively, optional second argument NEW-WINDOW is -used instead of `browse-url-new-window-flag'. +(autoload 'browse-url-default-haiku-browser "browse-url" "\ +Browse URL with the system default browser. +Default to the URL around or before point. \(fn URL &optional NEW-WINDOW)" t nil) -(make-obsolete 'browse-url-galeon 'nil '"25.1") - (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 @@ -2808,7 +2726,7 @@ currently selected window instead. \(fn URL &optional SAME-WINDOW)" t nil) (autoload 'browse-url-gnome-moz "browse-url" "\ -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. @@ -3026,18 +2944,18 @@ columns on its right towards the left. Toggle hyperlinking bug references in the buffer (Bug Reference mode). This is a minor mode. If called interactively, toggle the -`Bug-Reference mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +`Bug-Reference 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. +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 `bug-reference-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -3045,18 +2963,19 @@ disabled. Like `bug-reference-mode', but only buttonize in comments and strings. This is a minor mode. If called interactively, toggle the -`Bug-Reference-Prog mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Bug-Reference-Prog 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. +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 `bug-reference-prog-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -3082,6 +3001,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 +3362,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 +4393,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 +4681,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. @@ -4801,26 +4737,26 @@ Prefix argument is the same as for `checkdoc-defun'." t nil) (autoload 'checkdoc-minor-mode "checkdoc" "\ Toggle automatic docstring checking (Checkdoc minor mode). -This is a minor mode. If called interactively, toggle the `Checkdoc -minor 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 `checkdoc-minor-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - In Checkdoc minor mode, the usual bindings for `eval-defun' which is bound to \\<checkdoc-minor-mode-map>\\[checkdoc-eval-defun] and `checkdoc-eval-current-buffer' are overridden to include checking of documentation strings. \\{checkdoc-minor-mode-map} +This is a minor mode. If called interactively, toggle the +`Checkdoc minor 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 `checkdoc-minor-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'checkdoc-package-keywords "checkdoc" "\ @@ -4920,20 +4856,20 @@ or call the function `cl-font-lock-built-in-mode'.") (autoload 'cl-font-lock-built-in-mode "cl-font-lock" "\ Highlight built-in functions, variables, and types in `lisp-mode'. -This is a minor mode. If called interactively, toggle the +This is a global minor mode. If called interactively, toggle the `Cl-Font-Lock-Built-In mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable the -mode. +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. +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 \\='cl-font-lock-built-in-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -5020,7 +4956,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (autoload 'cl-generic-define-method "cl-generic" "\ -\(fn NAME QUALIFIERS ARGS USES-CNM FUNCTION)" nil nil) +\(fn NAME QUALIFIERS ARGS CALL-CON FUNCTION)" nil nil) (autoload 'cl-find-method "cl-generic" "\ @@ -5138,6 +5074,9 @@ Increment PLACE by X (1 by default). PLACE may be a symbol, or any generalized variable allowed by `setf'. The return value is the incremented value of PLACE. +If X is specified, it should be an expression that should +evaluate to a number. + \(fn PLACE &optional X)" nil t) (defvar cl-old-struct-compat-mode nil "\ @@ -5152,23 +5091,25 @@ or call the function `cl-old-struct-compat-mode'.") (autoload 'cl-old-struct-compat-mode "cl-lib" "\ Enable backward compatibility with old-style structs. + This can be needed when using code byte-compiled using the old macro-expansion of `cl-defstruct' that used vectors objects instead of record objects. -This is a minor mode. If called interactively, toggle the -`Cl-Old-Struct-Compat mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +This is a global minor mode. If called interactively, toggle the +`Cl-Old-Struct-Compat 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. +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 \\='cl-old-struct-compat-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -5284,6 +5225,10 @@ Convert COLOR string to a list of normalized RGB components. COLOR should be a color name (e.g. \"white\") or an RGB triplet string (e.g. \"#ffff1122eecc\"). +COLOR can also be the symbol `unspecified' or one of the strings +\"unspecified-fg\" or \"unspecified-bg\", in which case the +return value is nil. + Normally the return value is a list of three floating-point numbers, (RED GREEN BLUE), each between 0.0 and 1.0 inclusive. @@ -5468,7 +5413,7 @@ Generate .elc files in addition to the .eln files. Force the produced .eln to be outputted in the eln system directory (the last entry in `native-comp-eln-load-path') unless `native-compile-target-directory' is non-nil. If the environment -variable 'NATIVE_DISABLED' is set, only byte compile." nil nil) +variable \"NATIVE_DISABLED\" is set, only byte compile." nil nil) (autoload 'native-compile-async "comp" "\ Compile FILES asynchronously. @@ -5675,9 +5620,15 @@ If HIGHLIGHT-REGEXP is non-nil, `next-error' will temporarily highlight the matching section of the visited source line; the default is to use the global value of `compilation-highlight-regexp'. +If CONTINUE is non-nil, the buffer won't be emptied before +compilation is started. This can be useful if you wish to +combine the output from several compilation commands in the same +buffer. The new output will be at the end of the buffer, and +point is not changed. + Returns the compilation buffer created. -\(fn COMMAND &optional MODE NAME-FUNCTION HIGHLIGHT-REGEXP)" nil nil) +\(fn COMMAND &optional MODE NAME-FUNCTION HIGHLIGHT-REGEXP CONTINUE)" nil nil) (autoload 'compilation-mode "compile" "\ Major mode for compilation log buffers. @@ -5696,48 +5647,49 @@ Runs `compilation-mode-hook' with `run-mode-hooks' (which see). (autoload 'compilation-shell-minor-mode "compile" "\ Toggle Compilation Shell minor mode. +When Compilation Shell minor mode is enabled, all the +error-parsing commands of the Compilation major mode are +available but bound to keys that don't collide with Shell mode. +See `compilation-mode'. + This is a minor mode. If called interactively, toggle the `Compilation-Shell minor mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable the -mode. +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. +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 `compilation-shell-minor-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -When Compilation Shell minor mode is enabled, all the -error-parsing commands of the Compilation major mode are -available but bound to keys that don't collide with Shell mode. -See `compilation-mode'. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) (autoload 'compilation-minor-mode "compile" "\ Toggle Compilation minor mode. +When Compilation minor mode is enabled, all the error-parsing +commands of Compilation major mode are available. See +`compilation-mode'. + This is a minor mode. If called interactively, toggle the -`Compilation minor mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Compilation minor 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. +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 `compilation-minor-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -When Compilation minor mode is enabled, all the error-parsing -commands of Compilation major mode are available. See -`compilation-mode'. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -5767,23 +5719,24 @@ or call the function `dynamic-completion-mode'.") (autoload 'dynamic-completion-mode "completion" "\ Toggle dynamic word-completion on or off. -This is a minor mode. If called interactively, toggle the -`Dynamic-Completion mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +This is a global minor mode. If called interactively, toggle the +`Dynamic-Completion 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. +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 \\='dynamic-completion-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +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 "completion" '("*c-def-regexp*" "*lisp-def-regexp*" "accept-completion" "add-" "cdabbrev-" "check-completion-length" "clear-all-completions" "cmpl-" "complet" "current-completion-source" "delete-completion" "enable-completion" "find-" "initialize-completions" "inside-locate-completion-entry" "interactive-completion-string-reader" "kill-" "list-all-completions" "load-completions-from-file" "make-c" "next-cdabbrev" "num-cmpl-sources" "reset-cdabbrev" "save" "set-c" "symbol-" "use-completion-")) +(register-definition-prefixes "completion" '("*c-def-regexp*" "*lisp-def-regexp*" "accept-completion" "add-" "cdabbrev-" "check-completion-length" "clear-all-completions" "cmpl-" "complet" "current-completion-source" "delete-completion" "enable-completion" "find-" "inside-locate-completion-entry" "interactive-completion-string-reader" "kill-" "list-all-completions" "load-completions-from-file" "make-c" "next-cdabbrev" "num-cmpl-sources" "reset-cdabbrev" "save" "set-c" "symbol-" "use-completion-")) ;;;*** @@ -6041,6 +5994,7 @@ If FIX is non-nil, run `copyright-fix-years' instead. (put 'cperl-continued-statement-offset 'safe-local-variable 'integerp) (put 'cperl-extra-newline-before-brace 'safe-local-variable 'booleanp) (put 'cperl-merge-trailing-else 'safe-local-variable 'booleanp) +(put 'cperl-file-style 'safe-local-variable 'stringp) (autoload 'cperl-mode "cperl-mode" "\ Major mode for editing Perl code. @@ -6192,9 +6146,11 @@ Settings for classic indent-styles: K&R BSD=C++ GNU PBP PerlStyle=Whitesmith `cperl-continued-statement-offset' 5 4 2 4 4 CPerl knows several indentation styles, and may bulk set the -corresponding variables. Use \\[cperl-set-style] to do this. Use -\\[cperl-set-style-back] to restore the memorized preexisting values -\(both available from menu). See examples in `cperl-style-examples'. +corresponding variables. Use \\[cperl-set-style] to do this or +set the `cperl-file-style' user option. Use +\\[cperl-set-style-back] to restore the memorized preexisting +values (both available from menu). See examples in +`cperl-style-examples'. Part of the indentation style is how different parts of if/elsif/else statements are broken into lines; in CPerl, this is reflected on how @@ -6336,20 +6292,6 @@ or call the function `cua-mode'.") (autoload 'cua-mode "cua-base" "\ Toggle Common User Access style editing (CUA mode). -This is a minor mode. If called interactively, toggle the `Cua 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 \\='cua-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - CUA mode is a global minor mode. When enabled, typed text replaces the active selection, and you can use C-z, C-x, C-c, and C-v to undo, cut, copy, and paste in addition to the normal Emacs @@ -6368,6 +6310,20 @@ You can customize `cua-enable-cua-keys' to completely disable the CUA bindings, or `cua-prefix-override-inhibit-delay' to change the prefix fallback behavior. +This is a global minor mode. If called interactively, toggle the +`Cua 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 \\='cua-mode)'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'cua-selection-mode "cua-base" "\ @@ -6391,21 +6347,23 @@ Enable CUA selection mode without the C-z/C-x/C-c/C-v bindings. (autoload 'cua-rectangle-mark-mode "cua-rect" "\ Toggle the region as rectangular. + Activates the region if needed. Only lasts until the region is deactivated. This is a minor mode. If called interactively, toggle the -`Cua-Rectangle-Mark mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Cua-Rectangle-Mark 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. +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 `cua-rectangle-mark-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -6426,23 +6384,25 @@ By convention, this is a list of symbols where each symbol stands for the Keep cursor outside of any `cursor-intangible' text property. This is a minor mode. If called interactively, toggle the -`Cursor-Intangible mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Cursor-Intangible 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. +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 `cursor-intangible-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) (autoload 'cursor-sensor-mode "cursor-sensor" "\ Handle the `cursor-sensor-functions' text property. + This property should hold a list of functions which react to the motion of the cursor. They're called with three arguments (WINDOW OLDPOS DIR) where WINDOW is the affected window, OLDPOS is the last known position of @@ -6450,18 +6410,18 @@ the cursor and DIR can be `entered' or `left' depending on whether the cursor is entering the area covered by the text-property property or leaving it. This is a minor mode. If called interactively, toggle the -`Cursor-Sensor mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +`Cursor-Sensor 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. +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 `cursor-sensor-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -6524,6 +6484,19 @@ If given a prefix (or a COMMENT argument), also prompt for a comment. \(fn VARIABLE VALUE &optional COMMENT)" t nil) +(autoload 'setopt "cus-edit" "\ +Set VARIABLE/VALUE pairs, and return the final VALUE. +This is like `setq', but is meant for user options instead of +plain variables. This means that `setopt' will execute any +`custom-set' form associated with VARIABLE. + +\(fn [VARIABLE VALUE]...)" nil t) + +(autoload 'setopt--set "cus-edit" "\ + + +\(fn VARIABLE VALUE)" nil nil) + (autoload 'customize-save-variable "cus-edit" "\ Set the default for VARIABLE to VALUE, and save it for future sessions. Return VALUE. @@ -6838,25 +6811,25 @@ Mode used for cvs status output. (autoload 'cwarn-mode "cwarn" "\ Minor mode that highlights suspicious C and C++ constructions. +Suspicious constructs are highlighted using `font-lock-warning-face'. + +Note, in addition to enabling this minor mode, the major mode must +be included in the variable `cwarn-configuration'. By default C and +C++ modes are included. + This is a minor mode. If called interactively, toggle the `Cwarn -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. +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. +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 `cwarn-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -Suspicious constructs are highlighted using `font-lock-warning-face'. - -Note, in addition to enabling this minor mode, the major mode must -be included in the variable `cwarn-configuration'. By default C and -C++ modes are included. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -7309,20 +7282,6 @@ or call the function `delete-selection-mode'.") (autoload 'delete-selection-mode "delsel" "\ Toggle Delete Selection mode. -This is a minor mode. If called interactively, toggle the -`Delete-Selection 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 \\='delete-selection-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - When Delete Selection mode is enabled, typed text replaces the selection if the selection is active. Otherwise, typed text is just inserted at point regardless of any selection. @@ -7330,6 +7289,21 @@ point regardless of any selection. See `delete-selection-helper' and `delete-selection-pre-hook' for information on adapting behavior of commands in Delete Selection mode. +This is a global minor mode. If called interactively, toggle the +`Delete-Selection 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 \\='delete-selection-mode)'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'delete-active-region "delsel" "\ @@ -7409,6 +7383,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 @@ -7497,20 +7473,6 @@ or call the function `desktop-save-mode'.") (autoload 'desktop-save-mode "desktop" "\ Toggle desktop saving (Desktop Save mode). -This is a minor mode. If called interactively, toggle the -`Desktop-Save 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 \\='desktop-save-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - When Desktop Save mode is enabled, the state of Emacs is saved from one session to another. In particular, Emacs will save the desktop when it exits (this may prompt you; see the option `desktop-save'). The next @@ -7526,6 +7488,20 @@ To see all the options you can set, browse the `desktop' customization group. For further details, see info node `(emacs)Saving Emacs Sessions'. +This is a global minor mode. If called interactively, toggle the +`Desktop-Save 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 \\='desktop-save-mode)'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (defvar desktop-locals-to-save '(desktop-locals-to-save truncate-lines case-fold-search case-replace fill-column overwrite-mode change-log-default-name line-number-mode column-number-mode size-indication-mode buffer-file-coding-system buffer-display-time indent-tabs-mode tab-width indicate-buffer-boundaries indicate-empty-lines show-trailing-whitespace) "\ @@ -7734,6 +7710,12 @@ If NODISPLAY is non-nil, don't redisplay the article buffer. \(fn &optional NODISPLAY)" '(gnus-article-mode gnus-summary-mode) nil) +(autoload 'gnus-article-outlook-rearrange-citation "deuglify" "\ +Repair broken citations. +If NODISPLAY is non-nil, don't redisplay the article buffer. + +\(fn &optional NODISPLAY)" '(gnus-article-mode gnus-summary-mode) nil) + (autoload 'gnus-outlook-deuglify-article "deuglify" "\ Full deuglify of broken Outlook (Express) articles. Treat \"smartquotes\", unwrap lines, repair attribution and @@ -7745,7 +7727,7 @@ article buffer. (autoload 'gnus-article-outlook-deuglify-article "deuglify" "\ Deuglify broken Outlook (Express) articles and redisplay." '(gnus-article-mode gnus-summary-mode) nil) -(register-definition-prefixes "deuglify" '("gnus-")) +(register-definition-prefixes "deuglify" '("gnus-outlook-")) ;;;*** @@ -7961,6 +7943,8 @@ diff command. OLD and NEW may each be a buffer or a buffer name. +Also see the `diff-entire-buffers' variable. + \(fn OLD NEW &optional SWITCHES NO-ASYNC)" t nil) (register-definition-prefixes "diff" '("diff-")) @@ -7990,21 +7974,21 @@ a diff with \\[diff-reverse-direction]. (autoload 'diff-minor-mode "diff-mode" "\ Toggle Diff minor mode. -This is a minor mode. If called interactively, toggle the `Diff minor -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. +\\{diff-minor-mode-map} + +This is a minor mode. If called interactively, toggle the `Diff +minor 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. +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 `diff-minor-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -\\{diff-minor-mode-map} +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -8050,7 +8034,7 @@ some of the `ls' switches are not supported; see the doc string of (custom-autoload 'dired-listing-switches "dired" t) -(defvar dired-directory nil "\ +(defvar-local dired-directory nil "\ The directory name or wildcard spec that this Dired directory lists. Local to each Dired buffer. May be a list, in which case the car is the directory name and the cdr is the list of files to mention. @@ -8059,8 +8043,11 @@ The directory name must be absolute, but need not be fully expanded.") (autoload 'dired "dired" "\ \"Edit\" directory DIRNAME--delete, rename, print, etc. some files in it. -Optional second argument SWITCHES specifies the `ls' options used. -\(Interactively, use a prefix argument to be able to specify SWITCHES.) +Optional second argument SWITCHES specifies the options to be used +when invoking `insert-directory-program', usually `ls', which produces +the listing of the directory files and their attributes. +Interactively, a prefix argument will cause the command to prompt +for SWITCHES. If DIRNAME is a string, Dired displays a list of files in DIRNAME (which may also have shell wildcards appended to select certain files). @@ -8188,20 +8175,6 @@ Like \\[dired-jump] (`dired-jump') but in other window. (autoload 'dirtrack-mode "dirtrack" "\ Toggle directory tracking in shell buffers (Dirtrack mode). -This is a minor mode. If called interactively, toggle the `Dirtrack -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 `dirtrack-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - This method requires that your shell prompt contain the current working directory at all times, and that you set the variable `dirtrack-list' to match the prompt. @@ -8210,6 +8183,20 @@ This is an alternative to `shell-dirtrack-mode', which works by tracking `cd' and similar commands which change the shell working directory. +This is a minor mode. If called interactively, toggle the +`Dirtrack 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 `dirtrack-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'dirtrack "dirtrack" "\ @@ -8366,22 +8353,8 @@ in `.emacs'. (autoload 'display-fill-column-indicator-mode "display-fill-column-indicator" "\ Toggle display of `fill-column' indicator. -This uses `display-fill-column-indicator' internally. -This is a minor mode. If called interactively, toggle the -`Display-Fill-Column-Indicator 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 `display-fill-column-indicator-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. +This uses `display-fill-column-indicator' internally. To change the position of the column displayed by default customize `display-fill-column-indicator-column'. You can change the @@ -8390,6 +8363,21 @@ The globalized version is `global-display-fill-column-indicator-mode', which see. See Info node `Displaying Boundaries' for details. +This is a minor mode. If called interactively, toggle the +`Display-Fill-Column-Indicator 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 `display-fill-column-indicator-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (put 'global-display-fill-column-indicator-mode 'globalized-minor-mode t) @@ -8450,25 +8438,27 @@ list.") (autoload 'display-line-numbers-mode "display-line-numbers" "\ Toggle display of line numbers in the buffer. + This uses `display-line-numbers' internally. +To change the type of line numbers displayed by default, +customize `display-line-numbers-type'. To change the type while +the mode is on, set `display-line-numbers' directly. + This is a minor mode. If called interactively, toggle the -`Display-Line-Numbers mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Display-Line-Numbers 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. +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 `display-line-numbers-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -To change the type of line numbers displayed by default, -customize `display-line-numbers-type'. To change the type while -the mode is on, set `display-line-numbers' directly. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -8501,7 +8491,57 @@ Display-Line-Numbers mode. \(fn &optional ARG)" t nil) -(register-definition-prefixes "display-line-numbers" '("display-line-numbers-")) +(defvar header-line-indent "" "\ +String to indent at the start if the header line. +This is used in `header-line-indent-mode', and buffers that have +this switched on should have a `header-line-format' that look like: + + (\"\" header-line-indent THE-REST...) + +Also see `header-line-indent-width'.") + +(defvar header-line-indent-width 0 "\ +The width of the current line numbers displayed. +This is updated when `header-line-indent-mode' is switched on. + +Also see `header-line-indent'.") + +(autoload 'header-line-indent-mode "display-line-numbers" "\ +Mode to indent the header line in `display-line-numbers-mode' buffers. + +This means that the header line will be kept indented so that it +has blank space that's as wide as the displayed line numbers in +the buffer. + +Buffers that have this switched on should have a +`header-line-format' that look like: + + (\"\" header-line-indent THE-REST...) + +The `header-line-indent-width' variable is also kept updated, and +has the width of `header-line-format'. This can be used, for +instance, in `:align-to' specs, like: + + (space :align-to (+ header-line-indent-width 10)) + +This is a minor mode. If called interactively, toggle the +`Header-Line-Indent 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 `header-line-indent-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 "display-line-numbers" '("display-line-numbers-" "header-line-indent--")) ;;;*** @@ -8562,7 +8602,7 @@ If REVERSE, look up an IP address. (autoload 'dns-mode "dns-mode" "\ Major mode for viewing and editing DNS master files. -This mode is inherited from text mode. It add syntax +This mode is derived from text mode. It adds syntax highlighting, and some commands for handling DNS master files. Its keymap inherits from `text-mode' and it has the same variables for customizing indentation. It has its own abbrev @@ -8585,8 +8625,8 @@ Locate SOA record and increment the serial field." t nil) (autoload 'doc-view-mode-p "doc-view" "\ Return non-nil if document type TYPE is available for `doc-view'. -Document types are symbols like `dvi', `ps', `pdf', or `odf' (any -OpenDocument format). +Document types are symbols like `dvi', `ps', `pdf', `epub', +`cbz', `fb2', `xps', `oxps', or`odf' (any OpenDocument format). \(fn TYPE)" nil nil) @@ -8608,21 +8648,21 @@ to the next best mode." nil nil) (autoload 'doc-view-minor-mode "doc-view" "\ Toggle displaying buffer via Doc View (Doc View minor mode). -This is a minor mode. If called interactively, toggle the `Doc-View -minor mode' mode. If the prefix argument is positive, enable the -mode, and if it is zero or negative, disable the mode. +See the command `doc-view-mode' for more information on this 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. +This is a minor mode. If called interactively, toggle the +`Doc-View minor 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 `doc-view-minor-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -See the command `doc-view-mode' for more information on this mode. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -8679,22 +8719,22 @@ Switch to *doctor* buffer and start giving psychotherapy." t nil) (autoload 'double-mode "double" "\ Toggle special insertion on double keypresses (Double mode). -This is a minor mode. If called interactively, toggle the `Double -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. +When Double mode is enabled, some keys will insert different +strings when pressed twice. See `double-map' for details. -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. +This is a minor mode. If called interactively, toggle the +`Double 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 `double-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -When Double mode is enabled, some keys will insert different -strings when pressed twice. See `double-map' for details. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -8801,6 +8841,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 +8880,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 @@ -8862,8 +8906,12 @@ Define a constant M whose value is the result of `easy-mmode-define-keymap'. The M, BS, and ARGS arguments are as per that function. DOC is the constant's documentation. +This macro is deprecated; use `defvar-keymap' instead. + \(fn M BS DOC &rest ARGS)" nil t) +(function-put 'easy-mmode-defmap 'doc-string-elt '3) + (function-put 'easy-mmode-defmap 'lisp-indent-function '1) (autoload 'easy-mmode-defsyntax "easy-mmode" "\ @@ -8872,6 +8920,8 @@ CSS contains a list of syntax specifications of the form (CHAR . SYNTAX). \(fn ST CSS DOC &rest ARGS)" nil t) +(function-put 'easy-mmode-defsyntax 'doc-string-elt '3) + (function-put 'easy-mmode-defsyntax 'lisp-indent-function '1) (register-definition-prefixes "easy-mmode" '("easy-mmode-")) @@ -9261,6 +9311,11 @@ If regular expression is nil, repeat last search. Query replace FROM with TO in all files of a class tree. With prefix arg, process files of marked classes only. +As each match is found, the user must type a character saying +what to do with it. Type SPC or `y' to replace the match, +DEL or `n' to skip and go to the next match. For more directions, +type \\[help-command] at that time. + \(fn FROM TO)" t nil) (autoload 'ebrowse-tags-search-member-use "ebrowse" "\ @@ -9379,22 +9434,22 @@ or call the function `global-ede-mode'.") (autoload 'global-ede-mode "ede" "\ Toggle global EDE (Emacs Development Environment) mode. -This is a minor mode. If called interactively, toggle the `Global Ede -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. +This global minor mode enables `ede-minor-mode' in all buffers in +an EDE controlled project. -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. +This is a global minor mode. If called interactively, toggle the +`Global Ede 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 \\='global-ede-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -This global minor mode enables `ede-minor-mode' in all buffers in -an EDE controlled project. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -9575,7 +9630,10 @@ This applies to `eval-defun', `eval-region', `eval-buffer', and You can use the command `edebug-all-defs' to toggle the value of this variable. You may wish to make it local to each buffer with \(make-local-variable \\='edebug-all-defs) in your -`emacs-lisp-mode-hook'.") +`emacs-lisp-mode-hook'. + +Note that this user option has no effect unless the edebug +package has been loaded.") (custom-autoload 'edebug-all-defs "edebug" t) @@ -10221,7 +10279,7 @@ It creates an autoload function for CNAME's constructor. ;;;### (autoloads nil "eldoc" "emacs-lisp/eldoc.el" (0 0 0 0)) ;;; Generated autoloads from emacs-lisp/eldoc.el -(push (purecopy '(eldoc 1 11 0)) package--builtin-versions) +(push (purecopy '(eldoc 1 12 0)) package--builtin-versions) ;;;*** @@ -10241,20 +10299,6 @@ or call the function `electric-pair-mode'.") (autoload 'electric-pair-mode "elec-pair" "\ Toggle automatic parens pairing (Electric Pair mode). -This is a minor mode. If called interactively, toggle the -`Electric-Pair 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 \\='electric-pair-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Electric Pair mode is a global minor mode. When enabled, typing an open parenthesis automatically inserts the corresponding closing parenthesis, and vice versa. (Likewise for brackets, etc.). @@ -10263,25 +10307,40 @@ inserted around the region instead. To toggle the mode in a single buffer, use `electric-pair-local-mode'. +This is a global minor mode. If called interactively, toggle the +`Electric-Pair 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 \\='electric-pair-mode)'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'electric-pair-local-mode "elec-pair" "\ Toggle `electric-pair-mode' only in this buffer. This is a minor mode. If called interactively, toggle the -`Electric-Pair-Local mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Electric-Pair-Local 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. +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 `(buffer-local-value \\='electric-pair-mode \(current-buffer))'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -10292,6 +10351,31 @@ disabled. ;;;### (autoloads nil "elide-head" "elide-head.el" (0 0 0 0)) ;;; Generated autoloads from elide-head.el +(autoload 'elide-head-mode "elide-head" "\ +Toggle eliding (hiding) header material in the current buffer. + +When Elide Header mode is enabled, headers are hidden according +to `elide-head-headers-to-hide'. + +This is suitable as an entry on `find-file-hook' or appropriate +mode hooks. + +This is a minor mode. If called interactively, toggle the +`Elide-Head 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 `elide-head-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + +\(fn &optional ARG)" t nil) + (autoload 'elide-head "elide-head" "\ Hide header material in buffer according to `elide-head-headers-to-hide'. @@ -10302,6 +10386,8 @@ This is suitable as an entry on `find-file-hook' or appropriate mode hooks. \(fn &optional ARG)" t nil) +(make-obsolete 'elide-head 'elide-head-mode '"29.1") + (register-definition-prefixes "elide-head" '("elide-head-")) ;;;*** @@ -10362,6 +10448,11 @@ For example, to instrument all ELP functions, do the following: \\[elp-instrument-package] RET elp- RET +Note that only functions that are currently loaded will be +instrumented. If you run this function, and then later load +further functions that start with PREFIX, they will not be +instrumented automatically. + \(fn PREFIX)" t nil) (autoload 'elp-results "elp" "\ @@ -10374,6 +10465,14 @@ displayed." t nil) ;;;*** +;;;### (autoloads nil "em-extpipe" "eshell/em-extpipe.el" (0 0 0 +;;;;;; 0)) +;;; Generated autoloads from eshell/em-extpipe.el + +(register-definition-prefixes "em-extpipe" '("em-extpipe--or-with-catch" "eshell-")) + +;;;*** + ;;;### (autoloads nil "emacs-lock" "emacs-lock.el" (0 0 0 0)) ;;; Generated autoloads from emacs-lock.el @@ -10404,6 +10503,24 @@ some major modes from being locked under some circumstances. ;;;*** +;;;### (autoloads nil "emacs-news-mode" "textmodes/emacs-news-mode.el" +;;;;;; (0 0 0 0)) +;;; Generated autoloads from textmodes/emacs-news-mode.el + +(autoload 'emacs-news-mode "emacs-news-mode" "\ +Major mode for editing the Emacs NEWS file. + +\(fn)" t nil) + +(autoload 'emacs-news-view-mode "emacs-news-mode" "\ +Major mode for viewing the Emacs NEWS file. + +\(fn)" t nil) + +(register-definition-prefixes "emacs-news-mode" '("emacs-news-")) + +;;;*** + ;;;### (autoloads nil "emacsbug" "mail/emacsbug.el" (0 0 0 0)) ;;; Generated autoloads from mail/emacsbug.el @@ -10487,28 +10604,56 @@ 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 argument), choose the emoji +by typing its Unicode Standard name (with completion), instead +of selecting from emoji display. + +\(fn &optional TEXT)" t nil) + +(autoload 'emoji-recent "emoji" "\ +Choose and insert one of the recently-used emoji glyphs." t nil) + +(autoload 'emoji-search "emoji" "\ +Choose and insert an emoji glyph by typing its Unicode name. +This command prompts for an emoji name, with completion, and +inserts it. It recognizes the Unicode Standard names of emoji, +and also consults the `emoji-alternate-names' alist." t nil) + +(autoload 'emoji-list "emoji" "\ +List emojis and insert the one that's selected. +Select the emoji by typing \\<emoji-list-mode-map>\\[emoji-list-select] on its picture. +The glyph will be inserted into the buffer that was current +when the command was invoked." t nil) + +(autoload 'emoji-describe "emoji" "\ +Display the name of the grapheme cluster composed from GLYPH. +GLYPH should be a string of one or more characters which together +produce an emoji. Interactively, GLYPH is the emoji at point (it +could also be any character, not just emoji). + +If called from Lisp, return the name as a string; return nil if +the name is not known. + +\(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 (autoload 'enriched-mode "enriched" "\ Minor mode for editing text/enriched files. + These are files with embedded formatting information in the MIME standard text/enriched format. -This is a minor mode. If called interactively, toggle the `Enriched -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 `enriched-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Turning the mode on or off runs `enriched-mode-hook'. More information about Enriched mode is available in the file @@ -10518,6 +10663,20 @@ Commands: \\{enriched-mode-map} +This is a minor mode. If called interactively, toggle the +`Enriched 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 `enriched-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'enriched-encode "enriched" "\ @@ -10781,19 +10940,19 @@ enough, since keyservers have strict timeout settings. (autoload 'epa-mail-mode "epa-mail" "\ A minor-mode for composing encrypted/clearsigned mails. -This is a minor mode. If called interactively, toggle the `epa-mail -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the +`epa-mail 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. +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 `epa-mail-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -10854,19 +11013,19 @@ or call the function `epa-global-mail-mode'.") (autoload 'epa-global-mail-mode "epa-mail" "\ Minor mode to hook EasyPG into Mail mode. -This is a minor mode. If called interactively, toggle the +This is a global minor mode. If called interactively, toggle the `Epa-Global-Mail 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. +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 \\='epa-global-mail-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -10929,7 +11088,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) @@ -10994,7 +11153,7 @@ Example usage: (erc-tls :server \"irc.libera.chat\" :port 6697 :client-certificate - '(\"/home/bandali/my-cert.key\" + \\='(\"/home/bandali/my-cert.key\" \"/home/bandali/my-cert.crt\")) \(fn &key (SERVER (erc-compute-server)) (PORT (erc-compute-port)) (NICK (erc-compute-nick)) PASSWORD (FULL-NAME (erc-compute-full-name)) CLIENT-CERTIFICATE)" t nil) @@ -11034,7 +11193,7 @@ Otherwise, connect to HOST:PORT as USER and /join CHANNEL. ;;;### (autoloads nil "erc-lang" "erc/erc-lang.el" (0 0 0 0)) ;;; Generated autoloads from erc/erc-lang.el -(register-definition-prefixes "erc-lang" '("erc-cmd-LANG" "iso-638-languages" "language")) +(register-definition-prefixes "erc-lang" '("erc-cmd-LANG" "iso-639-1-languages" "language")) ;;;*** @@ -11076,6 +11235,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 +11270,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 +11294,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 +11654,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) @@ -11524,7 +11699,13 @@ Do `query-replace-regexp' of FROM with TO on all files listed in tags table. Third arg DELIMITED (prefix arg) means replace only word-delimited matches. If you exit (\\[keyboard-quit], RET or q), you can resume the query replace with the command \\[fileloop-continue]. -For non-interactive use, superseded by `fileloop-initialize-replace'. + +As each match is found, the user must type a character saying +what to do with it. Type SPC or `y' to replace the match, +DEL or `n' to skip and go to the next match. For more directions, +type \\[help-command] at that time. + +For non-interactive use, this is superseded by `fileloop-initialize-replace'. \(fn FROM TO &optional DELIMITED FILES)" t nil) @@ -11754,6 +11935,15 @@ If ERROR is non-nil, report an error if there is none. \(fn NAME &optional ERROR)" t nil) +(autoload 'eudc-expand-try-all "eudc" "\ +Wrap `eudc-expand-inline' with a prefix argument. +If TRY-ALL-SERVERS -- the prefix argument when called +interactively -- is non-nil, collect results from all servers. +If TRY-ALL-SERVERS is nil, do not try subsequent servers after +one server returns any match. + +\(fn &optional TRY-ALL-SERVERS)" t nil) + (autoload 'eudc-expand-inline "eudc" "\ Query the directory server, and expand the query string before point. The query string consists of the buffer substring from the point back to @@ -11762,12 +11952,19 @@ The variable `eudc-inline-query-format' controls how to associate the individual inline query words with directory attribute names. After querying the server for the given string, the expansion specified by `eudc-inline-expansion-format' is inserted in the buffer at point. -If REPLACE is non-nil, then this expansion replaces the name in the buffer. -`eudc-expansion-overwrites-query' being non-nil inverts the meaning of REPLACE. +If SAVE-QUERY-AS-KILL is non-nil, then save the pre-expansion +text to the kill ring. `eudc-expansion-save-query-as-kill' being +non-nil inverts the meaning of SAVE-QUERY-AS-KILL. Multiple servers can be tried with the same query until one finds a match, -see `eudc-inline-expansion-servers'. +see `eudc-inline-expansion-servers'. If TRY-ALL-SERVERS is +non-nil, collect results from all servers. -\(fn &optional REPLACE)" t nil) +\(fn &optional SAVE-QUERY-AS-KILL TRY-ALL-SERVERS)" t nil) + +(autoload 'eudc-format-inline-expansion-result "eudc" "\ +Format a query result according to `eudc-inline-expansion-format'. + +\(fn RES QUERY-ATTRS)" nil nil) (autoload 'eudc-query-with-words "eudc" "\ Query the directory server, and return the matching responses. @@ -11775,11 +11972,12 @@ The variable `eudc-inline-query-format' controls how to associate the individual QUERY-WORDS with directory attribute names. After querying the server for the given string, the expansion specified by `eudc-inline-expansion-format' is applied to the -matches before returning them.inserted in the buffer at point. +matches before returning them. Multiple servers can be tried with the same query until one finds a match, -see `eudc-inline-expansion-servers'. +see `eudc-inline-expansion-servers'. When TRY-ALL-SERVERS is non-nil, +keep collecting results from subsequent servers after the first match. -\(fn QUERY-WORDS)" nil nil) +\(fn QUERY-WORDS &optional TRY-ALL-SERVERS)" nil nil) (autoload 'eudc-query-form "eudc" "\ Display a form to query the directory server. @@ -11837,6 +12035,37 @@ Display a button for the JPEG DATA. ;;;*** +;;;### (autoloads nil "eudc-capf" "net/eudc-capf.el" (0 0 0 0)) +;;; Generated autoloads from net/eudc-capf.el + +(autoload 'eudc-capf-complete "eudc-capf" "\ +Email address completion function for `completion-at-point-functions'. + +This function checks whether the current major mode is one of the +modes listed in `eudc-capf-modes', and whether point is on a line +with a message header listing email recipients, that is, a line +whose beginning matches `message-email-recipient-header-regexp', +and, if the check succeeds, searches for records matching the +words before point. + +The return value is either nil when no match is found, or a +completion table as required for functions listed in +`completion-at-point-functions'." nil nil) + +(autoload 'eudc-capf-message-expand-name "eudc-capf" "\ +Email address completion function for `message-completion-alist'. + +When this function is added to `message-completion-alist', +replacing any existing entry for `message-expand-name' there, +with an appropriate regular expression such as for example +`message-email-recipient-header-regexp', then EUDC will be +queried for email addresses, and the results delivered to +`completion-at-point'." nil nil) + +(register-definition-prefixes "eudc-capf" '("eudc-capf-modes")) + +;;;*** + ;;;### (autoloads nil "eudc-export" "net/eudc-export.el" (0 0 0 0)) ;;; Generated autoloads from net/eudc-export.el @@ -11956,14 +12185,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" "\ @@ -12288,26 +12517,32 @@ a top-level keymap, `text-scale-increase' or `text-scale-decrease' may be more appropriate. \(fn INC)" t nil) + (define-key global-map [pinch] 'text-scale-pinch) + +(autoload 'text-scale-pinch "face-remap" "\ +Adjust the height of the default face by the scale in the pinch event EVENT. + +\(fn EVENT)" t nil) (autoload 'buffer-face-mode "face-remap" "\ Minor mode for a buffer-specific default face. +When enabled, the face specified by the variable +`buffer-face-mode-face' is used to display the buffer text. + This is a minor mode. If called interactively, toggle the -`Buffer-Face mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +`Buffer-Face 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. +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 `buffer-face-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -When enabled, the face specified by the variable -`buffer-face-mode-face' is used to display the buffer text. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -12757,6 +12992,12 @@ Execute BODY, and unwind connection-local variables. \(fn &rest BODY)" nil t) +(autoload 'with-connection-local-variables-1 "files-x" "\ +Apply connection-local variables according to `default-directory'. +Call BODY-FUN with no args, and then unwind connection-local variables. + +\(fn BODY-FUN)" nil nil) + (autoload 'path-separator "files-x" "\ The connection-local value of `path-separator'." nil nil) @@ -12952,6 +13193,9 @@ Interactively, prompt for LIBRARY using the one at or near point. This function searches `find-library-source-path' if non-nil, and `load-path' otherwise. +See the `find-library-include-other-files' user option for +customizing the candidate completions. + \(fn LIBRARY)" t nil) (autoload 'read-library-name "find-func" "\ @@ -13112,7 +13356,7 @@ Find directly the variable at point in the other window." t nil) (autoload 'find-function-setup-keys "find-func" "\ Define some key bindings for the `find-function' family of functions." nil nil) -(register-definition-prefixes "find-func" '("find-")) +(register-definition-prefixes "find-func" '("find-" "read-library-name--find-files")) ;;;*** @@ -13256,20 +13500,6 @@ region is invalid. This function saves match data. (autoload 'flymake-mode "flymake" "\ Toggle Flymake mode on or off. -This is a minor mode. If called interactively, toggle the `Flymake -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 `flymake-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Flymake is an Emacs minor mode for on-the-fly syntax checking. Flymake collects diagnostic information from multiple sources, called backends, and visually annotates the buffer with the @@ -13284,6 +13514,13 @@ The commands `flymake-goto-next-error' and `flymake-goto-prev-error' can be used to navigate among Flymake diagnostics annotated in the buffer. +By default, `flymake-mode' doesn't override the \\[next-error] command, but +if you're using Flymake a lot (and don't use the regular compilation +mechanisms that often), it can be useful to put something like +the following in your init file: + + (setq next-error-function \\='flymake-goto-next-error) + The visual appearance of each type of diagnostic can be changed by setting properties `flymake-overlay-control', `flymake-bitmap' and `flymake-severity' on the symbols of diagnostic types (like @@ -13300,6 +13537,20 @@ suitable for the current buffer. The commands `flymake-reporting-backends' summarize the situation, as does the special *Flymake log* buffer. +This is a minor mode. If called interactively, toggle the +`Flymake 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 `flymake-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'flymake-mode-on "flymake" "\ @@ -13347,20 +13598,6 @@ Turn on `flyspell-mode' for comments and strings." t nil) (autoload 'flyspell-mode "flyspell" "\ Toggle on-the-fly spell checking (Flyspell mode). -This is a minor mode. If called interactively, toggle the `Flyspell -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 `flyspell-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Flyspell mode is a buffer-local minor mode. When enabled, it spawns a single Ispell process and checks each word. The default flyspell behavior is to highlight incorrect words. @@ -13390,6 +13627,20 @@ in your init file. \\[flyspell-region] checks all words inside a region. \\[flyspell-buffer] checks the whole buffer. +This is a minor mode. If called interactively, toggle the +`Flyspell 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 `flyspell-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'turn-on-flyspell "flyspell" "\ @@ -13436,20 +13687,6 @@ Turn off Follow mode. Please see the function `follow-mode'." nil nil) (autoload 'follow-mode "follow" "\ Toggle Follow mode. -This is a minor mode. If called interactively, toggle the `Follow -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 `follow-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Follow mode is a minor mode that combines windows into one tall virtual window. This is accomplished by two main techniques: @@ -13479,6 +13716,20 @@ This command runs the normal hook `follow-mode-hook'. Keys specific to Follow mode: \\{follow-mode-map} +This is a minor mode. If called interactively, toggle the +`Follow 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 `follow-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'follow-scroll-up-window "follow" "\ @@ -13569,24 +13820,24 @@ selected if the original window is the first one in the frame. (autoload 'footnote-mode "footnote" "\ Toggle Footnote mode. -This is a minor mode. If called interactively, toggle the `Footnote -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. +Footnote mode is a buffer-local minor mode. If enabled, it +provides footnote support for `message-mode'. To get started, +play around with the following keys: +\\{footnote-minor-mode-map} + +This is a minor mode. If called interactively, toggle the +`Footnote 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. +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 `footnote-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -Footnote mode is a buffer-local minor mode. If enabled, it -provides footnote support for `message-mode'. To get started, -play around with the following keys: -\\{footnote-minor-mode-map} +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -13828,11 +14079,11 @@ and choose the directory as the fortune-file. ;;;### (autoloads nil "frameset" "frameset.el" (0 0 0 0)) ;;; Generated autoloads from frameset.el -(defvar frameset-session-filter-alist '((name . :never) (left . frameset-filter-iconified) (minibuffer . frameset-filter-minibuffer) (top . frameset-filter-iconified)) "\ +(defvar frameset-session-filter-alist (append '((left . frameset-filter-iconified) (minibuffer . frameset-filter-minibuffer) (top . frameset-filter-iconified)) (mapcar (lambda (p) (cons p :never)) frame-internal-parameters)) "\ Minimum set of parameters to filter for live (on-session) framesets. DO NOT MODIFY. See `frameset-filter-alist' for a full description.") -(defvar frameset-persistent-filter-alist (append '((background-color . frameset-filter-sanitize-color) (buffer-list . :never) (buffer-predicate . :never) (buried-buffer-list . :never) (client . :never) (delete-before . :never) (font . frameset-filter-font-param) (font-backend . :never) (foreground-color . frameset-filter-sanitize-color) (frameset--text-pixel-height . :save) (frameset--text-pixel-width . :save) (fullscreen . frameset-filter-shelve-param) (GUI:font . frameset-filter-unshelve-param) (GUI:fullscreen . frameset-filter-unshelve-param) (GUI:height . frameset-filter-unshelve-param) (GUI:width . frameset-filter-unshelve-param) (height . frameset-filter-shelve-param) (outer-window-id . :never) (parent-frame . :never) (parent-id . :never) (mouse-wheel-frame . :never) (tty . frameset-filter-tty-to-GUI) (tty-type . frameset-filter-tty-to-GUI) (width . frameset-filter-shelve-param) (window-id . :never) (window-system . :never)) frameset-session-filter-alist) "\ +(defvar frameset-persistent-filter-alist (append '((background-color . frameset-filter-sanitize-color) (bottom . frameset-filter-shelve-param) (buffer-list . :never) (buffer-predicate . :never) (buried-buffer-list . :never) (client . :never) (delete-before . :never) (font . frameset-filter-font-param) (font-backend . :never) (foreground-color . frameset-filter-sanitize-color) (frameset--text-pixel-height . :save) (frameset--text-pixel-width . :save) (fullscreen . frameset-filter-shelve-param) (GUI:bottom . frameset-filter-unshelve-param) (GUI:font . frameset-filter-unshelve-param) (GUI:fullscreen . frameset-filter-unshelve-param) (GUI:height . frameset-filter-unshelve-param) (GUI:left . frameset-filter-unshelve-param) (GUI:right . frameset-filter-unshelve-param) (GUI:top . frameset-filter-unshelve-param) (GUI:width . frameset-filter-unshelve-param) (height . frameset-filter-shelve-param) (left . frameset-filter-shelve-param) (parent-frame . :never) (mouse-wheel-frame . :never) (right . frameset-filter-shelve-param) (top . frameset-filter-shelve-param) (tty . frameset-filter-tty-to-GUI) (tty-type . frameset-filter-tty-to-GUI) (width . frameset-filter-shelve-param) (window-system . :never)) frameset-session-filter-alist) "\ Parameters to filter for persistent framesets. DO NOT MODIFY. See `frameset-filter-alist' for a full description.") @@ -14005,7 +14256,7 @@ Interactively, reads the register using `register-read-with-preview'. ;;;### (autoloads nil "fringe" "fringe.el" (0 0 0 0)) ;;; Generated autoloads from fringe.el -(unless (fboundp 'define-fringe-bitmap) (defun define-fringe-bitmap (_bitmap _bits &optional _height _width _align) "Define fringe bitmap BITMAP from BITS of size HEIGHT x WIDTH.\nBITMAP is a symbol identifying the new fringe bitmap.\nBITS is either a string or a vector of integers.\nHEIGHT is height of bitmap. If HEIGHT is nil, use length of BITS.\nWIDTH must be an integer between 1 and 16, or nil which defaults to 8.\nOptional fifth arg ALIGN may be one of ‘top’, ‘center’, or ‘bottom’,\nindicating the positioning of the bitmap relative to the rows where it\nis used; the default is to center the bitmap. Fifth arg may also be a\nlist (ALIGN PERIODIC) where PERIODIC non-nil specifies that the bitmap\nshould be repeated.\nIf BITMAP already exists, the existing definition is replaced.")) +(unless (fboundp 'define-fringe-bitmap) (defun define-fringe-bitmap (_bitmap _bits &optional _height _width _align) "Define fringe bitmap BITMAP from BITS of size HEIGHT x WIDTH.\nBITMAP is a symbol identifying the new fringe bitmap.\nBITS is either a string or a vector of integers.\nHEIGHT is height of bitmap. If HEIGHT is nil, use length of BITS.\nWIDTH must be an integer between 1 and 16, or nil which defaults to 8.\nOptional fifth arg ALIGN may be one of `top', `center', or `bottom',\nindicating the positioning of the bitmap relative to the rows where it\nis used; the default is to center the bitmap. Fifth arg may also be a\nlist (ALIGN PERIODIC) where PERIODIC non-nil specifies that the bitmap\nshould be repeated.\nIf BITMAP already exists, the existing definition is replaced.")) (register-definition-prefixes "fringe" '("fringe-" "set-fringe-")) @@ -14037,25 +14288,27 @@ for a description of this minor mode.") (autoload 'gdb-enable-debug "gdb-mi" "\ Toggle logging of transaction between Emacs and Gdb. + The log is stored in `gdb-debug-log' as an alist with elements whose cons is send, send-item or recv and whose cdr is the string being transferred. This list may grow up to a size of `gdb-debug-log-max' after which the oldest element (at the end of the list) is deleted every time a new one is added (at the front). -This is a minor mode. If called interactively, toggle the -`Gdb-Enable-Debug mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +This is a global minor mode. If called interactively, toggle the +`Gdb-Enable-Debug 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. +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 \\='gdb-enable-debug)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -14230,22 +14483,22 @@ regular expression that can be used as an element of (autoload 'glasses-mode "glasses" "\ Minor mode for making identifiers likeThis readable. -This is a minor mode. If called interactively, toggle the `Glasses -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. +When this mode is active, it tries to add virtual +separators (like underscores) at places they belong to. -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. +This is a minor mode. If called interactively, toggle the +`Glasses 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 `glasses-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -When this mode is active, it tries to add virtual -separators (like underscores) at places they belong to. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -14253,6 +14506,37 @@ separators (like underscores) at places they belong to. ;;;*** +;;;### (autoloads nil "glyphless-mode" "textmodes/glyphless-mode.el" +;;;;;; (0 0 0 0)) +;;; Generated autoloads from textmodes/glyphless-mode.el + +(autoload 'glyphless-display-mode "glyphless-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. + +This is a minor mode. If called interactively, toggle the +`Glyphless-Display 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 `glyphless-display-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 "glyphless-mode" '("glyphless-mode-")) + +;;;*** + ;;;### (autoloads nil "gmm-utils" "gnus/gmm-utils.el" (0 0 0 0)) ;;; Generated autoloads from gnus/gmm-utils.el @@ -14459,7 +14743,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-")) ;;;*** @@ -14767,7 +15051,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-")) ;;;*** @@ -14849,21 +15133,22 @@ If FORCE is non-nil, replace the old ones. (autoload 'gnus-mailing-list-mode "gnus-ml" "\ Minor mode for providing mailing-list commands. +\\{gnus-mailing-list-mode-map} + This is a minor mode. If called interactively, toggle the -`Gnus-Mailing-List mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Gnus-Mailing-List 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. +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 `gnus-mailing-list-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -\\{gnus-mailing-list-mode-map} +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -14994,7 +15279,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-")) ;;;*** @@ -15070,12 +15355,6 @@ LIST1 and LIST2 have to be sorted over <. \(fn LIST1 LIST2)" nil nil) -(autoload 'gnus-sorted-range-intersection "gnus-range" "\ -Return intersection of RANGE1 and RANGE2. -RANGE1 and RANGE2 have to be sorted over <. - -\(fn RANGE1 RANGE2)" nil nil) - (defalias 'gnus-set-sorted-intersection 'gnus-sorted-nintersection) (autoload 'gnus-sorted-nintersection "gnus-range" "\ @@ -15124,6 +15403,13 @@ Initialize the Gnus registry." t nil) ;;;*** +;;;### (autoloads nil "gnus-rmail" "gnus/gnus-rmail.el" (0 0 0 0)) +;;; Generated autoloads from gnus/gnus-rmail.el + +(register-definition-prefixes "gnus-rmail" '("gnus-")) + +;;;*** + ;;;### (autoloads nil "gnus-salt" "gnus/gnus-salt.el" (0 0 0 0)) ;;; Generated autoloads from gnus/gnus-salt.el @@ -15208,7 +15494,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-")) ;;;*** @@ -15320,18 +15606,18 @@ Also fontifies the buffer appropriately (see `goto-address-fontify-p' and Minor mode to buttonize URLs and e-mail addresses in the current buffer. This is a minor mode. If called interactively, toggle the -`Goto-Address mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +`Goto-Address 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. +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 `goto-address-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -15367,18 +15653,19 @@ See `goto-address-mode' for more information on Goto-Address mode. Like `goto-address-mode', but only for comments and strings. This is a minor mode. If called interactively, toggle the -`Goto-Address-Prog mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Goto-Address-Prog 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. +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 `goto-address-prog-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -15490,8 +15777,8 @@ Set up `compilation-exit-message-function' and run `grep-setup-hook'." nil nil) Compute the defaults for the `grep' command. The value depends on `grep-command', `grep-template', `grep-use-null-device', `grep-find-command', `grep-find-template', -`grep-use-null-filename-separator', `grep-find-use-xargs' and -`grep-highlight-matches'." nil nil) +`grep-use-null-filename-separator', `grep-find-use-xargs', +`grep-highlight-matches', and `grep-quoting-style'." nil nil) (autoload 'grep-mode "grep" "\ Sets `grep-last-buffer' and `compilation-window-height'. @@ -15533,7 +15820,7 @@ easily repeat a find command. \(fn COMMAND-ARGS)" t nil) -(defalias 'find-grep 'grep-find) +(defalias 'find-grep #'grep-find) (autoload 'lgrep "grep" "\ Run grep, searching for REGEXP in FILES in directory DIR. @@ -15595,7 +15882,7 @@ command before it's run. \(fn REGEXP &optional FILES DIR CONFIRM TEMPLATE)" t nil) -(defalias 'rzgrep 'zrgrep) +(defalias 'rzgrep #'zrgrep) (register-definition-prefixes "grep" '("grep-" "kill-grep" "rgrep-")) @@ -15714,19 +16001,19 @@ or call the function `gud-tooltip-mode'.") (autoload 'gud-tooltip-mode "gud" "\ Toggle the display of GUD tooltips. -This is a minor mode. If called interactively, toggle the -`Gud-Tooltip mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +This is a global minor mode. If called interactively, toggle the +`Gud-Tooltip 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. +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 \\='gud-tooltip-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -15959,19 +16246,22 @@ If this produces no string either, return nil." nil nil) (autoload 'display-local-help "help-at-pt" "\ Display local help in the echo area. -This displays a short help message, namely the string produced by -the `kbd-help' property at point. If `kbd-help' does not produce -a string, but the `help-echo' property does, then that string is -printed instead. +This command, by default, displays a short help message, namely +the string produced by the `kbd-help' property at point. If +`kbd-help' does not produce a string, but the `help-echo' +property does, then that string is printed instead. The string is passed through `substitute-command-keys' before it is displayed. -A numeric argument ARG prevents display of a message in case -there is no help. While ARG can be used interactively, it is -mainly meant for use from Lisp. +If INHIBIT-WARNING is non-nil, this prevents display of a message +in case there is no help. -\(fn &optional ARG)" t nil) +If DESCRIBE-BUTTON in non-nil (interactively, the prefix arg), and +there's a button/widget at point, pop a buffer describing that +button/widget instead. + +\(fn &optional INHIBIT-WARNING DESCRIBE-BUTTON)" t nil) (autoload 'help-at-pt-cancel-timer "help-at-pt" "\ Cancel any timer set by `help-at-pt-set-timer'. @@ -16104,10 +16394,15 @@ If TYPE is not a symbol, search for a function definition. The return value is the absolute name of a readable file where OBJECT is defined. If several such files exist, preference is given to a file found via `load-path'. The return value can also be `C-source', which -means that OBJECT is a function or variable defined in C. If no -suitable file is found, return nil. +means that OBJECT is a function or variable defined in C, but +it's currently unknown where. If no suitable file is found, +return nil. -\(fn OBJECT TYPE)" nil nil) +If ALSO-C-SOURCE is non-nil, instead of returning `C-source', +this function will attempt to locate the definition of OBJECT in +the C sources, too. + +\(fn OBJECT TYPE &optional ALSO-C-SOURCE)" nil nil) (autoload 'describe-function-1 "help-fns" "\ @@ -16235,9 +16530,15 @@ 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'. +Also see the `help-enable-variable-value-editing' variable. + Commands: \\{help-mode-map} @@ -16246,9 +16547,13 @@ Commands: (autoload 'help-mode-setup "help-mode" "\ Enter Help mode in the current buffer." nil nil) +(make-obsolete 'help-mode-setup 'nil '"29.1") + (autoload 'help-mode-finish "help-mode" "\ Finalize Help mode setup in current buffer." nil nil) +(make-obsolete 'help-mode-finish 'nil '"29.1") + (autoload 'help-setup-xref "help-mode" "\ Invoked from commands using the \"*Help*\" buffer to install some xref info. @@ -16458,20 +16763,6 @@ This discards the buffer's undo information." t nil) (autoload 'hi-lock-mode "hi-lock" "\ Toggle selective highlighting of patterns (Hi Lock mode). -This is a minor mode. If called interactively, toggle the `Hi-Lock -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 `hi-lock-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Hi Lock mode is automatically enabled when you invoke any of the highlighting commands listed below, such as \\[highlight-regexp]. To enable Hi Lock mode in all buffers, use `global-hi-lock-mode' @@ -16532,6 +16823,20 @@ position (number of characters into buffer) Hi-lock: end is found. A mode is excluded if it's in the list `hi-lock-exclude-modes'. +This is a minor mode. If called interactively, toggle the +`Hi-Lock 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 `hi-lock-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (put 'global-hi-lock-mode 'globalized-minor-mode t) @@ -16665,7 +16970,12 @@ be found in variable `hi-lock-interactive-patterns'." t nil) (autoload 'hi-lock-find-patterns "hi-lock" "\ Add patterns from the current buffer to the list of hi-lock patterns." t nil) -(register-definition-prefixes "hi-lock" '("hi-lock-" "turn-on-hi-lock-if-enabled")) +(autoload 'hi-lock-context-menu "hi-lock" "\ +Populate MENU with a menu item to highlight symbol at CLICK. + +\(fn MENU CLICK)" nil nil) + +(register-definition-prefixes "hi-lock" '("hi-lock-" "highlight-symbol-at-mouse" "turn-on-hi-lock-if-enabled")) ;;;*** @@ -16675,20 +16985,6 @@ Add patterns from the current buffer to the list of hi-lock patterns." t nil) (autoload 'hide-ifdef-mode "hideif" "\ Toggle features to hide/show #ifdef blocks (Hide-Ifdef mode). -This is a minor mode. If called interactively, toggle the `Hide-Ifdef -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 `hide-ifdef-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Hide-Ifdef mode is a buffer-local minor mode for use with C and C-like major modes. When enabled, code within #ifdef constructs that the C preprocessor would eliminate may be hidden from view. @@ -16723,6 +17019,20 @@ Several variables affect how the hiding is done: \\{hide-ifdef-mode-map} +This is a minor mode. If called interactively, toggle the +`Hide-Ifdef 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 `hide-ifdef-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 "hideif" '("backward-ifdef" "down-ifdef" "forward-ifdef" "hide-ifdef" "hif-" "intern-safe" "next-ifdef" "previous-ifdef" "show-ifdef" "up-ifdef")) @@ -16763,20 +17073,6 @@ whitespace. Case does not matter.") (autoload 'hs-minor-mode "hideshow" "\ Minor mode to selectively hide/show code and comment blocks. -This is a minor mode. If called interactively, toggle the `hs minor -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 `hs-minor-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - When hideshow minor mode is on, the menu bar is augmented with hideshow commands and the hideshow commands are enabled. The value (hs . t) is added to `buffer-invisibility-spec'. @@ -16793,6 +17089,20 @@ Lastly, the normal hook `hs-minor-mode-hook' is run using `run-hooks'. Key bindings: \\{hs-minor-mode-map} +This is a minor mode. If called interactively, toggle the `hs +minor 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 `hs-minor-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'turn-off-hideshow "hideshow" "\ @@ -16816,20 +17126,6 @@ Unconditionally turn off `hs-minor-mode'." nil nil) (autoload 'highlight-changes-mode "hilit-chg" "\ Toggle highlighting changes in this buffer (Highlight Changes mode). -This is a minor mode. If called interactively, toggle the -`Highlight-Changes 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 `highlight-changes-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - When Highlight Changes is enabled, changes are marked with a text property. Normally they are displayed in a distinctive face, but command \\[highlight-changes-visible-mode] can be used to toggle @@ -16845,25 +17141,25 @@ through various faces. buffer with the contents of a file \\[highlight-compare-buffers] highlights differences between two buffers. -\(fn &optional ARG)" t nil) - -(autoload 'highlight-changes-visible-mode "hilit-chg" "\ -Toggle visibility of highlighting due to Highlight Changes mode. - This is a minor mode. If called interactively, toggle the -`Highlight-Changes-Visible mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable the -mode. +`Highlight-Changes 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. +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 `highlight-changes-visible-mode'. +evaluate `highlight-changes-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. -The mode's hook is called both when the mode is enabled and when it is -disabled. +\(fn &optional ARG)" t nil) + +(autoload 'highlight-changes-visible-mode "hilit-chg" "\ +Toggle visibility of highlighting due to Highlight Changes mode. Highlight Changes Visible mode only has an effect when Highlight Changes mode is on. When enabled, the changed text is displayed @@ -16874,6 +17170,21 @@ The default value can be customized with variable This command does not itself set Highlight Changes mode. +This is a minor mode. If called interactively, toggle the +`Highlight-Changes-Visible 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 `highlight-changes-visible-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'highlight-changes-remove-highlight "hilit-chg" "\ @@ -17007,20 +17318,6 @@ argument VERBOSE non-nil makes the function verbose. (autoload 'hl-line-mode "hl-line" "\ Toggle highlighting of the current line (Hl-Line mode). -This is a minor mode. If called interactively, toggle the `Hl-Line -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 `hl-line-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Hl-Line mode is a buffer-local minor mode. If `hl-line-sticky-flag' is non-nil, Hl-Line mode highlights the line about the buffer's point in all windows. Caveat: the @@ -17031,6 +17328,20 @@ non-selected window. Hl-Line mode uses the function When `hl-line-sticky-flag' is nil, Hl-Line mode highlights the line about point in the selected window only. +This is a minor mode. If called interactively, toggle the +`Hl-Line 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 `hl-line-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (defvar global-hl-line-mode nil "\ @@ -17046,20 +17357,6 @@ or call the function `global-hl-line-mode'.") (autoload 'global-hl-line-mode "hl-line" "\ Toggle line highlighting in all buffers (Global Hl-Line mode). -This is a minor mode. If called interactively, toggle the `Global -Hl-Line 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 \\='global-hl-line-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - If `global-hl-line-sticky-flag' is non-nil, Global Hl-Line mode highlights the line about the current buffer's point in all live windows. @@ -17067,6 +17364,20 @@ windows. Global-Hl-Line mode uses the function `global-hl-line-highlight' on `post-command-hook'. +This is a global minor mode. If called interactively, toggle the +`Global Hl-Line 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 \\='global-hl-line-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 "hl-line" '("global-hl-line-" "hl-line-")) @@ -17191,6 +17502,11 @@ of a holiday list. The optional LABEL is used to label the buffer created. +The list of holiday lists is computed by the +`holiday-available-holiday-lists' and you can alter the results +by redefining that function, or use `add-function' to add +values. + \(fn Y1 &optional Y2 L LABEL)" t nil) (defalias 'holiday-list 'list-holidays) @@ -17467,22 +17783,22 @@ or call the function `fido-mode'.") (autoload 'fido-mode "icomplete" "\ An enhanced `icomplete-mode' that emulates `ido-mode'. -This is a minor mode. If called interactively, toggle the `Fido mode' -mode. If the prefix argument is positive, enable the mode, and if it -is zero or negative, disable the mode. +This global minor mode makes minibuffer completion behave +more like `ido-mode' than regular `icomplete-mode'. + +This is a global minor mode. If called interactively, toggle the +`Fido 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. +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 \\='fido-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -This global minor mode makes minibuffer completion behave -more like `ido-mode' than regular `icomplete-mode'. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -17499,20 +17815,6 @@ or call the function `icomplete-mode'.") (autoload 'icomplete-mode "icomplete" "\ Toggle incremental minibuffer completion (Icomplete mode). -This is a minor mode. If called interactively, toggle the `Icomplete -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 \\='icomplete-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - When this global minor mode is enabled, typing in the minibuffer continuously displays a list of possible completions that match the string you have typed. See `icomplete-completions' for a @@ -17526,6 +17828,20 @@ completions: \\{icomplete-minibuffer-map} +This is a global minor mode. If called interactively, toggle the +`Icomplete 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 \\='icomplete-mode)'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (defvar icomplete-vertical-mode nil "\ @@ -17541,26 +17857,27 @@ or call the function `icomplete-vertical-mode'.") (autoload 'icomplete-vertical-mode "icomplete" "\ Toggle vertical candidate display in `icomplete-mode' or `fido-mode'. -This is a minor mode. If called interactively, toggle the -`Icomplete-Vertical 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 \\='icomplete-vertical-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - If none of these modes are on, turn on `icomplete-mode'. As many completion candidates as possible are displayed, depending on the value of `max-mini-window-height', and the way the mini-window is resized depends on `resize-mini-windows'. +This is a global minor mode. If called interactively, toggle the +`Icomplete-Vertical 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 \\='icomplete-vertical-mode)'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (defvar fido-vertical-mode nil "\ @@ -17575,22 +17892,23 @@ or call the function `fido-vertical-mode'.") (autoload 'fido-vertical-mode "icomplete" "\ Toggle vertical candidate display in `fido-mode'. + When turning on, if non-vertical `fido-mode' is off, turn it on. If it's on, just add the vertical display. -This is a minor mode. If called interactively, toggle the -`Fido-Vertical mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +This is a global minor mode. If called interactively, toggle the +`Fido-Vertical 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. +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 \\='fido-vertical-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) (when (locate-library "obsolete/iswitchb") @@ -18108,6 +18426,14 @@ See `inferior-emacs-lisp-mode' for details. ;;;*** +;;;### (autoloads nil "ietf-drums-date" "mail/ietf-drums-date.el" +;;;;;; (0 0 0 0)) +;;; Generated autoloads from mail/ietf-drums-date.el + +(register-definition-prefixes "ietf-drums-date" '("date-parse-error" "ietf-drums-")) + +;;;*** + ;;;### (autoloads nil "iimage" "iimage.el" (0 0 0 0)) ;;; Generated autoloads from iimage.el @@ -18116,21 +18442,19 @@ See `inferior-emacs-lisp-mode' for details. (autoload 'iimage-mode "iimage" "\ Toggle Iimage mode on or off. -This is a minor mode. If called interactively, toggle the `Iimage -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the +`Iimage 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. +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 `iimage-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -\\{iimage-mode-map} +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -18167,6 +18491,16 @@ be determined. \(fn FILE)" nil nil) +(make-obsolete 'image-type-from-file-name 'image-supported-file-p '"29.1") + +(autoload 'image-supported-file-p "image" "\ +Say whether Emacs has native support for displaying TYPE. +The value is a symbol specifying the image type, or nil if type +cannot be determined (or if Emacs doesn't have built-in support +for the image type). + +\(fn FILE)" nil nil) + (autoload 'image-type "image" "\ Determine and return image type. SOURCE is an image file name or image data. @@ -18259,7 +18593,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. @@ -18328,6 +18666,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. @@ -18340,6 +18680,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")) ;;;*** @@ -18409,17 +18752,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. @@ -18436,27 +18781,27 @@ 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, -enable the mode, and if it is zero or negative, disable the mode. +`Image-Dired minor 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. +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 `image-dired-minor-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is 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) @@ -18477,18 +18822,29 @@ With prefix argument ARG, display image in its original size. Add comment to current or marked files in Dired." t nil) (autoload 'image-dired-mark-tagged-files "image-dired" "\ -Use regexp to mark files with matching tag. +Use REGEXP to mark files with matching tag. A `tag' is a keyword, a piece of meta data, associated with an image file and stored in image-dired's database file. This command lets you input a regexp and this will be matched against all tags on all image files in the database file. The files that have a -matching tag will be marked in the Dired buffer." t nil) +matching tag will be marked in the Dired buffer. + +\(fn REGEXP)" t nil) (autoload 'image-dired-dired-edit-comment-and-tags "image-dired" "\ 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-")) ;;;*** @@ -18496,7 +18852,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'. @@ -18544,23 +18900,23 @@ or call the function `auto-image-file-mode'.") (autoload 'auto-image-file-mode "image-file" "\ Toggle visiting of image files as images (Auto Image File mode). -This is a minor mode. If called interactively, toggle the +An image file is one whose name has an extension in +`image-file-name-extensions', or matches a regexp in +`image-file-name-regexps'. + +This is a global minor mode. If called interactively, toggle the `Auto-Image-File 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. +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 \\='auto-image-file-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -An image file is one whose name has an extension in -`image-file-name-extensions', or matches a regexp in -`image-file-name-regexps'. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -18573,8 +18929,8 @@ An image file is one whose name has an extension in (autoload 'image-mode "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}" t nil) @@ -18582,23 +18938,23 @@ Key bindings: (autoload 'image-minor-mode "image-mode" "\ Toggle Image minor mode in this buffer. +Image minor mode provides the key \\<image-mode-map>\\[image-toggle-display], +to switch back to `image-mode' and display an image file as the +actual image. + This is a minor mode. If called interactively, toggle the `Image minor 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. +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 `image-minor-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -Image minor mode provides the key \\<image-mode-map>\\[image-toggle-display], -to switch back to `image-mode' and display an image file as the -actual image. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -18823,7 +19179,7 @@ quoted using shell quote syntax. ;;;### (autoloads nil "info" "info.el" (0 0 0 0)) ;;; Generated autoloads from info.el -(defcustom Info-default-directory-list (let* ((config-dir (file-name-as-directory (or (and (featurep 'ns) (let ((dir (expand-file-name "../info" data-directory))) (if (file-directory-p dir) dir))) configure-info-directory))) (prefixes (prune-directory-list '("/usr/local/" "/usr/" "/opt/"))) (suffixes '("share/" "")) (standard-info-dirs (apply #'nconc (mapcar (lambda (pfx) (let ((dirs (mapcar (lambda (sfx) (concat pfx sfx "info/")) suffixes))) (prune-directory-list dirs))) prefixes))) (dirs (if (member config-dir standard-info-dirs) (nconc standard-info-dirs (list config-dir)) (cons config-dir standard-info-dirs)))) (if (not (eq system-type 'windows-nt)) dirs (let* ((instdir (file-name-directory invocation-directory)) (dir1 (expand-file-name "../info/" instdir)) (dir2 (expand-file-name "../../../info/" instdir))) (cond ((file-exists-p dir1) (append dirs (list dir1))) ((file-exists-p dir2) (append dirs (list dir2))) (t dirs))))) "\ +(defvar Info-default-directory-list nil "\ Default list of directories to search for Info documentation files. They are searched in the order they are given in the list. Therefore, the directory of Info files that come with Emacs @@ -18834,13 +19190,10 @@ first in this list. Once Info is started, the list of directories to search comes from the variable `Info-directory-list'. -This variable `Info-default-directory-list' is used as the default -for initializing `Info-directory-list' when Info is started, unless -the environment variable INFOPATH is set. -Although this is a customizable variable, that is mainly for technical -reasons. Normally, you should either set INFOPATH or customize -`Info-additional-directory-list', rather than changing this variable." :initialize #'custom-initialize-delay :type '(repeat directory)) +This variable is used as the default for initializing +`Info-directory-list' when Info is started, unless the +environment variable INFOPATH is set.") (custom-autoload 'Info-default-directory-list "info" t) @@ -18905,10 +19258,12 @@ Give an empty topic name to go to the Index node itself. \(fn TOPIC)" t nil) (autoload 'info-apropos "info" "\ -Grovel indices of all known Info files on your system for STRING. -Build a menu of the possible matches. +Search indices of all known Info files on your system for STRING. +If REGEXP (interactively, the prefix), use a regexp match. -\(fn STRING)" t nil) +Display a menu of the possible matches. + +\(fn STRING &optional REGEXP)" t nil) (autoload 'info-finder "info" "\ Display descriptions of the keywords in the Finder virtual manual. @@ -19038,25 +19393,40 @@ system." t nil) (put 'info-lookup-symbol 'info-file "emacs") (autoload 'info-lookup-symbol "info-look" "\ -Display the definition of SYMBOL, as found in the relevant manual. -When this command is called interactively, it reads SYMBOL from the -minibuffer. In the minibuffer, use \\<minibuffer-local-completion-map>\\[next-history-element] to yank the default argument -value into the minibuffer so you can edit it. The default symbol is the -one found at point. +Look up and display documentation of SYMBOL in the relevant Info manual. +SYMBOL should be an identifier: a function or method, a macro, a variable, +a data type, a class, etc. + +Interactively, prompt for SYMBOL; you can use \\<minibuffer-local-completion-map>\\[next-history-element] in the minibuffer +to yank the default argument value into the minibuffer so you can edit it. +The default symbol is the one found at point. + +MODE is the major mode whose Info manuals to search for the documentation +of SYMBOL. It defaults to the current buffer's `major-mode'; if that +mode doesn't have any Info manuals known to Emacs, the command will +prompt for MODE to use, with completion. With prefix arg, the command +always prompts for MODE. -With prefix arg MODE a query for the symbol help mode is offered. +Is SAME-WINDOW, try to reuse the current window instead of +popping up a new one. -\(fn SYMBOL &optional MODE)" t nil) +\(fn SYMBOL &optional MODE SAME-WINDOW)" t nil) (put 'info-lookup-file 'info-file "emacs") (autoload 'info-lookup-file "info-look" "\ -Display the documentation of a file. -When this command is called interactively, it reads FILE from the minibuffer. -In the minibuffer, use \\<minibuffer-local-completion-map>\\[next-history-element] to yank the default file name -into the minibuffer so you can edit it. +Look up and display documentation of FILE in the relevant Info manual. +FILE should be the name of a file; a notable example is a standard header +file that is part of the C or C++ standard library. + +Interactively, prompt for FILE; you can use \\<minibuffer-local-completion-map>\\[next-history-element] in the minibuffer +to yank the default argument value into the minibuffer so you can edit it. The default file name is the one found at point. -With prefix arg MODE a query for the file help mode is offered. +MODE is the major mode whose Info manuals to search for the documentation +of FILE. It defaults to the current buffer's `major-mode'; if that +mode doesn't have any Info manuals known to Emacs, the command will +prompt for MODE to use, with completion. With prefix arg, the command +always prompts for MODE. \(fn FILE &optional MODE)" t nil) @@ -19384,7 +19754,7 @@ Valid forms include: (KEY REGEXP) - skip to end of REGEXP. REGEXP must be a string. (KEY FUNCTION ARGS) - FUNCTION called with ARGS returns end of region.") -(defvar ispell-tex-skip-alists (purecopy '((("\\\\addcontentsline" ispell-tex-arg-end 2) ("\\\\add\\(tocontents\\|vspace\\)" ispell-tex-arg-end) ("\\\\\\([aA]lph\\|arabic\\)" ispell-tex-arg-end) ("\\\\cref" ispell-tex-arg-end) ("\\\\bibliographystyle" ispell-tex-arg-end) ("\\\\makebox" ispell-tex-arg-end 0) ("\\\\e?psfig" ispell-tex-arg-end) ("\\\\document\\(class\\|style\\)" . "\\\\begin[ \11\n]*{[ \11\n]*document[ \11\n]*}")) (("\\(figure\\|table\\)\\*?" ispell-tex-arg-end 0) ("list" ispell-tex-arg-end 2) ("program" . "\\\\end[ \11\n]*{[ \11\n]*program[ \11\n]*}") ("verbatim\\*?" . "\\\\end[ \11\n]*{[ \11\n]*verbatim\\*?[ \11\n]*}")))) "\ +(defvar ispell-tex-skip-alists (purecopy '((("\\\\addcontentsline" ispell-tex-arg-end 2) ("\\\\add\\(tocontents\\|vspace\\)" ispell-tex-arg-end) ("\\\\\\([aA]lph\\|arabic\\)" ispell-tex-arg-end) ("\\\\cref" ispell-tex-arg-end) ("\\\\bibliographystyle" ispell-tex-arg-end) ("\\\\makebox" ispell-tex-arg-end 0) ("\\\\e?psfig" ispell-tex-arg-end) ("\\\\document\\(class\\|style\\)" . "\\\\begin[ \11\n]*{document}")) (("\\(figure\\|table\\)\\*?" ispell-tex-arg-end 0) ("list" ispell-tex-arg-end 2) ("program" . "\\\\end[ \11]*{program}") ("verbatim\\*?" . "\\\\end[ \11]*{verbatim\\*?}")))) "\ Lists of regions to be skipped in TeX mode. First list is used raw. Second list has key placed inside \\begin{}. @@ -19443,24 +19813,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). @@ -19480,6 +19850,8 @@ By just answering RET you can find out what the current dictionary is. (autoload 'ispell-region "ispell" "\ Interactively check a region for spelling errors. +Leave the mark at the last misspelled word that the user was queried about. + Return nil if spell session was terminated, otherwise returns shift offset amount for last line processed. @@ -19498,7 +19870,8 @@ to limit the check. Check the comment or string containing point for spelling errors." t nil) (autoload 'ispell-buffer "ispell" "\ -Check the current buffer for spelling errors interactively." t nil) +Check the current buffer for spelling errors interactively. +Leave the mark at the last misspelled word that the user was queried about." t nil) (autoload 'ispell-buffer-with-debug "ispell" "\ `ispell-buffer' with some output sent to `ispell-debug-buffer'. @@ -19534,20 +19907,6 @@ available on the net." t nil) (autoload 'ispell-minor-mode "ispell" "\ Toggle last-word spell checking (Ispell minor mode). -This is a minor mode. If called interactively, toggle the `ISpell -minor 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 `ispell-minor-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Ispell minor mode is a buffer-local minor mode. When enabled, typing SPC or RET warns you if the previous word is incorrectly spelled. @@ -19559,6 +19918,20 @@ SPC. For spell-checking \"on the fly\", not just after typing SPC or RET, use `flyspell-mode'. +This is a minor mode. If called interactively, toggle the +`ISpell minor 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 `ispell-minor-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'ispell-message "ispell" "\ @@ -19567,8 +19940,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: @@ -19728,7 +20101,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-")) ;;;*** @@ -19742,7 +20115,7 @@ one of the aforementioned options instead of using this mode. ;;;### (autoloads nil "jsonrpc" "jsonrpc.el" (0 0 0 0)) ;;; Generated autoloads from jsonrpc.el -(push (purecopy '(jsonrpc 1 0 14)) package--builtin-versions) +(push (purecopy '(jsonrpc 1 0 15)) package--builtin-versions) (register-definition-prefixes "jsonrpc" '("jsonrpc-")) @@ -19868,11 +20241,9 @@ and the return value is the length of the conversion. (global-set-key "\C-x\C-k" #'kmacro-keymap) (autoload 'kmacro-keymap "kmacro" "Keymap for keyboard macro commands." t 'keymap) -(autoload 'kmacro-exec-ring-item "kmacro" "\ +(define-obsolete-function-alias 'kmacro-exec-ring-item #'funcall "29.1" "\ Execute item ITEM from the macro ring. -ARG is the number of times to execute the item. - -\(fn ITEM ARG)" nil nil) +ARG is the number of times to execute the item.") (autoload 'kmacro-start-macro "kmacro" "\ Record subsequent keyboard input, defining a keyboard macro. @@ -19973,12 +20344,20 @@ If kbd macro currently being defined end it before activating it. \(fn EVENT)" t nil) +(autoload 'kmacro "kmacro" "\ +Create a `kmacro' for macro bound to symbol or key. +KEYS should be a vector or a string that obeys `key-valid-p'. + +\(fn KEYS &optional COUNTER FORMAT)" nil nil) + (autoload 'kmacro-lambda-form "kmacro" "\ -Create lambda form for macro bound to symbol or key. + \(fn MAC &optional COUNTER FORMAT)" nil nil) -(register-definition-prefixes "kmacro" '("kdb-macro-redisplay" "kmacro-")) +(make-obsolete 'kmacro-lambda-form 'kmacro '"29.1") + +(register-definition-prefixes "kmacro" '("kmacro-")) ;;;*** @@ -20232,21 +20611,25 @@ sleep in seconds. (autoload 'linum-mode "linum" "\ Toggle display of line numbers in the left margin (Linum mode). +This mode has been largely replaced by `display-line-numbers-mode' +\(which is much faster and has fewer interaction problems with other +modes). + +Linum mode is a buffer-local minor mode. + This is a minor mode. If called interactively, toggle the `Linum -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. +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. +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 `linum-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -Linum mode is a buffer-local minor mode. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -20638,7 +21021,7 @@ and then select the region of un-tablified names and use \(fn TOP BOTTOM &optional MACRO)" t nil) (define-key ctl-x-map "q" 'kbd-macro-query) -(register-definition-prefixes "macros" '("macros--insert-vector-macro")) +(register-definition-prefixes "macros" '("macro")) ;;;*** @@ -20824,24 +21207,24 @@ or call the function `mail-abbrevs-mode'.") (autoload 'mail-abbrevs-mode "mailabbrev" "\ Toggle abbrev expansion of mail aliases (Mail Abbrevs mode). -This is a minor mode. If called interactively, toggle the -`Mail-Abbrevs mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +Mail Abbrevs mode is a global minor mode. When enabled, +abbrev-like expansion is performed when editing certain mail +headers (those specified by `mail-abbrev-mode-regexp'), based on +the entries in your `mail-personal-alias-file'. -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. +This is a global minor mode. If called interactively, toggle the +`Mail-Abbrevs 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 \\='mail-abbrevs-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -Mail Abbrevs mode is a global minor mode. When enabled, -abbrev-like expansion is performed when editing certain mail -headers (those specified by `mail-abbrev-mode-regexp'), based on -the entries in your `mail-personal-alias-file'. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -20925,6 +21308,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-")) ;;;*** @@ -21188,6 +21577,11 @@ Default bookmark handler for Man buffers. \(fn BOOKMARK)" nil nil) +(autoload 'Man-context-menu "man" "\ +Populate MENU with commands that open a man page at point. + +\(fn MENU CLICK)" nil nil) + (register-definition-prefixes "man" '("Man-" "man")) ;;;*** @@ -21206,20 +21600,6 @@ Default bookmark handler for Man buffers. (autoload 'master-mode "master" "\ Toggle Master mode. -This is a minor mode. If called interactively, toggle the `Master -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 `master-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - When Master mode is enabled, you can scroll the slave buffer using the following commands: @@ -21229,6 +21609,20 @@ The slave buffer is stored in the buffer-local variable `master-of'. You can set this variable using `master-set-slave'. You can show yourself the value of `master-of' by calling `master-show-slave'. +This is a minor mode. If called interactively, toggle the +`Master 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 `master-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 "master" '("master-")) @@ -21251,25 +21645,25 @@ or call the function `minibuffer-depth-indicate-mode'.") (autoload 'minibuffer-depth-indicate-mode "mb-depth" "\ Toggle Minibuffer Depth Indication mode. -This is a minor mode. If called interactively, toggle the +Minibuffer Depth Indication mode is a global minor mode. When +enabled, any recursive use of the minibuffer will show the +recursion depth in the minibuffer prompt. This is only useful if +`enable-recursive-minibuffers' is non-nil. + +This is a global minor mode. If called interactively, toggle the `Minibuffer-Depth-Indicate mode' mode. If the prefix argument is -positive, enable the mode, and if it is zero or negative, disable the -mode. +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. +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 \\='minibuffer-depth-indicate-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -Minibuffer Depth Indication mode is a global minor mode. When -enabled, any recursive use of the minibuffer will show the -recursion depth in the minibuffer prompt. This is only useful if -`enable-recursive-minibuffers' is non-nil. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -21426,7 +21820,7 @@ Command to parse command line mailto: links. This is meant to be used for MIME handlers: Setting the handler for \"x-scheme-handler/mailto;\" to \"emacs -f message-mailto %u\" will then start up Emacs ready to compose mail. For emacsclient use - emacsclient -e '(message-mailto \"%u\")' + emacsclient -e \\='(message-mailto \"%u\")' \(fn &optional URL)" t nil) @@ -21662,7 +22056,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-")) ;;;*** @@ -21698,7 +22092,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-")) ;;;*** @@ -21733,7 +22127,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-")) ;;;*** @@ -21747,14 +22141,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-")) ;;;*** @@ -21820,19 +22214,19 @@ or call the function `midnight-mode'.") (autoload 'midnight-mode "midnight" "\ Non-nil means run `midnight-hook' at midnight. -This is a minor mode. If called interactively, toggle the `Midnight -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. +This is a global minor mode. If called interactively, toggle the +`Midnight 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. +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 \\='midnight-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -21875,21 +22269,6 @@ or call the function `minibuffer-electric-default-mode'.") (autoload 'minibuffer-electric-default-mode "minibuf-eldef" "\ Toggle Minibuffer Electric Default mode. -This is a minor mode. If called interactively, toggle the -`Minibuffer-Electric-Default 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 \\='minibuffer-electric-default-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Minibuffer Electric Default mode is a global minor mode. When enabled, minibuffer prompts that show a default value only show the default when it's applicable -- that is, when hitting RET @@ -21897,6 +22276,21 @@ would yield the default value. If the user modifies the input such that hitting RET would enter a non-default value, the prompt is modified to remove the default indication. +This is a global minor mode. If called interactively, toggle the +`Minibuffer-Electric-Default 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 \\='minibuffer-electric-default-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 "minibuf-eldef" '("minibuf")) @@ -21916,11 +22310,14 @@ The characters copied are inserted in the buffer before point. (autoload 'zap-up-to-char "misc" "\ Kill up to, but not including ARGth occurrence of CHAR. +When run interactively, the argument INTERACTIVE is non-nil. Case is ignored if `case-fold-search' is non-nil in the current buffer. Goes backward if ARG is negative; error if CHAR not found. Ignores CHAR at point. +If called interactively, do a case sensitive search if CHAR +is an upper-case character. -\(fn ARG CHAR)" t nil) +\(fn ARG CHAR &optional INTERACTIVE)" t nil) (autoload 'mark-beginning-of-buffer "misc" "\ Set mark at the beginning of the buffer." t nil) @@ -22099,7 +22496,7 @@ Major mode for the mixal asm language. ;;;### (autoloads nil "mm-encode" "gnus/mm-encode.el" (0 0 0 0)) ;;; Generated autoloads from gnus/mm-encode.el -(define-obsolete-function-alias 'mm-default-file-encoding #'mm-default-file-type "future") +(define-obsolete-function-alias 'mm-default-file-encoding #'mm-default-file-type "28.1") (autoload 'mm-default-file-type "mm-encode" "\ Return a default content type for FILE. @@ -22217,6 +22614,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. @@ -22460,22 +22859,22 @@ or call the function `msb-mode'.") (autoload 'msb-mode "msb" "\ Toggle Msb mode. -This is a minor mode. If called interactively, toggle the `Msb mode' -mode. If the prefix argument is positive, enable the mode, and if it -is zero or negative, disable the mode. +This mode overrides the binding(s) of `mouse-buffer-menu' to provide a +different buffer menu using the function `msb'. -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. +This is a global minor mode. If called interactively, toggle the +`Msb 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 \\='msb-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -This mode overrides the binding(s) of `mouse-buffer-menu' to provide a -different buffer menu using the function `msb'. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -22772,6 +23171,30 @@ QUALITY can be: ;;;*** +;;;### (autoloads nil "multisession" "emacs-lisp/multisession.el" +;;;;;; (0 0 0 0)) +;;; Generated autoloads from emacs-lisp/multisession.el + +(autoload 'define-multisession-variable "multisession" "\ +Make NAME into a multisession variable initialized from INITIAL-VALUE. +DOC should be a doc string, and ARGS are keywords as applicable to +`make-multisession'. + +\(fn NAME INITIAL-VALUE &optional DOC &rest ARGS)" nil t) + +(function-put 'define-multisession-variable 'lisp-indent-function 'defun) + +(autoload 'list-multisession-values "multisession" "\ +List all values in the \"multisession\" database. +If CHOOSE-STORAGE (interactively, the prefix), query for the +storage method to list. + +\(fn &optional CHOOSE-STORAGE)" t nil) + +(register-definition-prefixes "multisession" '("multisession-")) + +;;;*** + ;;;### (autoloads nil "mwheel" "mwheel.el" (0 0 0 0)) ;;; Generated autoloads from mwheel.el @@ -22788,19 +23211,19 @@ or call the function `mouse-wheel-mode'.") (autoload 'mouse-wheel-mode "mwheel" "\ Toggle mouse wheel support (Mouse Wheel mode). -This is a minor mode. If called interactively, toggle the -`Mouse-Wheel mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +This is a global minor mode. If called interactively, toggle the +`Mouse-Wheel 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. +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 \\='mouse-wheel-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -24057,7 +24480,7 @@ Coloring: ;;;### (autoloads nil "org" "org/org.el" (0 0 0 0)) ;;; Generated autoloads from org/org.el -(push (purecopy '(org 9 5 2)) package--builtin-versions) +(push (purecopy '(org 9 5 3)) package--builtin-versions) (autoload 'org-babel-do-load-languages "org" "\ Load the languages defined in `org-babel-load-languages'. @@ -24421,7 +24844,7 @@ is active. \(fn &optional TODO-ONLY STRING EDIT-AT)" t nil) (autoload 'org-todo-list "org-agenda" "\ -Show all (not done) TODO entries from all agenda file in a single list. +Show all (not done) TODO entries from all agenda files in a single list. The prefix arg can be used to select a specific TODO keyword and limit the list to these. When using `\\[universal-argument]', you will be prompted for a keyword. A numeric prefix directly selects the Nth keyword in @@ -24482,7 +24905,7 @@ Set restriction lock for agenda to current subtree or file. When in a restricted subtree, remove it. The restriction will span over the entire file if TYPE is `file', -or if type is '(4), or if the cursor is before the first headline +or if type is \\='(4), or if the cursor is before the first headline in the file. Otherwise, only apply the restriction to the current subtree. @@ -24731,27 +25154,25 @@ Turning on outline mode calls the value of `text-mode-hook' and then of `outline-mode-hook', if they are non-nil. \(fn)" t nil) -(put 'outline-minor-mode-cycle 'safe-local-variable 'booleanp) -(put 'outline-minor-mode-highlight 'safe-local-variable 'symbolp) (autoload 'outline-minor-mode "outline" "\ Toggle Outline minor mode. -This is a minor mode. If called interactively, toggle the `Outline -minor mode' mode. If the prefix argument is positive, enable the -mode, and if it is zero or negative, disable the mode. +See the command `outline-mode' for more information on this mode. + +This is a minor mode. If called interactively, toggle the +`Outline minor 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. +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 `outline-minor-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -See the command `outline-mode' for more information on this mode. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -24928,7 +25349,7 @@ that code in the early init-file. (defun package-activate-all nil "\ Activate all installed packages. -The variable `package-load-list' controls which packages to load." (setq package--activated t) (let* ((elc (concat package-quickstart-file "c")) (qs (if (file-readable-p elc) elc (if (file-readable-p package-quickstart-file) package-quickstart-file)))) (if qs (let ((load-source-file-function nil)) (unless (boundp 'package-activated-list) (setq package-activated-list nil)) (load qs nil 'nomessage)) (require 'package) (package--activate-all)))) +The variable `package-load-list' controls which packages to load." (setq package--activated t) (let* ((elc (concat package-quickstart-file "c")) (qs (if (file-readable-p elc) elc (if (file-readable-p package-quickstart-file) package-quickstart-file)))) (if (and qs (not (bound-and-true-p package-activated-list))) (let ((load-source-file-function nil)) (unless (boundp 'package-activated-list) (setq package-activated-list nil)) (load qs nil 'nomessage)) (require 'package) (package--activate-all)))) (autoload 'package-import-keyring "package" "\ Import keys from FILE. @@ -24945,6 +25366,15 @@ downloads in the background. \(fn &optional ASYNC)" t nil) +(autoload 'package-installed-p "package" "\ +Return non-nil if PACKAGE, of MIN-VERSION or newer, is installed. +If PACKAGE is a symbol, it is the package name and MIN-VERSION +should be a version list. + +If PACKAGE is a `package-desc' object, MIN-VERSION is ignored. + +\(fn PACKAGE &optional MIN-VERSION)" nil nil) + (autoload 'package-install "package" "\ Install the package PKG. PKG can be a `package-desc' or a symbol naming one of the @@ -24963,6 +25393,18 @@ to install it but still mark it as selected. \(fn PKG &optional DONT-SELECT)" t nil) +(autoload 'package-update "package" "\ +Update package NAME if a newer version exists. + +\(fn NAME)" t nil) + +(autoload 'package-update-all "package" "\ +Refresh package list and upgrade all packages. +If QUERY, ask the user before updating packages. When called +interactively, QUERY is always true. + +\(fn &optional QUERY)" t nil) + (autoload 'package-install-from-buffer "package" "\ Install a package from the current buffer. The current buffer is assumed to be a single .el or .tar file or @@ -25025,7 +25467,9 @@ short description. Return the version number of the package in which this is used. Assumes it is used from an Elisp file placed inside the top-level directory of an installed ELPA package. -The return value is a string (or nil in case we can't find it)." nil nil) +The return value is a string (or nil in case we can't find it). +It works in more cases if the call is in the file which contains +the `Version:' header." nil nil) (function-put 'package-get-version 'pure 't) @@ -25291,7 +25735,7 @@ PATTERNS are normal `pcase' patterns, and VALUES are expression. Evaluation happens sequentially as in `setq' (not in parallel). -An example: (pcase-setq `((,a) [(,b)]) '((1) [(2)])) +An example: (pcase-setq \\=`((,a) [(,b)]) \\='((1) [(2)])) VAL is presumed to match PAT. Failure to match may signal an error or go undetected, binding variables to arbitrary values, such as nil. @@ -25761,6 +26205,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 @@ -25777,19 +26229,52 @@ or call the function `pixel-scroll-mode'.") (autoload 'pixel-scroll-mode "pixel-scroll" "\ A minor mode to scroll text pixel-by-pixel. -This is a minor mode. If called interactively, toggle the -`Pixel-Scroll mode' mode. If the prefix argument is positive, enable -the mode, and if it is zero or negative, disable the mode. +This is a global minor mode. If called interactively, toggle the +`Pixel-Scroll 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. +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-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is 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 global 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) @@ -25873,10 +26358,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'. @@ -25902,6 +26403,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-")) ;;;*** @@ -26452,8 +26959,12 @@ are both set to t. (autoload 'proced "proced" "\ Generate a listing of UNIX system processes. \\<proced-mode-map> -If invoked with optional ARG, do not select the window displaying -the process information. +If invoked with optional non-negative ARG, do not select the +window displaying the process information. + +If `proced-show-remote-processes' is non-nil or the command is +invoked with a negative ARG `\\[universal-argument] \\[negative-argument]', and `default-directory' +points to a remote host, the system processes of that host are shown. This function runs the normal hook `proced-post-display-hook'. @@ -26576,13 +27087,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) @@ -26628,6 +27151,10 @@ command \\[fileloop-continue]. (autoload 'project-query-replace-regexp "project" "\ Query-replace REGEXP in all the files of the project. Stops when a match is found and prompts for whether to replace it. +At that prompt, the user must type a character saying what to do +with the match. Type SPC or `y' to replace the match, +DEL or `n' to skip and go to the next match. For more directions, +type \\[help-command] at that time. If you exit the `query-replace', you can later continue the `query-replace' loop using the command \\[fileloop-continue]. @@ -26682,6 +27209,8 @@ is non-nil, the command will not ask the user for confirmation. NO-CONFIRM is always nil when the command is invoked interactively. +Also see the `project-kill-buffers-display-buffer-list' variable. + \(fn &optional NO-CONFIRM)" t nil) (autoload 'project-remember-project "project" "\ @@ -27141,8 +27670,8 @@ If it is nil, the current key is shown. DOCSTRING is the documentation string of this package. The command `describe-input-method' shows this string while replacing the form -\\=\\<VAR> in the string by the value of VAR. That value should be a -string. For instance, the form \\=\\<quail-translation-docstring> is +\\=\\=\\=\\<VAR> in the string by the value of VAR. That value should be a +string. For instance, the form \\=\\=\\=\\<quail-translation-docstring> is replaced by a description about how to select a translation from a list of candidates. @@ -27522,6 +28051,13 @@ Display `quickurl-list' as a formatted list using `quickurl-list-mode'." t nil) ;;;*** +;;;### (autoloads nil "range" "emacs-lisp/range.el" (0 0 0 0)) +;;; Generated autoloads from emacs-lisp/range.el + +(register-definition-prefixes "range" '("range-")) + +;;;*** + ;;;### (autoloads nil "rcirc" "net/rcirc.el" (0 0 0 0)) ;;; Generated autoloads from net/rcirc.el @@ -27539,11 +28075,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. @@ -27558,19 +28094,20 @@ or call the function `rcirc-track-minor-mode'.") (autoload 'rcirc-track-minor-mode "rcirc" "\ Global minor mode for tracking activity in rcirc buffers. -This is a minor mode. If called interactively, toggle the -`Rcirc-Track minor mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +This is a global minor mode. If called interactively, toggle the +`Rcirc-Track minor 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. +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 \\='rcirc-track-minor-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -27618,20 +28155,6 @@ or call the function `recentf-mode'.") (autoload 'recentf-mode "recentf" "\ Toggle \"Open Recent\" menu (Recentf mode). -This is a minor mode. If called interactively, toggle the `Recentf -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 \\='recentf-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - When Recentf mode is enabled, a \"Open Recent\" submenu is displayed in the \"File\" menu, containing a list of files that were operated on recently, in the most-recently-used order. @@ -27641,7 +28164,21 @@ to a file, and killing a buffer is counted as \"operating\" on the file. If instead you want to prioritize files that appear in buffers you switch to a lot, you can say something like the following: - (add-hook 'buffer-list-update-hook 'recentf-track-opened-file) + (add-hook \\='buffer-list-update-hook #\\='recentf-track-opened-file) + +This is a global minor mode. If called interactively, toggle the +`Recentf 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 \\='recentf-mode)'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -27786,22 +28323,22 @@ with a prefix argument, prompt for START-AT and FORMAT. (autoload 'rectangle-mark-mode "rect" "\ Toggle the region as rectangular. +Activates the region if it's inactive and Transient Mark mode is +on. Only lasts until the region is next deactivated. + This is a minor mode. If called interactively, toggle the `Rectangle-Mark 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. +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 `rectangle-mark-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -Activates the region if it's inactive and Transient Mark mode is -on. Only lasts until the region is next deactivated. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -27829,20 +28366,6 @@ on. Only lasts until the region is next deactivated. (autoload 'refill-mode "refill" "\ Toggle automatic refilling (Refill mode). -This is a minor mode. If called interactively, toggle the `Refill -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 `refill-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Refill mode is a buffer-local minor mode. When enabled, the current paragraph is refilled as you edit. Self-inserting characters only cause refilling if they would cause @@ -27850,6 +28373,20 @@ auto-filling. For true \"word wrap\" behavior, use `visual-line-mode' instead. +This is a minor mode. If called interactively, toggle the +`Refill 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 `refill-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 "refill" '("refill-")) @@ -27869,20 +28406,6 @@ Turn on RefTeX mode." nil nil) (autoload 'reftex-mode "reftex" "\ Minor mode with distinct support for \\label, \\ref and \\cite in LaTeX. -This is a minor mode. If called interactively, toggle the `Reftex -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 `reftex-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - \\<reftex-mode-map>A Table of Contents of the entire (multifile) document with browsing capabilities is available with `\\[reftex-toc]'. @@ -27911,6 +28434,20 @@ on the menu bar. ------------------------------------------------------------------------------ +This is a minor mode. If called interactively, toggle the +`Reftex 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 `reftex-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'reftex-reset-scanning-information "reftex" "\ @@ -28099,23 +28636,24 @@ or call the function `repeat-mode'.") (autoload 'repeat-mode "repeat" "\ Toggle Repeat mode. + When Repeat mode is enabled, and the command symbol has the property named `repeat-map', this map is activated temporarily for the next command. See `describe-repeat-maps' for a list of all repeatable commands. -This is a minor mode. If called interactively, toggle the `Repeat -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. +This is a global minor mode. If called interactively, toggle the +`Repeat 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. +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 \\='repeat-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -28192,24 +28730,24 @@ report errors as appropriate for this kind of usage. (autoload 'reveal-mode "reveal" "\ Toggle uncloaking of invisible text near point (Reveal mode). -This is a minor mode. If called interactively, toggle the `Reveal -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. +Reveal mode is a buffer-local minor mode. When enabled, it +reveals invisible text around point. -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. +Also see the `reveal-auto-hide' variable. -To check whether the minor mode is enabled in the current buffer, -evaluate `reveal-mode'. +This is a minor mode. If called interactively, toggle the +`Reveal mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. -The mode's hook is called both when the mode is enabled and when it is -disabled. +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. -Reveal mode is a buffer-local minor mode. When enabled, it -reveals invisible text around point. +To check whether the minor mode is enabled in the current buffer, +evaluate `reveal-mode'. -Also see the `reveal-auto-hide' variable. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -28225,21 +28763,22 @@ or call the function `global-reveal-mode'.") (autoload 'global-reveal-mode "reveal" "\ Toggle Reveal mode in all buffers (Global Reveal mode). + Reveal mode renders invisible text around point visible again. -This is a minor mode. If called interactively, toggle the `Global -Reveal mode' mode. If the prefix argument is positive, enable the -mode, and if it is zero or negative, disable the mode. +This is a global minor mode. If called interactively, toggle the +`Global Reveal 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. +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 \\='global-reveal-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -28563,6 +29102,103 @@ Set PASSWORD to be used for retrieving mail from a POP or IMAP server. ;;;*** +;;;### (autoloads nil "rmailedit" "mail/rmailedit.el" (0 0 0 0)) +;;; Generated autoloads from mail/rmailedit.el + +(autoload 'rmail-edit-current-message "rmailedit" "\ +Edit the contents of this message." t nil) + +(register-definition-prefixes "rmailedit" '("rmail-")) + +;;;*** + +;;;### (autoloads nil "rmailkwd" "mail/rmailkwd.el" (0 0 0 0)) +;;; Generated autoloads from mail/rmailkwd.el + +(autoload 'rmail-add-label "rmailkwd" "\ +Add LABEL to labels associated with current RMAIL message. +Completes (see `rmail-read-label') over known labels when reading. +LABEL may be a symbol or string. Only one label is allowed. + +\(fn LABEL)" t nil) + +(autoload 'rmail-kill-label "rmailkwd" "\ +Remove LABEL from labels associated with current RMAIL message. +Completes (see `rmail-read-label') over known labels when reading. +LABEL may be a symbol or string. Only one label is allowed. + +\(fn LABEL)" t nil) + +(autoload 'rmail-read-label "rmailkwd" "\ +Read a label with completion, prompting with PROMPT. +Completions are chosen from `rmail-label-obarray'. The default +is `rmail-last-label', if that is non-nil. Updates `rmail-last-label' +according to the choice made, and returns a symbol. + +\(fn PROMPT)" nil nil) + +(autoload 'rmail-previous-labeled-message "rmailkwd" "\ +Show previous message with one of the labels LABELS. +LABELS should be a comma-separated list of label names. +If LABELS is empty, the last set of labels specified is used. +With prefix argument N moves backward N messages with these labels. + +\(fn N LABELS)" t nil) + +(autoload 'rmail-next-labeled-message "rmailkwd" "\ +Show next message with one of the labels LABELS. +LABELS should be a comma-separated list of label names. +If LABELS is empty, the last set of labels specified is used. +With prefix argument N moves forward N messages with these labels. + +\(fn N LABELS)" t nil) + +(register-definition-prefixes "rmailkwd" '("rmail-")) + +;;;*** + +;;;### (autoloads nil "rmailmm" "mail/rmailmm.el" (0 0 0 0)) +;;; Generated autoloads from mail/rmailmm.el + +(autoload 'rmail-mime "rmailmm" "\ +Toggle the display of a MIME message. + +The actual behavior depends on the value of `rmail-enable-mime'. + +If `rmail-enable-mime' is non-nil (the default), this command toggles +the display of a MIME message between decoded presentation form and +raw data. With optional prefix argument ARG, it toggles the display only +of the MIME entity at point, if there is one. The optional argument +STATE forces a particular display state, rather than toggling. +`raw' forces raw mode, any other non-nil value forces decoded mode. + +If `rmail-enable-mime' is nil, this creates a temporary \"*RMAIL*\" +buffer holding a decoded copy of the message. Inline content-types +are handled according to `rmail-mime-media-type-handlers-alist'. +By default, this displays text and multipart messages, and offers to +download attachments as specified by `rmail-mime-attachment-dirs-alist'. +The arguments ARG and STATE have no effect in this case. + +\(fn &optional ARG STATE)" t nil) + +(register-definition-prefixes "rmailmm" '("rmail-")) + +;;;*** + +;;;### (autoloads nil "rmailmsc" "mail/rmailmsc.el" (0 0 0 0)) +;;; Generated autoloads from mail/rmailmsc.el + +(autoload 'set-rmail-inbox-list "rmailmsc" "\ +Set the inbox list of the current RMAIL file to FILE-NAME. +You can specify one file name, or several names separated by commas. +If FILE-NAME is empty, remove any existing inbox list. + +This applies only to the current session. + +\(fn FILE-NAME)" t nil) + +;;;*** + ;;;### (autoloads nil "rmailout" "mail/rmailout.el" (0 0 0 0)) ;;; Generated autoloads from mail/rmailout.el (put 'rmail-output-file-alist 'risky-local-variable t) @@ -28635,6 +29271,113 @@ than appending to it. Deletes the message after writing if ;;;*** +;;;### (autoloads nil "rmailsort" "mail/rmailsort.el" (0 0 0 0)) +;;; Generated autoloads from mail/rmailsort.el + +(autoload 'rmail-sort-by-date "rmailsort" "\ +Sort messages of current Rmail buffer by \"Date\" header. +If prefix argument REVERSE is non-nil, sorts in reverse order. + +\(fn REVERSE)" t nil) + +(autoload 'rmail-sort-by-subject "rmailsort" "\ +Sort messages of current Rmail buffer by \"Subject\" header. +Ignores any \"Re: \" prefix. If prefix argument REVERSE is +non-nil, sorts in reverse order. + +\(fn REVERSE)" t nil) + +(autoload 'rmail-sort-by-author "rmailsort" "\ +Sort messages of current Rmail buffer by author. +This uses either the \"From\" or \"Sender\" header, downcased. +If prefix argument REVERSE is non-nil, sorts in reverse order. + +\(fn REVERSE)" t nil) + +(autoload 'rmail-sort-by-recipient "rmailsort" "\ +Sort messages of current Rmail buffer by recipient. +This uses either the \"To\" or \"Apparently-To\" header, downcased. +If prefix argument REVERSE is non-nil, sorts in reverse order. + +\(fn REVERSE)" t nil) + +(autoload 'rmail-sort-by-correspondent "rmailsort" "\ +Sort messages of current Rmail buffer by other correspondent. +This uses either the \"From\", \"Sender\", \"To\", or +\"Apparently-To\" header, downcased. Uses the first header not +excluded by `mail-dont-reply-to-names'. If prefix argument +REVERSE is non-nil, sorts in reverse order. + +\(fn REVERSE)" t nil) + +(autoload 'rmail-sort-by-lines "rmailsort" "\ +Sort messages of current Rmail buffer by the number of lines. +If prefix argument REVERSE is non-nil, sorts in reverse order. + +\(fn REVERSE)" t nil) + +(autoload 'rmail-sort-by-labels "rmailsort" "\ +Sort messages of current Rmail buffer by labels. +LABELS is a comma-separated list of labels. The order of these +labels specifies the order of messages: messages with the first +label come first, messages with the second label come second, and +so on. Messages that have none of these labels come last. +If prefix argument REVERSE is non-nil, sorts in reverse order. + +\(fn REVERSE LABELS)" t nil) + +(register-definition-prefixes "rmailsort" '("rmail-")) + +;;;*** + +;;;### (autoloads nil "rmailsum" "mail/rmailsum.el" (0 0 0 0)) +;;; Generated autoloads from mail/rmailsum.el + +(autoload 'rmail-summary "rmailsum" "\ +Display a summary of all messages, one line per message." t nil) + +(autoload 'rmail-summary-by-labels "rmailsum" "\ +Display a summary of all messages with one or more LABELS. +LABELS should be a string containing the desired labels, separated by commas. + +\(fn LABELS)" t nil) + +(autoload 'rmail-summary-by-recipients "rmailsum" "\ +Display a summary of all messages with the given RECIPIENTS. +Normally checks the To, From and Cc fields of headers; +but if PRIMARY-ONLY is non-nil (prefix arg given), + only look in the To and From fields. +RECIPIENTS is a regular expression. + +\(fn RECIPIENTS &optional PRIMARY-ONLY)" t nil) + +(autoload 'rmail-summary-by-regexp "rmailsum" "\ +Display a summary of all messages according to regexp REGEXP. +If the regular expression is found in the header of the message +\(including in the date and other lines, as well as the subject line), +Emacs will list the message in the summary. + +\(fn REGEXP)" t nil) + +(autoload 'rmail-summary-by-topic "rmailsum" "\ +Display a summary of all messages with the given SUBJECT. +Normally checks just the Subject field of headers; but with prefix +argument WHOLE-MESSAGE is non-nil, looks in the whole message. +SUBJECT is a regular expression. + +\(fn SUBJECT &optional WHOLE-MESSAGE)" t nil) + +(autoload 'rmail-summary-by-senders "rmailsum" "\ +Display a summary of all messages whose \"From\" field matches SENDERS. +SENDERS is a regular expression. The default for SENDERS matches the +sender of the current message. + +\(fn SENDERS)" t nil) + +(register-definition-prefixes "rmailsum" '("rmail-")) + +;;;*** + ;;;### (autoloads nil "rmc" "emacs-lisp/rmc.el" (0 0 0 0)) ;;; Generated autoloads from emacs-lisp/rmc.el @@ -28654,6 +29397,9 @@ the optional argument HELP-STRING. This argument is a string that should contain a more detailed description of all of the possible choices. `read-multiple-choice' will display that description in a help buffer if the user requests that. +If optional argument SHOW-HELP is non-nil, show the help screen +immediately, before any user input. If SHOW-HELP is a string, +use it as the name of the help buffer. This function translates user input into responses by consulting the bindings in `query-replace-map'; see the documentation of @@ -28680,7 +29426,9 @@ Usage example: (?s \"session only\") (?n \"no\"))) -\(fn PROMPT CHOICES &optional HELP-STRING)" nil nil) +\(fn PROMPT CHOICES &optional HELP-STRING SHOW-HELP)" nil nil) + +(register-definition-prefixes "rmc" '("rmc--")) ;;;*** @@ -28771,20 +29519,6 @@ Validation will be enabled if `rng-nxml-auto-validate-flag' is non-nil." t nil) (autoload 'rng-validate-mode "rng-valid" "\ Minor mode performing continual validation against a RELAX NG schema. -This is a minor mode. If called interactively, toggle the -`Rng-Validate 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 `rng-validate-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Checks whether the buffer is a well-formed XML 1.0 document, conforming to the XML Namespaces Recommendation and valid against a RELAX NG schema. The mode-line indicates whether it is or not. Any @@ -28805,6 +29539,20 @@ conventionally have a suffix of `.rnc'). The variable `rng-schema-locating-files' specifies files containing rules to use for finding the schema. +This is a minor mode. If called interactively, toggle the +`Rng-Validate 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 `rng-validate-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 "rng-valid" '("rng-")) @@ -28814,7 +29562,7 @@ to use for finding the schema. ;;;### (autoloads nil "rng-xsd" "nxml/rng-xsd.el" (0 0 0 0)) ;;; Generated autoloads from nxml/rng-xsd.el -(put 'http://www\.w3\.org/2001/XMLSchema-datatypes 'rng-dt-compile #'rng-xsd-compile) +(put 'http://www.w3.org/2001/XMLSchema-datatypes 'rng-dt-compile #'rng-xsd-compile) (autoload 'rng-xsd-compile "rng-xsd" "\ Provide W3C XML Schema as a RELAX NG datatypes library. @@ -28931,23 +29679,23 @@ highlighting. (autoload 'rst-minor-mode "rst" "\ Toggle ReST minor mode. -This is a minor mode. If called interactively, toggle the `Rst minor -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. +When ReST minor mode is enabled, the ReST mode keybindings +are installed on top of the major mode bindings. Use this +for modes derived from Text mode, like Mail mode. + +This is a minor mode. If called interactively, toggle the `Rst +minor 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. +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 `rst-minor-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -When ReST minor mode is enabled, the ReST mode keybindings -are installed on top of the major mode bindings. Use this -for modes derived from Text mode, like Mail mode. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -28991,18 +29739,18 @@ Use the command `ruler-mode' to change this variable.") Toggle display of ruler in header line (Ruler mode). This is a minor mode. If called interactively, toggle the `Ruler -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. +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. +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 `ruler-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -29271,20 +30019,6 @@ or call the function `savehist-mode'.") (autoload 'savehist-mode "savehist" "\ Toggle saving of minibuffer history (Savehist mode). -This is a minor mode. If called interactively, toggle the `Savehist -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 \\='savehist-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - When Savehist mode is enabled, minibuffer history is saved to `savehist-file' periodically and when exiting Emacs. When Savehist mode is enabled for the first time in an Emacs session, @@ -29311,6 +30045,20 @@ This mode should normally be turned on from your Emacs init file. Calling it at any other time replaces your current minibuffer histories, which is probably undesirable. +This is a global minor mode. If called interactively, toggle the +`Savehist 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 \\='savehist-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 "savehist" '("savehist-")) @@ -29332,49 +30080,52 @@ or call the function `save-place-mode'.") (autoload 'save-place-mode "saveplace" "\ Non-nil means automatically save place in each file. + This means when you visit a file, point goes to the last place where it was when you previously visited the same file. -This is a minor mode. If called interactively, toggle the `Save-Place -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. +This is a global minor mode. If called interactively, toggle the +`Save-Place 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. +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 \\='save-place-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) (autoload 'save-place-local-mode "saveplace" "\ Toggle whether to save your place in this file between sessions. + If this mode is enabled, point is recorded when you kill the buffer or exit Emacs. Visiting this file again will go to that position, even in a later Emacs session. +To save places automatically in all files, put this in your init +file: + +\(save-place-mode 1) + This is a minor mode. If called interactively, toggle the -`Save-Place-Local mode' mode. If the prefix argument is positive, -enable the mode, and if it is zero or negative, disable the mode. +`Save-Place-Local 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. +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 `save-place-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -To save places automatically in all files, put this in your init -file: - -\(save-place-mode 1) +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -29454,22 +30205,22 @@ or call the function `scroll-all-mode'.") (autoload 'scroll-all-mode "scroll-all" "\ Toggle shared scrolling in same-frame windows (Scroll-All mode). -This is a minor mode. If called interactively, toggle the `Scroll-All -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. +When Scroll-All mode is enabled, scrolling commands invoked in +one window apply to all visible windows in the same frame. + +This is a global minor mode. If called interactively, toggle the +`Scroll-All 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. +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 \\='scroll-all-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -When Scroll-All mode is enabled, scrolling commands invoked in -one window apply to all visible windows in the same frame. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -29490,28 +30241,28 @@ one window apply to all visible windows in the same frame. (autoload 'scroll-lock-mode "scroll-lock" "\ Buffer-local minor mode for pager-like scrolling. -This is a minor mode. If called interactively, toggle the -`Scroll-Lock 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 `scroll-lock-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - When enabled, keys that normally move point by line or paragraph will scroll the buffer by the respective amount of lines instead and point will be kept vertically fixed relative to window boundaries during scrolling. -Note that the default key binding to Scroll_Lock will not work on +Note that the default key binding to `scroll' will not work on MS-Windows systems if `w32-scroll-lock-modifier' is non-nil. +This is a minor mode. If called interactively, toggle the +`Scroll-Lock 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 `scroll-lock-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 "scroll-lock" '("scroll-lock-")) @@ -29569,20 +30320,6 @@ or call the function `semantic-mode'.") (autoload 'semantic-mode "semantic" "\ Toggle parser features (Semantic mode). -This is a minor mode. If called interactively, toggle the `Semantic -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 \\='semantic-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - In Semantic mode, Emacs parses the buffers you visit for their semantic content. This information is used by a variety of auxiliary minor modes, listed in `semantic-default-submodes'; @@ -29591,6 +30328,20 @@ Semantic mode. \\{semantic-mode-map} +This is a global minor mode. If called interactively, toggle the +`Semantic 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 \\='semantic-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 "semantic" '("bovinate" "semantic-")) @@ -29630,7 +30381,7 @@ Major mode for editing Bovine grammars. \(fn)" t nil) -(register-definition-prefixes "semantic/bovine/grammar" '("bovine-")) +(register-definition-prefixes "semantic/bovine/grammar" '("bovine-" "semantic-grammar-")) ;;;*** @@ -29771,7 +30522,7 @@ Major mode for editing Wisent grammars. \(fn)" t nil) -(register-definition-prefixes "semantic/wisent/grammar" '("wisent-")) +(register-definition-prefixes "semantic/wisent/grammar" '("semantic-grammar-" "wisent-")) ;;;*** @@ -30247,23 +30998,23 @@ or call the function `server-mode'.") (autoload 'server-mode "server" "\ Toggle Server mode. -This is a minor mode. If called interactively, toggle the `Server -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. +Server mode runs a process that accepts commands from the +`emacsclient' program. See Info node `Emacs server' and +`server-start' for details. -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. +This is a global minor mode. If called interactively, toggle the +`Server 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 \\='server-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -Server mode runs a process that accepts commands from the -`emacsclient' program. See Info node `Emacs server' and -`server-start' for details. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -30276,6 +31027,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-")) ;;;*** @@ -30573,6 +31347,8 @@ If BUFFER exists and shell process is running, just switch to BUFFER. Program used comes from variable `explicit-shell-file-name', or (if that is nil) from the ESHELL environment variable, or (if that is nil) from `shell-file-name'. +Non-interactively, it can also be specified via the FILE-NAME arg. + If a file `~/.emacs_SHELLNAME' exists, or `~/.emacs.d/init_SHELLNAME.sh', it is given as initial input (but this may be lost, due to a timing error, if the shell discards input when it starts up). @@ -30596,7 +31372,7 @@ Make the shell buffer the current buffer, and return it. \(Type \\[describe-mode] in the shell buffer for a list of commands.) -\(fn &optional BUFFER)" t nil) +\(fn &optional BUFFER FILE-NAME)" t nil) (register-definition-prefixes "shell" '("dirs" "explicit-" "shell-")) @@ -30609,10 +31385,13 @@ Make the shell buffer the current buffer, and return it. (autoload 'shortdoc-display-group "shortdoc" "\ Pop to a buffer with short documentation summary for functions in GROUP. If FUNCTION is non-nil, place point on the entry for FUNCTION (if any). +If SAME-WINDOW, don't pop to a new window. + +\(fn GROUP &optional FUNCTION SAME-WINDOW)" t nil) -\(fn GROUP &optional FUNCTION)" t nil) +(defalias 'shortdoc #'shortdoc-display-group) -(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")) ;;;*** @@ -30752,6 +31531,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'). @@ -30889,21 +31670,21 @@ buffer names. (autoload 'smerge-mode "smerge-mode" "\ Minor mode to simplify editing output from the diff3 program. -This is a minor mode. If called interactively, toggle the `SMerge -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. +\\{smerge-mode-map} -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. +This is a minor mode. If called interactively, toggle the +`SMerge 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 `smerge-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -\\{smerge-mode-map} +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -31025,26 +31806,26 @@ Open the customization group `so-long'." t nil) (autoload 'so-long-minor-mode "so-long" "\ This is the minor mode equivalent of `so-long-mode'. -This is a minor mode. If called interactively, toggle the `So-Long -minor 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 `so-long-minor-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Any active minor modes listed in `so-long-minor-modes' are disabled for the current buffer, and buffer-local values are assigned to variables in accordance with `so-long-variable-overrides'. This minor mode is a standard `so-long-action' option. +This is a minor mode. If called interactively, toggle the +`So-Long minor 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 `so-long-minor-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'so-long-mode "so-long" "\ @@ -31111,20 +31892,6 @@ or call the function `global-so-long-mode'.") (autoload 'global-so-long-mode "so-long" "\ Toggle automated performance mitigations for files with long lines. -This is a minor mode. If called interactively, toggle the `Global -So-Long 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 \\='global-so-long-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Many Emacs modes struggle with buffers which contain excessively long lines, and may consequently cause unacceptable performance issues. @@ -31140,6 +31907,20 @@ Use \\[so-long-commentary] for more information. Use \\[so-long-customize] to open the customization group `so-long' to configure the behaviour. +This is a global minor mode. If called interactively, toggle the +`Global So-Long 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 \\='global-so-long-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 "so-long" '("so-long-" "turn-o")) @@ -31148,7 +31929,7 @@ configure the behaviour. ;;;### (autoloads nil "soap-client" "net/soap-client.el" (0 0 0 0)) ;;; Generated autoloads from net/soap-client.el -(push (purecopy '(soap-client 3 2 0)) package--builtin-versions) +(push (purecopy '(soap-client 3 2 1)) package--builtin-versions) (register-definition-prefixes "soap-client" '("soap-")) @@ -31464,7 +32245,7 @@ installed through `spam-necessary-extra-headers'. \(fn &rest SYMBOLS)" t nil) -(register-definition-prefixes "spam" '("spam-")) +(register-definition-prefixes "spam" '(":keymap" "spam-")) ;;;*** @@ -32060,6 +32841,25 @@ Run vsql as an inferior process. ;;;*** +;;;### (autoloads nil "sqlite" "sqlite.el" (0 0 0 0)) +;;; Generated autoloads from sqlite.el + +(register-definition-prefixes "sqlite" '("with-sqlite-transaction")) + +;;;*** + +;;;### (autoloads nil "sqlite-mode" "sqlite-mode.el" (0 0 0 0)) +;;; Generated autoloads from sqlite-mode.el + +(autoload 'sqlite-mode-open-file "sqlite-mode" "\ +Browse the contents of an sqlite file. + +\(fn FILE)" t nil) + +(register-definition-prefixes "sqlite-mode" '("sqlite-")) + +;;;*** + ;;;### (autoloads nil "srecode" "cedet/srecode.el" (0 0 0 0)) ;;; Generated autoloads from cedet/srecode.el (push (purecopy '(srecode 1 2)) package--builtin-versions) @@ -32155,6 +32955,38 @@ Major-mode for writing SRecode macros. ;;;*** +;;;### (autoloads nil "string-edit" "textmodes/string-edit.el" (0 +;;;;;; 0 0 0)) +;;; Generated autoloads from textmodes/string-edit.el + +(autoload 'string-edit "string-edit" "\ +Switch to a new buffer to edit STRING. +When the user finishes editing (with \\<string-edit-mode-map>\\[string-edit-done]), SUCCESS-CALLBACK +is called with the resulting string. + +If the user aborts (with \\<string-edit-mode-map>\\[string-edit-abort]), ABORT-CALLBACK (if any) is +called with no parameters. + +PROMPT will be inserted at the start of the buffer, but won't be +included in the resulting string. If PROMPT is nil, no help text +will be inserted. + +\(fn PROMPT STRING SUCCESS-CALLBACK &key ABORT-CALLBACK)" nil nil) + +(autoload 'read-string-from-buffer "string-edit" "\ +Switch to a new buffer to edit STRING in a recursive edit. +The user finishes editing with \\<string-edit-mode-map>\\[string-edit-done], or aborts with \\<string-edit-mode-map>\\[string-edit-abort]). + +PROMPT will be inserted at the start of the buffer, but won't be +included in the resulting string. If nil, no prompt will be +inserted in the buffer. + +\(fn PROMPT STRING)" nil nil) + +(register-definition-prefixes "string-edit" '("string-edit-")) + +;;;*** + ;;;### (autoloads nil "strokes" "strokes.el" (0 0 0 0)) ;;; Generated autoloads from strokes.el @@ -32233,20 +33065,6 @@ or call the function `strokes-mode'.") (autoload 'strokes-mode "strokes" "\ Toggle Strokes mode, a global minor mode. -This is a minor mode. If called interactively, toggle the `Strokes -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 \\='strokes-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - \\<strokes-mode-map> Strokes are pictographic mouse gestures which invoke commands. Strokes are invoked with \\[strokes-do-stroke]. You can define @@ -32260,6 +33078,20 @@ Encode/decode your strokes with \\[strokes-encode-buffer], \\{strokes-mode-map} +This is a global minor mode. If called interactively, toggle the +`Strokes 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 \\='strokes-mode)'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'strokes-decode-buffer "strokes" "\ @@ -32297,38 +33129,6 @@ Studlify-case the current buffer." t nil) ;;;### (autoloads nil "subr-x" "emacs-lisp/subr-x.el" (0 0 0 0)) ;;; Generated autoloads from emacs-lisp/subr-x.el -(autoload 'if-let "subr-x" "\ -Bind variables according to SPEC and evaluate THEN or ELSE. -Evaluate each binding in turn, as in `let*', stopping if a -binding value is nil. If all are non-nil return the value of -THEN, otherwise the last form in ELSE. - -Each element of SPEC is a list (SYMBOL VALUEFORM) that binds -SYMBOL to the value of VALUEFORM. An element can additionally be -of the form (VALUEFORM), which is evaluated and checked for nil; -i.e. SYMBOL can be omitted if only the test result is of -interest. It can also be of the form SYMBOL, then the binding of -SYMBOL is checked for nil. - -As a special case, interprets a SPEC of the form (SYMBOL SOMETHING) -like ((SYMBOL SOMETHING)). This exists for backward compatibility -with an old syntax that accepted only one binding. - -\(fn SPEC THEN &rest ELSE)" nil t) - -(function-put 'if-let 'lisp-indent-function '2) - -(autoload 'when-let "subr-x" "\ -Bind variables according to SPEC and conditionally evaluate BODY. -Evaluate each binding in turn, stopping if a binding value is nil. -If all are non-nil, return the value of the last form in BODY. - -The variable list SPEC is the same as in `if-let'. - -\(fn SPEC &rest BODY)" nil t) - -(function-put 'when-let 'lisp-indent-function '1) - (autoload 'string-truncate-left "subr-x" "\ Truncate STRING to LENGTH, replacing initial surplus with \"...\". @@ -32342,13 +33142,33 @@ removed. \(fn STRING)" nil nil) -(autoload 'string-lines "subr-x" "\ -Split STRING into a list of lines. -If OMIT-NULLS, empty lines will be removed from the results. +(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. -\(fn STRING &optional OMIT-NULLS)" nil nil) +If OBJECT is non-nil, it should be a string or a buffer. If nil, +this defaults to the current buffer. -(register-definition-prefixes "subr-x" '("and-let*" "hash-table-" "if-let*" "internal--" "named-let" "replace-region-contents" "string-" "thread-" "when-let*")) +\(fn START END PROP VALUE &optional OBJECT)" nil nil) + +(autoload 'read-process-name "subr-x" "\ +Query the user for a process and return the process object. + +\(fn PROMPT)" nil nil) + +(register-definition-prefixes "subr-x" '("hash-table-" "internal--thread-argument" "named-let" "replace-region-contents" "string-" "thread-" "with-")) ;;;*** @@ -32360,20 +33180,6 @@ If OMIT-NULLS, empty lines will be removed from the results. (autoload 'subword-mode "subword" "\ Toggle subword movement and editing (Subword mode). -This is a minor mode. If called interactively, toggle the `Subword -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 `subword-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Subword mode is a buffer-local minor mode. Enabling it changes the definition of a word so that word-based commands stop inside symbols with mixed uppercase and lowercase letters, @@ -32392,6 +33198,20 @@ called a `subword'. Here are some examples: This mode changes the definition of a word so that word commands treat nomenclature boundaries as word boundaries. +This is a minor mode. If called interactively, toggle the +`Subword 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 `subword-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (put 'global-subword-mode 'globalized-minor-mode t) @@ -32425,20 +33245,6 @@ See `subword-mode' for more information on Subword mode. (autoload 'superword-mode "subword" "\ Toggle superword movement and editing (Superword mode). -This is a minor mode. If called interactively, toggle the `Superword -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 `superword-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Superword mode is a buffer-local minor mode. Enabling it changes the definition of words such that characters which have symbol syntax are treated as parts of words: e.g., in `superword-mode', @@ -32446,6 +33252,20 @@ syntax are treated as parts of words: e.g., in `superword-mode', \\{superword-mode-map} +This is a minor mode. If called interactively, toggle the +`Superword 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 `superword-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (put 'global-superword-mode 'globalized-minor-mode t) @@ -32536,20 +33356,6 @@ or call the function `gpm-mouse-mode'.") (autoload 'gpm-mouse-mode "t-mouse" "\ Toggle mouse support in GNU/Linux consoles (GPM Mouse mode). -This is a minor mode. If called interactively, toggle the `Gpm-Mouse -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 \\='gpm-mouse-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - This allows the use of the mouse when operating on a GNU/Linux console, in the same way as you can use the mouse under X11. It relies on the `gpm' daemon being activated. @@ -32558,6 +33364,20 @@ Note that when `gpm-mouse-mode' is enabled, you cannot use the mouse to transfer text between Emacs and other programs which use GPM. This is due to limitations in GPM and the Linux kernel. +This is a global minor mode. If called interactively, toggle the +`Gpm-Mouse 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 \\='gpm-mouse-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 "t-mouse" '("gpm-mouse-")) @@ -32570,19 +33390,19 @@ GPM. This is due to limitations in GPM and the Linux kernel. (autoload 'tab-line-mode "tab-line" "\ Toggle display of tab line in the windows displaying the current buffer. -This is a minor mode. If called interactively, toggle the `Tab-Line -mode' mode. If the prefix argument is positive, enable the mode, and -if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the +`Tab-Line 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. +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 `tab-line-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -32654,6 +33474,34 @@ The variable `tab-width' controls the spacing of tab stops. ;;;### (autoloads nil "table" "textmodes/table.el" (0 0 0 0)) ;;; Generated autoloads from textmodes/table.el +(autoload 'table-fixed-width-mode "table" "\ +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. + +This is a minor mode. If called interactively, toggle the +`Table-Fixed-Width 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 `table-fixed-width-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + +\(fn &optional ARG)" t nil) + (autoload 'table-insert "table" "\ Insert an editable text table. Insert a table of specified number of COLUMNS and ROWS. Optional @@ -32982,32 +33830,6 @@ or `top', `middle', `bottom' or `none' for vertical. \(fn JUSTIFY)" t nil) -(autoload 'table-fixed-width-mode "table" "\ -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. - -This is a minor mode. If called interactively, toggle the -`Table-Fixed-Width 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 `table-fixed-width-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - -\(fn &optional ARG)" t nil) - (autoload 'table-query-dimension "table" "\ 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 @@ -33896,6 +34718,51 @@ value of `texinfo-mode-hook'. ;;;*** +;;;### (autoloads nil "textsec" "international/textsec.el" (0 0 0 +;;;;;; 0)) +;;; Generated autoloads from international/textsec.el + +(register-definition-prefixes "textsec" '("textsec-")) + +;;;*** + +;;;### (autoloads nil "textsec-check" "international/textsec-check.el" +;;;;;; (0 0 0 0)) +;;; Generated autoloads from international/textsec-check.el + +(autoload 'textsec-suspicious-p "textsec-check" "\ +Say whether OBJECT is suspicious for use as TYPE. +If OBJECT is suspicious, return a string explaining the reason +for considering it suspicious, otherwise return nil. + +Available values of TYPE and corresponding OBJECTs are: + + `url' -- a URL; OBJECT should be a URL string. + + `link' -- an HTML link; OBJECT should be a cons cell + of the form (URL . LINK-TEXT). + + `domain' -- a Web domain; OBJECT should be a string. + + `local-address' -- the local part of an email address; OBJECT + should be a string. + `name' -- the \"display name\" part of an email address; + OBJECT should be a string. + +`email-address' -- a full email address; OBJECT should be a string. + + `email-address-header' -- a raw email address header in RFC 2822 format; + OBJECT should be a string. + +If the user option `textsec-check' is nil, these checks are +disabled, and this function always returns nil. + +\(fn OBJECT TYPE)" nil nil) + +(register-definition-prefixes "textsec-check" '("textsec-check")) + +;;;*** + ;;;### (autoloads nil "thai-util" "language/thai-util.el" (0 0 0 ;;;;;; 0)) ;;; Generated autoloads from language/thai-util.el @@ -33938,7 +34805,7 @@ Compose Thai characters in the current buffer." t nil) (autoload 'forward-thing "thingatpt" "\ Move forward to the end of the Nth next THING. THING should be a symbol specifying a type of syntactic entity. -Possibilities include `symbol', `list', `sexp', `defun', +Possibilities include `symbol', `list', `sexp', `defun', `number', `filename', `url', `email', `uuid', `word', `sentence', `whitespace', `line', and `page'. @@ -33947,7 +34814,7 @@ Possibilities include `symbol', `list', `sexp', `defun', (autoload 'bounds-of-thing-at-point "thingatpt" "\ Determine the start and end buffer locations for the THING at point. THING should be a symbol specifying a type of syntactic entity. -Possibilities include `symbol', `list', `sexp', `defun', +Possibilities include `symbol', `list', `sexp', `defun', `number', `filename', `url', `email', `uuid', `word', `sentence', `whitespace', `line', and `page'. @@ -34191,20 +35058,6 @@ This function is meant to be used as a `post-self-insert-hook'." t nil) (autoload 'tildify-mode "tildify" "\ Adds electric behavior to space character. -This is a minor mode. If called interactively, toggle the `Tildify -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 `tildify-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - When space is inserted into a buffer in a position where hard space is required instead (determined by `tildify-space-pattern' and `tildify-space-predicates'), that space character is replaced by a hard space specified by @@ -34214,6 +35067,20 @@ When `tildify-mode' is enabled, if `tildify-string-alist' specifies a hard space representation for current major mode, the `tildify-space-string' buffer-local variable will be set to the representation. +This is a minor mode. If called interactively, toggle the +`Tildify 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 `tildify-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 "tildify" '("tildify-")) @@ -34249,26 +35116,26 @@ or call the function `display-time-mode'.") (autoload 'display-time-mode "time" "\ Toggle display of time, load level, and mail flag in mode lines. -This is a minor mode. If called interactively, toggle the -`Display-Time 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 \\='display-time-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - When Display Time mode is enabled, it updates every minute (you can control the number of seconds between updates by customizing `display-time-interval'). If `display-time-day-and-date' is non-nil, the current day and date are displayed as well. This runs the normal hook `display-time-hook' after each update. +This is a global minor mode. If called interactively, toggle the +`Display-Time 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 \\='display-time-mode)'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (define-obsolete-function-alias 'display-time-world #'world-clock "28.1") @@ -34388,6 +35255,10 @@ The \"%z\" specifier does not print anything. When it is used, specifiers must be given in order of decreasing size. To the left of \"%z\", nothing is output until the first non-zero unit is encountered. +The \"%x\" specifier does not print anything. When it is used, +specifiers must be given in order of decreasing size. To the +right of \"%x\", trailing zero units are not output. + \(fn STRING SECONDS)" nil nil) (autoload 'seconds-to-string "time-date" "\ @@ -34908,7 +35779,7 @@ like \"/sys\" or \"/C:\".") Load Tramp file name handler, and perform OPERATION." (tramp-unload-file-name-handlers) (when tramp-mode (let ((default-directory temporary-file-directory)) (when (bound-and-true-p tramp-archive-autoload) (load "tramp-archive" 'noerror 'nomessage)) (load "tramp" 'noerror 'nomessage))) (apply operation args)) (defun tramp-register-autoload-file-name-handlers nil "\ -Add Tramp file name handlers to `file-name-handler-alist' during autoload." (add-to-list 'file-name-handler-alist (cons tramp-autoload-file-name-regexp #'tramp-autoload-file-name-handler)) (put #'tramp-autoload-file-name-handler 'safe-magic t)) +Add Tramp file name handlers to `file-name-handler-alist' during autoload." (unless (rassq #'tramp-file-name-handler file-name-handler-alist) (add-to-list 'file-name-handler-alist (cons tramp-autoload-file-name-regexp #'tramp-autoload-file-name-handler)) (put #'tramp-autoload-file-name-handler 'safe-magic t))) (tramp-register-autoload-file-name-handlers) (defun tramp-unload-file-name-handlers nil "\ @@ -34935,7 +35806,7 @@ Discard Tramp from loading remote files." (interactive) (ignore-errors (unload-f (defvar tramp-archive-enabled (featurep 'dbusbind) "\ Non-nil when file archive support is available.") -(defconst tramp-archive-suffixes '("7z" "apk" "ar" "cab" "CAB" "cpio" "deb" "depot" "exe" "iso" "jar" "lzh" "LZH" "msu" "MSU" "mtree" "odb" "odf" "odg" "odp" "ods" "odt" "pax" "rar" "rpm" "shar" "tar" "tbz" "tgz" "tlz" "txz" "tzst" "warc" "xar" "xpi" "xps" "zip" "ZIP") "\ +(defconst tramp-archive-suffixes '("7z" "apk" "ar" "cab" "CAB" "cpio" "crate" "deb" "depot" "epub" "exe" "iso" "jar" "lzh" "LZH" "msu" "MSU" "mtree" "odb" "odf" "odg" "odp" "ods" "odt" "pax" "rar" "rpm" "shar" "tar" "tbz" "tgz" "tlz" "txz" "tzst" "warc" "xar" "xpi" "xps" "zip" "ZIP") "\ List of suffixes which indicate a file archive. It must be supported by libarchive(3).") @@ -34947,10 +35818,10 @@ It must be supported by libarchive(3).") Regular expression matching archive file names." '(concat "\\`" "\\(" ".+" "\\." (regexp-opt tramp-archive-suffixes) "\\(?:" "\\." (regexp-opt tramp-archive-compression-suffixes) "\\)*" "\\)" "\\(" "/" ".*" "\\)" "\\'")) (defun tramp-archive-autoload-file-name-handler (operation &rest args) "\ -Load Tramp archive file name handler, and perform OPERATION." (defvar tramp-archive-autoload) (when tramp-archive-enabled (let ((default-directory temporary-file-directory) (tramp-archive-autoload t)) (apply #'tramp-autoload-file-name-handler operation args)))) +Load Tramp archive file name handler, and perform OPERATION." (defvar tramp-archive-autoload) (let ((default-directory temporary-file-directory) (tramp-archive-autoload tramp-archive-enabled)) (apply #'tramp-autoload-file-name-handler operation args))) (defun tramp-register-archive-file-name-handler nil "\ -Add archive file name handler to `file-name-handler-alist'." (when tramp-archive-enabled (add-to-list 'file-name-handler-alist (cons (tramp-archive-autoload-file-name-regexp) #'tramp-archive-autoload-file-name-handler)) (put #'tramp-archive-autoload-file-name-handler 'safe-magic t))) +Add archive file name handler to `file-name-handler-alist'." (when (and tramp-archive-enabled (not (rassq #'tramp-archive-file-name-handler file-name-handler-alist))) (add-to-list 'file-name-handler-alist (cons (tramp-archive-autoload-file-name-regexp) #'tramp-archive-autoload-file-name-handler)) (put #'tramp-archive-autoload-file-name-handler 'safe-magic t))) (add-hook 'after-init-hook #'tramp-register-archive-file-name-handler) @@ -35064,7 +35935,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 28 1)) package--builtin-versions) +(push (purecopy '(tramp 2 6 0 -1)) package--builtin-versions) (register-definition-prefixes "trampver" '("tramp-")) @@ -35241,21 +36112,8 @@ or call the function `type-break-mode'.") (autoload 'type-break-mode "type-break" "\ Enable or disable typing-break mode. -This is a minor mode, but it is global to all buffers by default. -This is a minor mode. If called interactively, toggle the `Type-Break -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 \\='type-break-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. +This is a minor mode, but it is global to all buffers by default. When this mode is enabled, the user is encouraged to take typing breaks at appropriate intervals; either after a specified amount of time or when the @@ -35324,6 +36182,20 @@ across Emacs sessions. This provides recovery of the break status between sessions and after a crash. Manual changes to the file may result in problems. +This is a global minor mode. If called interactively, toggle the +`Type-Break 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 \\='type-break-mode)'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'type-break "type-break" "\ @@ -35387,65 +36259,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")) @@ -35718,7 +36550,7 @@ Handle file: and ftp: URLs. \(fn URL CALLBACK CBARGS)" nil nil) -(register-definition-prefixes "url-file" '("url-file-")) +(register-definition-prefixes "url-file" '("url-")) ;;;*** @@ -35775,29 +36607,30 @@ or call the function `url-handler-mode'.") (autoload 'url-handler-mode "url-handlers" "\ Handle URLs as if they were file names throughout Emacs. + After switching on this minor mode, Emacs file primitives handle URLs. For instance: -This is a minor mode. If called interactively, toggle the -`Url-Handler 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 \\='url-handler-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - (file-exists-p \"https://www.gnu.org/\") => t and `C-x C-f https://www.gnu.org/ RET' will give you the HTML at that URL in a buffer. +This is a global minor mode. If called interactively, toggle the +`Url-Handler 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 \\='url-handler-mode)'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'url-file-handler "url-handlers" "\ @@ -36309,7 +37142,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 +37272,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" "\ @@ -36922,7 +37759,7 @@ case, and the process object in the asynchronous case. (load "vc-git" nil t) (vc-git-registered file)))) -(register-definition-prefixes "vc-git" '("vc-git-")) +(register-definition-prefixes "vc-git" '("vc-")) ;;;*** @@ -37093,7 +37930,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. @@ -37970,20 +38807,6 @@ own View-like bindings. (autoload 'view-mode "view" "\ Toggle View mode, a minor mode for viewing text but not editing it. -This is a minor mode. If called interactively, toggle the `View 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 `view-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - When View mode is enabled, commands that do not change the buffer contents are available as usual. Kill commands save text but do not delete it from the buffer. Most other commands beep and @@ -38061,6 +38884,20 @@ then \\[View-leave], \\[View-quit] and \\[View-kill-and-leave] will return to th Entry to view-mode runs the normal hook `view-mode-hook'. +This is a minor mode. If called interactively, toggle the `View +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 `view-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'view-return-to-alist-update "view" "\ @@ -38171,17 +39008,10 @@ Turn on Viper emulation of Vi in Emacs. See Info node `(viper)Top'." t nil) ;;;*** -;;;### (autoloads nil "vt-control" "vt-control.el" (0 0 0 0)) -;;; Generated autoloads from vt-control.el +;;;### (autoloads nil "vtable" "emacs-lisp/vtable.el" (0 0 0 0)) +;;; Generated autoloads from emacs-lisp/vtable.el -(register-definition-prefixes "vt-control" '("vt-")) - -;;;*** - -;;;### (autoloads nil "vt100-led" "vt100-led.el" (0 0 0 0)) -;;; Generated autoloads from vt100-led.el - -(register-definition-prefixes "vt100-led" '("led-")) +(register-definition-prefixes "vtable" '("vtable")) ;;;*** @@ -38352,23 +39182,23 @@ or call the function `which-function-mode'.") (autoload 'which-function-mode "which-func" "\ Toggle mode line display of current function (Which Function mode). -This is a minor mode. If called interactively, toggle the +Which Function mode is a global minor mode. When enabled, the +current function name is continuously displayed in the mode line, +in certain major modes. + +This is a global minor mode. If called interactively, toggle the `Which-Function 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. +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 \\='which-function-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -Which Function mode is a global minor mode. When enabled, the -current function name is continuously displayed in the mode line, -in certain major modes. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -38383,44 +39213,30 @@ in certain major modes. (autoload 'whitespace-mode "whitespace" "\ Toggle whitespace visualization (Whitespace mode). -This is a minor mode. If called interactively, toggle the `Whitespace -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 `whitespace-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - See also `whitespace-style', `whitespace-newline' and `whitespace-display-mappings'. This mode uses a number of faces to visualize the whitespace; see the customization group `whitespace' for details. -\(fn &optional ARG)" t nil) - -(autoload 'whitespace-newline-mode "whitespace" "\ -Toggle newline visualization (Whitespace Newline mode). - This is a minor mode. If called interactively, toggle the -`Whitespace-Newline mode' mode. If the prefix argument is positive, +`Whitespace 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. +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 `whitespace-newline-mode'. +evaluate `whitespace-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. -The mode's hook is called both when the mode is enabled and when it is -disabled. +\(fn &optional ARG)" t nil) + +(autoload 'whitespace-newline-mode "whitespace" "\ +Toggle newline visualization (Whitespace Newline mode). Use `whitespace-newline-mode' only for NEWLINE visualization exclusively. For other visualizations, including NEWLINE @@ -38429,6 +39245,21 @@ use `whitespace-mode'. See also `whitespace-newline' and `whitespace-display-mappings'. +This is a minor mode. If called interactively, toggle the +`Whitespace-Newline 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 `whitespace-newline-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (defvar global-whitespace-mode nil "\ @@ -38444,22 +39275,23 @@ or call the function `global-whitespace-mode'.") (autoload 'global-whitespace-mode "whitespace" "\ Toggle whitespace visualization globally (Global Whitespace mode). -This is a minor mode. If called interactively, toggle the `Global -Whitespace mode' mode. If the prefix argument is positive, enable the -mode, and if it is zero or negative, disable the mode. +See also `whitespace-style', `whitespace-newline' and +`whitespace-display-mappings'. -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. +This is a global minor mode. If called interactively, toggle the +`Global Whitespace 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 \\='global-whitespace-mode)'. -The mode's hook is called both when the mode is enabled and when it is -disabled. - -See also `whitespace-style', `whitespace-newline' and -`whitespace-display-mappings'. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -38476,20 +39308,6 @@ or call the function `global-whitespace-newline-mode'.") (autoload 'global-whitespace-newline-mode "whitespace" "\ Toggle global newline visualization (Global Whitespace Newline mode). -This is a minor mode. If called interactively, toggle the `Global -Whitespace-Newline 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 \\='global-whitespace-newline-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Use `global-whitespace-newline-mode' only for NEWLINE visualization exclusively. For other visualizations, including NEWLINE visualization together with (HARD) SPACEs and/or TABs, @@ -38497,6 +39315,21 @@ please use `global-whitespace-mode'. See also `whitespace-newline' and `whitespace-display-mappings'. +This is a global minor mode. If called interactively, toggle the +`Global Whitespace-Newline 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 \\='global-whitespace-newline-mode)'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + \(fn &optional ARG)" t nil) (autoload 'whitespace-toggle-options "whitespace" "\ @@ -38809,19 +39642,19 @@ Show widget browser for WIDGET in other window. (autoload 'widget-minor-mode "wid-browse" "\ Minor mode for traversing widgets. -This is a minor mode. If called interactively, toggle the `Widget -minor mode' mode. If the prefix argument is positive, enable the -mode, and if it is zero or negative, disable the mode. +This is a minor mode. If called interactively, toggle the +`Widget minor 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. +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 `widget-minor-mode'. -The mode's hook is called both when the mode is enabled and when it is -disabled. +The mode's hook is called both when the mode is enabled and when +it is disabled. \(fn &optional ARG)" t nil) @@ -38918,6 +39751,32 @@ unless `windmove-create-window' is non-nil and a new window is created. \(fn &optional ARG)" t nil) +(defvar windmove-mode t "\ +Non-nil if Windmove mode is enabled. +See the `windmove-mode' command +for a description of this minor mode.") + +(custom-autoload 'windmove-mode "windmove" nil) + +(autoload 'windmove-mode "windmove" "\ +Global minor mode for default windmove commands. + +This is a global minor mode. If called interactively, toggle the +`Windmove 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 \\='windmove-mode)'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + +\(fn &optional ARG)" t nil) + (autoload 'windmove-default-keybindings "windmove" "\ Set up keybindings for `windmove'. Keybindings are of the form MODIFIERS-{left,right,up,down}, @@ -39018,7 +39877,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) @@ -39066,20 +39925,6 @@ or call the function `winner-mode'.") (autoload 'winner-mode "winner" "\ Toggle Winner mode on or off. -This is a minor mode. If called interactively, toggle the `Winner -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 \\='winner-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Winner mode is a global minor mode that records the changes in the window configuration (i.e. how the frames are partitioned into windows) so that the changes can be \"undone\" using the @@ -39087,6 +39932,20 @@ command `winner-undo'. By default this one is bound to the key sequence `C-c <left>'. If you change your mind (while undoing), you can press `C-c <right>' (calling `winner-redo'). +This is a global minor mode. If called interactively, toggle the +`Winner 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 \\='winner-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 "winner" '("winner-")) @@ -39141,6 +40000,65 @@ Default bookmark handler for Woman buffers. ;;;*** +;;;### (autoloads nil "word-wrap-mode" "textmodes/word-wrap-mode.el" +;;;;;; (0 0 0 0)) +;;; Generated autoloads from textmodes/word-wrap-mode.el + +(autoload 'word-wrap-whitespace-mode "word-wrap-mode" "\ +Allow `word-wrap' to fold on all breaking whitespace characters. + +The characters to break on are defined by `word-wrap-whitespace-characters'. + +This is a minor mode. If called interactively, toggle the +`Word-Wrap-Whitespace 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 `word-wrap-whitespace-mode'. + +The mode's hook is called both when the mode is enabled and when +it is disabled. + +\(fn &optional ARG)" t nil) + +(put 'global-word-wrap-whitespace-mode 'globalized-minor-mode t) + +(defvar global-word-wrap-whitespace-mode nil "\ +Non-nil if Global Word-Wrap-Whitespace mode is enabled. +See the `global-word-wrap-whitespace-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 `global-word-wrap-whitespace-mode'.") + +(custom-autoload 'global-word-wrap-whitespace-mode "word-wrap-mode" nil) + +(autoload 'global-word-wrap-whitespace-mode "word-wrap-mode" "\ +Toggle Word-Wrap-Whitespace mode in all buffers. +With prefix ARG, enable Global Word-Wrap-Whitespace mode if ARG is +positive; otherwise, disable it. + +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. + +Word-Wrap-Whitespace mode is enabled in all buffers where +`word-wrap-whitespace-mode' would do it. + +See `word-wrap-whitespace-mode' for more information on +Word-Wrap-Whitespace mode. + +\(fn &optional ARG)" t nil) + +(register-definition-prefixes "word-wrap-mode" '("word-wrap-whitespace-characters")) + +;;;*** + ;;;### (autoloads nil "x-dnd" "x-dnd.el" (0 0 0 0)) ;;; Generated autoloads from x-dnd.el @@ -39241,15 +40159,31 @@ 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 4 1)) 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-show-xrefs "xref" "\ +Display some Xref values produced by FETCHER using DISPLAY-ACTION. +The meanings of both arguments are the same as documented in +`xref-show-xrefs-function'. + +\(fn FETCHER DISPLAY-ACTION)" nil nil) (autoload 'xref-find-definitions "xref" "\ Find the definition of the identifier at point. @@ -39261,7 +40195,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 +40239,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) @@ -39374,20 +40309,6 @@ or call the function `xterm-mouse-mode'.") (autoload 'xterm-mouse-mode "xt-mouse" "\ Toggle XTerm mouse mode. -This is a minor mode. If called interactively, toggle the -`Xterm-Mouse 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 \\='xterm-mouse-mode)'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - Turn it on to use Emacs mouse commands, and off to use xterm mouse commands. This works in terminal emulators compatible with xterm. It only works for simple uses of the mouse. Basically, only non-modified @@ -39395,6 +40316,20 @@ single clicks are supported. When turned on, the normal xterm mouse functionality for such clicks is still available by holding down the SHIFT key while pressing the mouse button. +This is a global minor mode. If called interactively, toggle the +`Xterm-Mouse 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 \\='xterm-mouse-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 "xt-mouse" '("turn-o" "xt-mouse-epoch" "xterm-mouse-")) @@ -39411,10 +40346,44 @@ Interactively, URL defaults to the string looking like a url around point. \(fn URL &optional NEW-SESSION)" t nil) +(autoload 'xwidget-webkit-bookmark-jump-handler "xwidget" "\ +Jump to the web page bookmarked by the bookmark record BOOKMARK. +If `xwidget-webkit-bookmark-jump-new-session' is non-nil, create +a new xwidget-webkit session, otherwise use an existing session. + +\(fn BOOKMARK)" nil nil) + (register-definition-prefixes "xwidget" '("xwidget-")) ;;;*** +;;;### (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 +40418,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,16 +40453,16 @@ 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/cl-seq.el" "emacs-lisp/debug-early.el" "emacs-lisp/easymenu.el" ;;;;;; "emacs-lisp/eieio-custom.el" "emacs-lisp/eieio-opt.el" "emacs-lisp/float-sup.el" ;;;;;; "emacs-lisp/lisp-mode.el" "emacs-lisp/lisp.el" "emacs-lisp/macroexp.el" -;;;;;; "emacs-lisp/map-ynp.el" "emacs-lisp/nadvice.el" "emacs-lisp/shorthands.el" -;;;;;; "emacs-lisp/syntax.el" "emacs-lisp/timer.el" "env.el" "epa-hook.el" -;;;;;; "erc/erc-autoaway.el" "erc/erc-button.el" "erc/erc-capab.el" -;;;;;; "erc/erc-compat.el" "erc/erc-dcc.el" "erc/erc-desktop-notifications.el" +;;;;;; "emacs-lisp/map-ynp.el" "emacs-lisp/nadvice.el" "emacs-lisp/oclosure.el" +;;;;;; "emacs-lisp/shorthands.el" "emacs-lisp/syntax.el" "emacs-lisp/timer.el" +;;;;;; "env.el" "epa-hook.el" "erc/erc-autoaway.el" "erc/erc-button.el" +;;;;;; "erc/erc-capab.el" "erc/erc-compat.el" "erc/erc-dcc.el" "erc/erc-desktop-notifications.el" ;;;;;; "erc/erc-ezbounce.el" "erc/erc-fill.el" "erc/erc-identd.el" ;;;;;; "erc/erc-imenu.el" "erc/erc-join.el" "erc/erc-list.el" "erc/erc-log.el" ;;;;;; "erc/erc-match.el" "erc/erc-menu.el" "erc/erc-netsplit.el" @@ -39505,73 +40472,76 @@ Zone out, completely." t nil) ;;;;;; "erc/erc-stamp.el" "erc/erc-status-sidebar.el" "erc/erc-track.el" ;;;;;; "erc/erc-truncate.el" "erc/erc-xdcc.el" "eshell/em-alias.el" ;;;;;; "eshell/em-banner.el" "eshell/em-basic.el" "eshell/em-cmpl.el" -;;;;;; "eshell/em-dirs.el" "eshell/em-glob.el" "eshell/em-hist.el" -;;;;;; "eshell/em-ls.el" "eshell/em-pred.el" "eshell/em-prompt.el" -;;;;;; "eshell/em-rebind.el" "eshell/em-script.el" "eshell/em-smart.el" -;;;;;; "eshell/em-term.el" "eshell/em-tramp.el" "eshell/em-unix.el" -;;;;;; "eshell/em-xtra.el" "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-dirs.el" "eshell/em-elecslash.el" "eshell/em-glob.el" +;;;;;; "eshell/em-hist.el" "eshell/em-ls.el" "eshell/em-pred.el" +;;;;;; "eshell/em-prompt.el" "eshell/em-rebind.el" "eshell/em-script.el" +;;;;;; "eshell/em-smart.el" "eshell/em-term.el" "eshell/em-tramp.el" +;;;;;; "eshell/em-unix.el" "eshell/em-xtra.el" "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/emoji-labels.el" "international/emoji-zwj.el" +;;;;;; "international/eucjp-ms.el" "international/idna-mapping.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-confusable.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-scripts.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" +;;;;;; "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" +;;;;;; "language/indian.el" "language/indonesian.el" "language/japanese.el" +;;;;;; "language/khmer.el" "language/korean.el" "language/lao.el" +;;;;;; "language/misc-lang.el" "language/philippine.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/emoji.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/hanja3.el" "leim/quail/hebrew.el" "leim/quail/indonesian.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/philippine.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" ;;;;;; "leim/quail/tamil-dvorak.el" "leim/quail/tsang-b5.el" "leim/quail/tsang-cns.el" ;;;;;; "leim/quail/vntelex.el" "leim/quail/vnvni.el" "leim/quail/welsh.el" -;;;;;; "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" -;;;;;; "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" -;;;;;; "org/ox-html.el" "org/ox-icalendar.el" "org/ox-latex.el" -;;;;;; "org/ox-md.el" "org/ox-odt.el" "org/ox-org.el" "org/ox-publish.el" -;;;;;; "org/ox-texinfo.el" "org/ox.el" "paren.el" "progmodes/elisp-mode.el" -;;;;;; "progmodes/prog-mode.el" "ps-mule.el" "register.el" "replace.el" -;;;;;; "rfn-eshadow.el" "select.el" "simple.el" "startup.el" "subdirs.el" -;;;;;; "subr.el" "tab-bar.el" "textmodes/fill.el" "textmodes/makeinfo.el" +;;;;;; "loadup.el" "mail/blessmail.el" "mail/undigest.el" "menu-bar.el" +;;;;;; "mh-e/mh-gnus.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" "org/ox-html.el" +;;;;;; "org/ox-icalendar.el" "org/ox-latex.el" "org/ox-md.el" "org/ox-odt.el" +;;;;;; "org/ox-org.el" "org/ox-publish.el" "org/ox-texinfo.el" "org/ox.el" +;;;;;; "paren.el" "progmodes/elisp-mode.el" "progmodes/prog-mode.el" +;;;;;; "ps-mule.el" "register.el" "replace.el" "rfn-eshadow.el" +;;;;;; "select.el" "simple.el" "startup.el" "subdirs.el" "subr.el" +;;;;;; "tab-bar.el" "textmodes/fill.el" "textmodes/makeinfo.el" ;;;;;; "textmodes/page.el" "textmodes/paragraphs.el" "textmodes/reftex-auc.el" ;;;;;; "textmodes/reftex-cite.el" "textmodes/reftex-dcr.el" "textmodes/reftex-global.el" ;;;;;; "textmodes/reftex-index.el" "textmodes/reftex-parse.el" "textmodes/reftex-ref.el" @@ -39587,6 +40557,6 @@ Zone out, completely." t nil) ;; version-control: never ;; no-byte-compile: t ;; no-update-autoloads: t -;; coding: utf-8 +;; coding: utf-8-emacs-unix ;; End: ;;; loaddefs.el ends here diff --git a/lisp/leim/quail/compose.el b/lisp/leim/quail/compose.el index 2aa8ae78fe7..60c73d7dff8 100644 --- a/lisp/leim/quail/compose.el +++ b/lisp/leim/quail/compose.el @@ -464,9 +464,9 @@ Examples: ("2^" ?²) ("^3" ?³) ("3^" ?³) - ("mu" ?µ) - ("/u" ?µ) - ("u/" ?µ) + ("mu" ?μ) + ("/u" ?μ) + ("u/" ?μ) ("^1" ?¹) ("1^" ?¹) ("^_o" ?º) diff --git a/lisp/leim/quail/emoji.el b/lisp/leim/quail/emoji.el new file mode 100644 index 00000000000..f9d3e170be5 --- /dev/null +++ b/lisp/leim/quail/emoji.el @@ -0,0 +1,2003 @@ +;;; emoji.el --- Quail package for emoji character composition -*- lexical-binding: t -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; Author: Juri Linkov <juri@linkov.net> +;; Keywords: multilingual, input method, i18n + +;; 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 input method supports the same key sequences as the names +;; defined by the `C-x 8 e s' completions in emoji.el. Also it adds +;; more emoji that enclosed in double colons. + +;; You can enable this input method transiently with `C-u C-x \ emoji RET'. +;; Then typing `C-x \' will enable this input method temporarily, and +;; after typing a key sequence it will be disabled. So typing +;; e.g. `C-x \ : )' will insert the smiling character, and disable +;; this input method automatically afterwards. + +;;; Code: + +(require 'quail) + +(quail-define-package + "emoji" "UTF-8" "🙂" t + "Emoji input method for inserting emoji characters. +Examples: + slightly smiling face -> 🙂 + :slightly_smiling_face: -> 🙂 + :-) -> 🙂" + '(("\t" . quail-completion)) + t nil nil nil nil nil nil nil nil t) + +(eval-when-compile + (require 'emoji) + (emoji--init) + (defmacro emoji--define-rules () + `(quail-define-rules + ,@(let ((rules nil)) + (maphash (lambda (from to) + (push (list from (if (stringp to) + (vector to) + to)) + rules)) + emoji--all-bases) + (append + rules + '((":hash:" ["#️⃣"]) + (":keycap_star:" ["*️⃣"]) + (":zero:" ["0️⃣"]) + (":one:" ["1️⃣"]) + (":two:" ["2️⃣"]) + (":three:" ["3️⃣"]) + (":four:" ["4️⃣"]) + (":five:" ["5️⃣"]) + (":six:" ["6️⃣"]) + (":seven:" ["7️⃣"]) + (":eight:" ["8️⃣"]) + (":nine:" ["9️⃣"]) + (":copyright:" ["©️"]) + (":registered:" ["®️"]) + (":mahjong:" ["🀄"]) + (":black_joker:" ["🃏"]) + (":a:" ["🅰️"]) + (":b:" ["🅱️"]) + (":o2:" ["🅾️"]) + (":parking:" ["🅿️"]) + (":ab:" ["🆎"]) + (":cl:" ["🆑"]) + (":cool:" ["🆒"]) + (":free:" ["🆓"]) + (":id:" ["🆔"]) + (":new:" ["🆕"]) + (":ng:" ["🆖"]) + (":ok:" ["🆗"]) + (":sos:" ["🆘"]) + (":up:" ["🆙"]) + (":vs:" ["🆚"]) + (":flag-ac:" ["🇦🇨"]) + (":flag-ad:" ["🇦🇩"]) + (":flag-ae:" ["🇦🇪"]) + (":flag-af:" ["🇦🇫"]) + (":flag-ag:" ["🇦🇬"]) + (":flag-ai:" ["🇦🇮"]) + (":flag-al:" ["🇦🇱"]) + (":flag-am:" ["🇦🇲"]) + (":flag-ao:" ["🇦🇴"]) + (":flag-aq:" ["🇦🇶"]) + (":flag-ar:" ["🇦🇷"]) + (":flag-as:" ["🇦🇸"]) + (":flag-at:" ["🇦🇹"]) + (":flag-au:" ["🇦🇺"]) + (":flag-aw:" ["🇦🇼"]) + (":flag-ax:" ["🇦🇽"]) + (":flag-az:" ["🇦🇿"]) + (":flag-ba:" ["🇧🇦"]) + (":flag-bb:" ["🇧🇧"]) + (":flag-bd:" ["🇧🇩"]) + (":flag-be:" ["🇧🇪"]) + (":flag-bf:" ["🇧🇫"]) + (":flag-bg:" ["🇧🇬"]) + (":flag-bh:" ["🇧🇭"]) + (":flag-bi:" ["🇧🇮"]) + (":flag-bj:" ["🇧🇯"]) + (":flag-bl:" ["🇧🇱"]) + (":flag-bm:" ["🇧🇲"]) + (":flag-bn:" ["🇧🇳"]) + (":flag-bo:" ["🇧🇴"]) + (":flag-bq:" ["🇧🇶"]) + (":flag-br:" ["🇧🇷"]) + (":flag-bs:" ["🇧🇸"]) + (":flag-bt:" ["🇧🇹"]) + (":flag-bv:" ["🇧🇻"]) + (":flag-bw:" ["🇧🇼"]) + (":flag-by:" ["🇧🇾"]) + (":flag-bz:" ["🇧🇿"]) + (":flag-ca:" ["🇨🇦"]) + (":flag-cc:" ["🇨🇨"]) + (":flag-cd:" ["🇨🇩"]) + (":flag-cf:" ["🇨🇫"]) + (":flag-cg:" ["🇨🇬"]) + (":flag-ch:" ["🇨🇭"]) + (":flag-ci:" ["🇨🇮"]) + (":flag-ck:" ["🇨🇰"]) + (":flag-cl:" ["🇨🇱"]) + (":flag-cm:" ["🇨🇲"]) + (":cn:" ["🇨🇳"]) + (":flag-cn:" ["🇨🇳"]) + (":flag-co:" ["🇨🇴"]) + (":flag-cp:" ["🇨🇵"]) + (":flag-cr:" ["🇨🇷"]) + (":flag-cu:" ["🇨🇺"]) + (":flag-cv:" ["🇨🇻"]) + (":flag-cw:" ["🇨🇼"]) + (":flag-cx:" ["🇨🇽"]) + (":flag-cy:" ["🇨🇾"]) + (":flag-cz:" ["🇨🇿"]) + (":de:" ["🇩🇪"]) + (":flag-de:" ["🇩🇪"]) + (":flag-dg:" ["🇩🇬"]) + (":flag-dj:" ["🇩🇯"]) + (":flag-dk:" ["🇩🇰"]) + (":flag-dm:" ["🇩🇲"]) + (":flag-do:" ["🇩🇴"]) + (":flag-dz:" ["🇩🇿"]) + (":flag-ea:" ["🇪🇦"]) + (":flag-ec:" ["🇪🇨"]) + (":flag-ee:" ["🇪🇪"]) + (":flag-eg:" ["🇪🇬"]) + (":flag-eh:" ["🇪🇭"]) + (":flag-er:" ["🇪🇷"]) + (":es:" ["🇪🇸"]) + (":flag-es:" ["🇪🇸"]) + (":flag-et:" ["🇪🇹"]) + (":flag-eu:" ["🇪🇺"]) + (":flag-fi:" ["🇫🇮"]) + (":flag-fj:" ["🇫🇯"]) + (":flag-fk:" ["🇫🇰"]) + (":flag-fm:" ["🇫🇲"]) + (":flag-fo:" ["🇫🇴"]) + (":fr:" ["🇫🇷"]) + (":flag-fr:" ["🇫🇷"]) + (":flag-ga:" ["🇬🇦"]) + (":gb:" ["🇬🇧"]) + (":uk:" ["🇬🇧"]) + (":flag-gb:" ["🇬🇧"]) + (":flag-gd:" ["🇬🇩"]) + (":flag-ge:" ["🇬🇪"]) + (":flag-gf:" ["🇬🇫"]) + (":flag-gg:" ["🇬🇬"]) + (":flag-gh:" ["🇬🇭"]) + (":flag-gi:" ["🇬🇮"]) + (":flag-gl:" ["🇬🇱"]) + (":flag-gm:" ["🇬🇲"]) + (":flag-gn:" ["🇬🇳"]) + (":flag-gp:" ["🇬🇵"]) + (":flag-gq:" ["🇬🇶"]) + (":flag-gr:" ["🇬🇷"]) + (":flag-gs:" ["🇬🇸"]) + (":flag-gt:" ["🇬🇹"]) + (":flag-gu:" ["🇬🇺"]) + (":flag-gw:" ["🇬🇼"]) + (":flag-gy:" ["🇬🇾"]) + (":flag-hk:" ["🇭🇰"]) + (":flag-hm:" ["🇭🇲"]) + (":flag-hn:" ["🇭🇳"]) + (":flag-hr:" ["🇭🇷"]) + (":flag-ht:" ["🇭🇹"]) + (":flag-hu:" ["🇭🇺"]) + (":flag-ic:" ["🇮🇨"]) + (":flag-id:" ["🇮🇩"]) + (":flag-ie:" ["🇮🇪"]) + (":flag-il:" ["🇮🇱"]) + (":flag-im:" ["🇮🇲"]) + (":flag-in:" ["🇮🇳"]) + (":flag-io:" ["🇮🇴"]) + (":flag-iq:" ["🇮🇶"]) + (":flag-ir:" ["🇮🇷"]) + (":flag-is:" ["🇮🇸"]) + (":it:" ["🇮🇹"]) + (":flag-it:" ["🇮🇹"]) + (":flag-je:" ["🇯🇪"]) + (":flag-jm:" ["🇯🇲"]) + (":flag-jo:" ["🇯🇴"]) + (":jp:" ["🇯🇵"]) + (":flag-jp:" ["🇯🇵"]) + (":flag-ke:" ["🇰🇪"]) + (":flag-kg:" ["🇰🇬"]) + (":flag-kh:" ["🇰🇭"]) + (":flag-ki:" ["🇰🇮"]) + (":flag-km:" ["🇰🇲"]) + (":flag-kn:" ["🇰🇳"]) + (":flag-kp:" ["🇰🇵"]) + (":kr:" ["🇰🇷"]) + (":flag-kr:" ["🇰🇷"]) + (":flag-kw:" ["🇰🇼"]) + (":flag-ky:" ["🇰🇾"]) + (":flag-kz:" ["🇰🇿"]) + (":flag-la:" ["🇱🇦"]) + (":flag-lb:" ["🇱🇧"]) + (":flag-lc:" ["🇱🇨"]) + (":flag-li:" ["🇱🇮"]) + (":flag-lk:" ["🇱🇰"]) + (":flag-lr:" ["🇱🇷"]) + (":flag-ls:" ["🇱🇸"]) + (":flag-lt:" ["🇱🇹"]) + (":flag-lu:" ["🇱🇺"]) + (":flag-lv:" ["🇱🇻"]) + (":flag-ly:" ["🇱🇾"]) + (":flag-ma:" ["🇲🇦"]) + (":flag-mc:" ["🇲🇨"]) + (":flag-md:" ["🇲🇩"]) + (":flag-me:" ["🇲🇪"]) + (":flag-mf:" ["🇲🇫"]) + (":flag-mg:" ["🇲🇬"]) + (":flag-mh:" ["🇲🇭"]) + (":flag-mk:" ["🇲🇰"]) + (":flag-ml:" ["🇲🇱"]) + (":flag-mm:" ["🇲🇲"]) + (":flag-mn:" ["🇲🇳"]) + (":flag-mo:" ["🇲🇴"]) + (":flag-mp:" ["🇲🇵"]) + (":flag-mq:" ["🇲🇶"]) + (":flag-mr:" ["🇲🇷"]) + (":flag-ms:" ["🇲🇸"]) + (":flag-mt:" ["🇲🇹"]) + (":flag-mu:" ["🇲🇺"]) + (":flag-mv:" ["🇲🇻"]) + (":flag-mw:" ["🇲🇼"]) + (":flag-mx:" ["🇲🇽"]) + (":flag-my:" ["🇲🇾"]) + (":flag-mz:" ["🇲🇿"]) + (":flag-na:" ["🇳🇦"]) + (":flag-nc:" ["🇳🇨"]) + (":flag-ne:" ["🇳🇪"]) + (":flag-nf:" ["🇳🇫"]) + (":flag-ng:" ["🇳🇬"]) + (":flag-ni:" ["🇳🇮"]) + (":flag-nl:" ["🇳🇱"]) + (":flag-no:" ["🇳🇴"]) + (":flag-np:" ["🇳🇵"]) + (":flag-nr:" ["🇳🇷"]) + (":flag-nu:" ["🇳🇺"]) + (":flag-nz:" ["🇳🇿"]) + (":flag-om:" ["🇴🇲"]) + (":flag-pa:" ["🇵🇦"]) + (":flag-pe:" ["🇵🇪"]) + (":flag-pf:" ["🇵🇫"]) + (":flag-pg:" ["🇵🇬"]) + (":flag-ph:" ["🇵🇭"]) + (":flag-pk:" ["🇵🇰"]) + (":flag-pl:" ["🇵🇱"]) + (":flag-pm:" ["🇵🇲"]) + (":flag-pn:" ["🇵🇳"]) + (":flag-pr:" ["🇵🇷"]) + (":flag-ps:" ["🇵🇸"]) + (":flag-pt:" ["🇵🇹"]) + (":flag-pw:" ["🇵🇼"]) + (":flag-py:" ["🇵🇾"]) + (":flag-qa:" ["🇶🇦"]) + (":flag-re:" ["🇷🇪"]) + (":flag-ro:" ["🇷🇴"]) + (":flag-rs:" ["🇷🇸"]) + (":ru:" ["🇷🇺"]) + (":flag-ru:" ["🇷🇺"]) + (":flag-rw:" ["🇷🇼"]) + (":flag-sa:" ["🇸🇦"]) + (":flag-sb:" ["🇸🇧"]) + (":flag-sc:" ["🇸🇨"]) + (":flag-sd:" ["🇸🇩"]) + (":flag-se:" ["🇸🇪"]) + (":flag-sg:" ["🇸🇬"]) + (":flag-sh:" ["🇸🇭"]) + (":flag-si:" ["🇸🇮"]) + (":flag-sj:" ["🇸🇯"]) + (":flag-sk:" ["🇸🇰"]) + (":flag-sl:" ["🇸🇱"]) + (":flag-sm:" ["🇸🇲"]) + (":flag-sn:" ["🇸🇳"]) + (":flag-so:" ["🇸🇴"]) + (":flag-sr:" ["🇸🇷"]) + (":flag-ss:" ["🇸🇸"]) + (":flag-st:" ["🇸🇹"]) + (":flag-sv:" ["🇸🇻"]) + (":flag-sx:" ["🇸🇽"]) + (":flag-sy:" ["🇸🇾"]) + (":flag-sz:" ["🇸🇿"]) + (":flag-ta:" ["🇹🇦"]) + (":flag-tc:" ["🇹🇨"]) + (":flag-td:" ["🇹🇩"]) + (":flag-tf:" ["🇹🇫"]) + (":flag-tg:" ["🇹🇬"]) + (":flag-th:" ["🇹🇭"]) + (":flag-tj:" ["🇹🇯"]) + (":flag-tk:" ["🇹🇰"]) + (":flag-tl:" ["🇹🇱"]) + (":flag-tm:" ["🇹🇲"]) + (":flag-tn:" ["🇹🇳"]) + (":flag-to:" ["🇹🇴"]) + (":flag-tr:" ["🇹🇷"]) + (":flag-tt:" ["🇹🇹"]) + (":flag-tv:" ["🇹🇻"]) + (":flag-tw:" ["🇹🇼"]) + (":flag-tz:" ["🇹🇿"]) + (":flag-ua:" ["🇺🇦"]) + (":flag-ug:" ["🇺🇬"]) + (":flag-um:" ["🇺🇲"]) + (":flag-un:" ["🇺🇳"]) + (":us:" ["🇺🇸"]) + (":flag-us:" ["🇺🇸"]) + (":flag-uy:" ["🇺🇾"]) + (":flag-uz:" ["🇺🇿"]) + (":flag-va:" ["🇻🇦"]) + (":flag-vc:" ["🇻🇨"]) + (":flag-ve:" ["🇻🇪"]) + (":flag-vg:" ["🇻🇬"]) + (":flag-vi:" ["🇻🇮"]) + (":flag-vn:" ["🇻🇳"]) + (":flag-vu:" ["🇻🇺"]) + (":flag-wf:" ["🇼🇫"]) + (":flag-ws:" ["🇼🇸"]) + (":flag-xk:" ["🇽🇰"]) + (":flag-ye:" ["🇾🇪"]) + (":flag-yt:" ["🇾🇹"]) + (":flag-za:" ["🇿🇦"]) + (":flag-zm:" ["🇿🇲"]) + (":flag-zw:" ["🇿🇼"]) + (":koko:" ["🈁"]) + (":sa:" ["🈂️"]) + (":u7121:" ["🈚"]) + (":u6307:" ["🈯"]) + (":u7981:" ["🈲"]) + (":u7a7a:" ["🈳"]) + (":u5408:" ["🈴"]) + (":u6e80:" ["🈵"]) + (":u6709:" ["🈶"]) + (":u6708:" ["🈷️"]) + (":u7533:" ["🈸"]) + (":u5272:" ["🈹"]) + (":u55b6:" ["🈺"]) + (":ideograph_advantage:" ["🉐"]) + (":accept:" ["🉑"]) + (":cyclone:" ["🌀"]) + (":foggy:" ["🌁"]) + (":closed_umbrella:" ["🌂"]) + (":night_with_stars:" ["🌃"]) + (":sunrise_over_mountains:" ["🌄"]) + (":sunrise:" ["🌅"]) + (":city_sunset:" ["🌆"]) + (":city_sunrise:" ["🌇"]) + (":rainbow:" ["🌈"]) + (":bridge_at_night:" ["🌉"]) + (":ocean:" ["🌊"]) + (":volcano:" ["🌋"]) + (":milky_way:" ["🌌"]) + (":earth_africa:" ["🌍"]) + (":earth_americas:" ["🌎"]) + (":earth_asia:" ["🌏"]) + (":globe_with_meridians:" ["🌐"]) + (":new_moon:" ["🌑"]) + (":waxing_crescent_moon:" ["🌒"]) + (":first_quarter_moon:" ["🌓"]) + (":moon:" ["🌔"]) + (":waxing_gibbous_moon:" ["🌔"]) + (":full_moon:" ["🌕"]) + (":waning_gibbous_moon:" ["🌖"]) + (":last_quarter_moon:" ["🌗"]) + (":waning_crescent_moon:" ["🌘"]) + (":crescent_moon:" ["🌙"]) + (":new_moon_with_face:" ["🌚"]) + (":first_quarter_moon_with_face:" ["🌛"]) + (":last_quarter_moon_with_face:" ["🌜"]) + (":full_moon_with_face:" ["🌝"]) + (":sun_with_face:" ["🌞"]) + (":star2:" ["🌟"]) + (":stars:" ["🌠"]) + (":thermometer:" ["🌡️"]) + (":mostly_sunny:" ["🌤️"]) + (":sun_small_cloud:" ["🌤️"]) + (":barely_sunny:" ["🌥️"]) + (":sun_behind_cloud:" ["🌥️"]) + (":partly_sunny_rain:" ["🌦️"]) + (":sun_behind_rain_cloud:" ["🌦️"]) + (":rain_cloud:" ["🌧️"]) + (":snow_cloud:" ["🌨️"]) + (":lightning:" ["🌩️"]) + (":lightning_cloud:" ["🌩️"]) + (":tornado:" ["🌪️"]) + (":tornado_cloud:" ["🌪️"]) + (":fog:" ["🌫️"]) + (":wind_blowing_face:" ["🌬️"]) + (":hotdog:" ["🌭"]) + (":taco:" ["🌮"]) + (":burrito:" ["🌯"]) + (":chestnut:" ["🌰"]) + (":seedling:" ["🌱"]) + (":evergreen_tree:" ["🌲"]) + (":deciduous_tree:" ["🌳"]) + (":palm_tree:" ["🌴"]) + (":cactus:" ["🌵"]) + (":hot_pepper:" ["🌶️"]) + (":tulip:" ["🌷"]) + (":cherry_blossom:" ["🌸"]) + (":rose:" ["🌹"]) + (":hibiscus:" ["🌺"]) + (":sunflower:" ["🌻"]) + (":blossom:" ["🌼"]) + (":corn:" ["🌽"]) + (":ear_of_rice:" ["🌾"]) + (":herb:" ["🌿"]) + (":four_leaf_clover:" ["🍀"]) + (":maple_leaf:" ["🍁"]) + (":fallen_leaf:" ["🍂"]) + (":leaves:" ["🍃"]) + (":mushroom:" ["🍄"]) + (":tomato:" ["🍅"]) + (":eggplant:" ["🍆"]) + (":grapes:" ["🍇"]) + (":melon:" ["🍈"]) + (":watermelon:" ["🍉"]) + (":tangerine:" ["🍊"]) + (":lemon:" ["🍋"]) + (":banana:" ["🍌"]) + (":pineapple:" ["🍍"]) + (":apple:" ["🍎"]) + (":green_apple:" ["🍏"]) + (":pear:" ["🍐"]) + (":peach:" ["🍑"]) + (":cherries:" ["🍒"]) + (":strawberry:" ["🍓"]) + (":hamburger:" ["🍔"]) + (":pizza:" ["🍕"]) + (":meat_on_bone:" ["🍖"]) + (":poultry_leg:" ["🍗"]) + (":rice_cracker:" ["🍘"]) + (":rice_ball:" ["🍙"]) + (":rice:" ["🍚"]) + (":curry:" ["🍛"]) + (":ramen:" ["🍜"]) + (":spaghetti:" ["🍝"]) + (":bread:" ["🍞"]) + (":fries:" ["🍟"]) + (":sweet_potato:" ["🍠"]) + (":dango:" ["🍡"]) + (":oden:" ["🍢"]) + (":sushi:" ["🍣"]) + (":fried_shrimp:" ["🍤"]) + (":fish_cake:" ["🍥"]) + (":icecream:" ["🍦"]) + (":shaved_ice:" ["🍧"]) + (":ice_cream:" ["🍨"]) + (":doughnut:" ["🍩"]) + (":cookie:" ["🍪"]) + (":chocolate_bar:" ["🍫"]) + (":candy:" ["🍬"]) + (":lollipop:" ["🍭"]) + (":custard:" ["🍮"]) + (":honey_pot:" ["🍯"]) + (":cake:" ["🍰"]) + (":bento:" ["🍱"]) + (":stew:" ["🍲"]) + (":fried_egg:" ["🍳"]) + (":cooking:" ["🍳"]) + (":fork_and_knife:" ["🍴"]) + (":tea:" ["🍵"]) + (":sake:" ["🍶"]) + (":wine_glass:" ["🍷"]) + (":cocktail:" ["🍸"]) + (":tropical_drink:" ["🍹"]) + (":beer:" ["🍺"]) + (":beers:" ["🍻"]) + (":baby_bottle:" ["🍼"]) + (":knife_fork_plate:" ["🍽️"]) + (":champagne:" ["🍾"]) + (":popcorn:" ["🍿"]) + (":ribbon:" ["🎀"]) + (":gift:" ["🎁"]) + (":birthday:" ["🎂"]) + (":jack_o_lantern:" ["🎃"]) + (":christmas_tree:" ["🎄"]) + (":santa:" ["🎅"]) + (":fireworks:" ["🎆"]) + (":sparkler:" ["🎇"]) + (":balloon:" ["🎈"]) + (":tada:" ["🎉"]) + (":confetti_ball:" ["🎊"]) + (":tanabata_tree:" ["🎋"]) + (":crossed_flags:" ["🎌"]) + (":bamboo:" ["🎍"]) + (":dolls:" ["🎎"]) + (":flags:" ["🎏"]) + (":wind_chime:" ["🎐"]) + (":rice_scene:" ["🎑"]) + (":school_satchel:" ["🎒"]) + (":mortar_board:" ["🎓"]) + (":medal:" ["🎖️"]) + (":reminder_ribbon:" ["🎗️"]) + (":studio_microphone:" ["🎙️"]) + (":level_slider:" ["🎚️"]) + (":control_knobs:" ["🎛️"]) + (":film_frames:" ["🎞️"]) + (":admission_tickets:" ["🎟️"]) + (":carousel_horse:" ["🎠"]) + (":ferris_wheel:" ["🎡"]) + (":roller_coaster:" ["🎢"]) + (":fishing_pole_and_fish:" ["🎣"]) + (":microphone:" ["🎤"]) + (":movie_camera:" ["🎥"]) + (":cinema:" ["🎦"]) + (":headphones:" ["🎧"]) + (":art:" ["🎨"]) + (":tophat:" ["🎩"]) + (":circus_tent:" ["🎪"]) + (":ticket:" ["🎫"]) + (":clapper:" ["🎬"]) + (":performing_arts:" ["🎭"]) + (":video_game:" ["🎮"]) + (":dart:" ["🎯"]) + (":slot_machine:" ["🎰"]) + (":8ball:" ["🎱"]) + (":game_die:" ["🎲"]) + (":bowling:" ["🎳"]) + (":flower_playing_cards:" ["🎴"]) + (":musical_note:" ["🎵"]) + (":notes:" ["🎶"]) + (":saxophone:" ["🎷"]) + (":guitar:" ["🎸"]) + (":musical_keyboard:" ["🎹"]) + (":trumpet:" ["🎺"]) + (":violin:" ["🎻"]) + (":musical_score:" ["🎼"]) + (":running_shirt_with_sash:" ["🎽"]) + (":tennis:" ["🎾"]) + (":ski:" ["🎿"]) + (":basketball:" ["🏀"]) + (":checkered_flag:" ["🏁"]) + (":snowboarder:" ["🏂"]) + (":woman-running:" ["🏃♀️"]) + (":man-running:" ["🏃♂️"]) + (":runner:" ["🏃"]) + (":running:" ["🏃"]) + (":woman-surfing:" ["🏄♀️"]) + (":man-surfing:" ["🏄♂️"]) + (":surfer:" ["🏄"]) + (":sports_medal:" ["🏅"]) + (":trophy:" ["🏆"]) + (":horse_racing:" ["🏇"]) + (":football:" ["🏈"]) + (":rugby_football:" ["🏉"]) + (":woman-swimming:" ["🏊♀️"]) + (":man-swimming:" ["🏊♂️"]) + (":swimmer:" ["🏊"]) + (":woman-lifting-weights:" ["🏋️♀️"]) + (":man-lifting-weights:" ["🏋️♂️"]) + (":weight_lifter:" ["🏋️"]) + (":woman-golfing:" ["🏌️♀️"]) + (":man-golfing:" ["🏌️♂️"]) + (":golfer:" ["🏌️"]) + (":racing_motorcycle:" ["🏍️"]) + (":racing_car:" ["🏎️"]) + (":cricket_bat_and_ball:" ["🏏"]) + (":volleyball:" ["🏐"]) + (":field_hockey_stick_and_ball:" ["🏑"]) + (":ice_hockey_stick_and_puck:" ["🏒"]) + (":table_tennis_paddle_and_ball:" ["🏓"]) + (":snow_capped_mountain:" ["🏔️"]) + (":camping:" ["🏕️"]) + (":beach_with_umbrella:" ["🏖️"]) + (":building_construction:" ["🏗️"]) + (":house_buildings:" ["🏘️"]) + (":cityscape:" ["🏙️"]) + (":derelict_house_building:" ["🏚️"]) + (":classical_building:" ["🏛️"]) + (":desert:" ["🏜️"]) + (":desert_island:" ["🏝️"]) + (":national_park:" ["🏞️"]) + (":stadium:" ["🏟️"]) + (":house:" ["🏠"]) + (":house_with_garden:" ["🏡"]) + (":office:" ["🏢"]) + (":post_office:" ["🏣"]) + (":european_post_office:" ["🏤"]) + (":hospital:" ["🏥"]) + (":bank:" ["🏦"]) + (":atm:" ["🏧"]) + (":hotel:" ["🏨"]) + (":love_hotel:" ["🏩"]) + (":convenience_store:" ["🏪"]) + (":school:" ["🏫"]) + (":department_store:" ["🏬"]) + (":factory:" ["🏭"]) + (":izakaya_lantern:" ["🏮"]) + (":lantern:" ["🏮"]) + (":japanese_castle:" ["🏯"]) + (":european_castle:" ["🏰"]) + (":rainbow-flag:" ["🏳️🌈"]) + (":transgender_flag:" ["🏳️⚧️"]) + (":waving_white_flag:" ["🏳️"]) + (":pirate_flag:" ["🏴☠️"]) + (":flag-england:" ["🏴"]) + (":flag-scotland:" ["🏴"]) + (":flag-wales:" ["🏴"]) + (":waving_black_flag:" ["🏴"]) + (":rosette:" ["🏵️"]) + (":label:" ["🏷️"]) + (":badminton_racquet_and_shuttlecock:" ["🏸"]) + (":bow_and_arrow:" ["🏹"]) + (":amphora:" ["🏺"]) + (":skin-tone-2:" ["🏻"]) + (":skin-tone-3:" ["🏼"]) + (":skin-tone-4:" ["🏽"]) + (":skin-tone-5:" ["🏾"]) + (":skin-tone-6:" ["🏿"]) + (":rat:" ["🐀"]) + (":mouse2:" ["🐁"]) + (":ox:" ["🐂"]) + (":water_buffalo:" ["🐃"]) + (":cow2:" ["🐄"]) + (":tiger2:" ["🐅"]) + (":leopard:" ["🐆"]) + (":rabbit2:" ["🐇"]) + (":black_cat:" ["🐈⬛"]) + (":cat2:" ["🐈"]) + (":dragon:" ["🐉"]) + (":crocodile:" ["🐊"]) + (":whale2:" ["🐋"]) + (":snail:" ["🐌"]) + (":snake:" ["🐍"]) + (":racehorse:" ["🐎"]) + (":ram:" ["🐏"]) + (":goat:" ["🐐"]) + (":sheep:" ["🐑"]) + (":monkey:" ["🐒"]) + (":rooster:" ["🐓"]) + (":chicken:" ["🐔"]) + (":service_dog:" ["🐕🦺"]) + (":dog2:" ["🐕"]) + (":pig2:" ["🐖"]) + (":boar:" ["🐗"]) + (":elephant:" ["🐘"]) + (":octopus:" ["🐙"]) + (":shell:" ["🐚"]) + (":bug:" ["🐛"]) + (":ant:" ["🐜"]) + (":bee:" ["🐝"]) + (":honeybee:" ["🐝"]) + (":ladybug:" ["🐞"]) + (":lady_beetle:" ["🐞"]) + (":fish:" ["🐟"]) + (":tropical_fish:" ["🐠"]) + (":blowfish:" ["🐡"]) + (":turtle:" ["🐢"]) + (":hatching_chick:" ["🐣"]) + (":baby_chick:" ["🐤"]) + (":hatched_chick:" ["🐥"]) + (":bird:" ["🐦"]) + (":penguin:" ["🐧"]) + (":koala:" ["🐨"]) + (":poodle:" ["🐩"]) + (":dromedary_camel:" ["🐪"]) + (":camel:" ["🐫"]) + (":dolphin:" ["🐬"]) + (":flipper:" ["🐬"]) + (":mouse:" ["🐭"]) + (":cow:" ["🐮"]) + (":tiger:" ["🐯"]) + (":rabbit:" ["🐰"]) + (":cat:" ["🐱"]) + (":dragon_face:" ["🐲"]) + (":whale:" ["🐳"]) + (":horse:" ["🐴"]) + (":monkey_face:" ["🐵"]) + (":o)" ["🐵"]) + (":dog:" ["🐶"]) + (":pig:" ["🐷"]) + (":frog:" ["🐸"]) + (":hamster:" ["🐹"]) + (":wolf:" ["🐺"]) + (":polar_bear:" ["🐻❄️"]) + (":bear:" ["🐻"]) + (":panda_face:" ["🐼"]) + (":pig_nose:" ["🐽"]) + (":feet:" ["🐾"]) + (":paw_prints:" ["🐾"]) + (":chipmunk:" ["🐿️"]) + (":eyes:" ["👀"]) + (":eye-in-speech-bubble:" ["👁️🗨️"]) + (":eye:" ["👁️"]) + (":ear:" ["👂"]) + (":nose:" ["👃"]) + (":lips:" ["👄"]) + (":tongue:" ["👅"]) + (":point_up_2:" ["👆"]) + (":point_down:" ["👇"]) + (":point_left:" ["👈"]) + (":point_right:" ["👉"]) + (":facepunch:" ["👊"]) + (":punch:" ["👊"]) + (":wave:" ["👋"]) + (":ok_hand:" ["👌"]) + (":+1:" ["👍"]) + (":thumbsup:" ["👍"]) + (":-1:" ["👎"]) + (":thumbsdown:" ["👎"]) + (":clap:" ["👏"]) + (":open_hands:" ["👐"]) + (":crown:" ["👑"]) + (":womans_hat:" ["👒"]) + (":eyeglasses:" ["👓"]) + (":necktie:" ["👔"]) + (":shirt:" ["👕"]) + (":tshirt:" ["👕"]) + (":jeans:" ["👖"]) + (":dress:" ["👗"]) + (":kimono:" ["👘"]) + (":bikini:" ["👙"]) + (":womans_clothes:" ["👚"]) + (":purse:" ["👛"]) + (":handbag:" ["👜"]) + (":pouch:" ["👝"]) + (":mans_shoe:" ["👞"]) + (":shoe:" ["👞"]) + (":athletic_shoe:" ["👟"]) + (":high_heel:" ["👠"]) + (":sandal:" ["👡"]) + (":boot:" ["👢"]) + (":footprints:" ["👣"]) + (":bust_in_silhouette:" ["👤"]) + (":busts_in_silhouette:" ["👥"]) + (":boy:" ["👦"]) + (":girl:" ["👧"]) + (":male-farmer:" ["👨🌾"]) + (":male-cook:" ["👨🍳"]) + (":man_feeding_baby:" ["👨🍼"]) + (":male-student:" ["👨🎓"]) + (":male-singer:" ["👨🎤"]) + (":male-artist:" ["👨🎨"]) + (":male-teacher:" ["👨🏫"]) + (":male-factory-worker:" ["👨🏭"]) + (":man-boy-boy:" ["👨👦👦"]) + (":man-boy:" ["👨👦"]) + (":man-girl-boy:" ["👨👧👦"]) + (":man-girl-girl:" ["👨👧👧"]) + (":man-girl:" ["👨👧"]) + (":man-man-boy:" ["👨👨👦"]) + (":man-man-boy-boy:" ["👨👨👦👦"]) + (":man-man-girl:" ["👨👨👧"]) + (":man-man-girl-boy:" ["👨👨👧👦"]) + (":man-man-girl-girl:" ["👨👨👧👧"]) + (":man-woman-boy:" ["👨👩👦"]) + (":man-woman-boy-boy:" ["👨👩👦👦"]) + (":man-woman-girl:" ["👨👩👧"]) + (":man-woman-girl-boy:" ["👨👩👧👦"]) + (":man-woman-girl-girl:" ["👨👩👧👧"]) + (":male-technologist:" ["👨💻"]) + (":male-office-worker:" ["👨💼"]) + (":male-mechanic:" ["👨🔧"]) + (":male-scientist:" ["👨🔬"]) + (":male-astronaut:" ["👨🚀"]) + (":male-firefighter:" ["👨🚒"]) + (":man_with_probing_cane:" ["👨🦯"]) + (":red_haired_man:" ["👨🦰"]) + (":curly_haired_man:" ["👨🦱"]) + (":bald_man:" ["👨🦲"]) + (":white_haired_man:" ["👨🦳"]) + (":man_in_motorized_wheelchair:" ["👨🦼"]) + (":man_in_manual_wheelchair:" ["👨🦽"]) + (":male-doctor:" ["👨⚕️"]) + (":male-judge:" ["👨⚖️"]) + (":male-pilot:" ["👨✈️"]) + (":man-heart-man:" ["👨❤️👨"]) + (":man-kiss-man:" ["👨❤️💋👨"]) + (":man:" ["👨"]) + (":female-farmer:" ["👩🌾"]) + (":female-cook:" ["👩🍳"]) + (":woman_feeding_baby:" ["👩🍼"]) + (":female-student:" ["👩🎓"]) + (":female-singer:" ["👩🎤"]) + (":female-artist:" ["👩🎨"]) + (":female-teacher:" ["👩🏫"]) + (":female-factory-worker:" ["👩🏭"]) + (":woman-boy-boy:" ["👩👦👦"]) + (":woman-boy:" ["👩👦"]) + (":woman-girl-boy:" ["👩👧👦"]) + (":woman-girl-girl:" ["👩👧👧"]) + (":woman-girl:" ["👩👧"]) + (":woman-woman-boy:" ["👩👩👦"]) + (":woman-woman-boy-boy:" ["👩👩👦👦"]) + (":woman-woman-girl:" ["👩👩👧"]) + (":woman-woman-girl-boy:" ["👩👩👧👦"]) + (":woman-woman-girl-girl:" ["👩👩👧👧"]) + (":female-technologist:" ["👩💻"]) + (":female-office-worker:" ["👩💼"]) + (":female-mechanic:" ["👩🔧"]) + (":female-scientist:" ["👩🔬"]) + (":female-astronaut:" ["👩🚀"]) + (":female-firefighter:" ["👩🚒"]) + (":woman_with_probing_cane:" ["👩🦯"]) + (":red_haired_woman:" ["👩🦰"]) + (":curly_haired_woman:" ["👩🦱"]) + (":bald_woman:" ["👩🦲"]) + (":white_haired_woman:" ["👩🦳"]) + (":woman_in_motorized_wheelchair:" ["👩🦼"]) + (":woman_in_manual_wheelchair:" ["👩🦽"]) + (":female-doctor:" ["👩⚕️"]) + (":female-judge:" ["👩⚖️"]) + (":female-pilot:" ["👩✈️"]) + (":woman-heart-man:" ["👩❤️👨"]) + (":woman-heart-woman:" ["👩❤️👩"]) + (":woman-kiss-man:" ["👩❤️💋👨"]) + (":woman-kiss-woman:" ["👩❤️💋👩"]) + (":woman:" ["👩"]) + (":family:" ["👪"]) + (":man_and_woman_holding_hands:" ["👫"]) + (":woman_and_man_holding_hands:" ["👫"]) + (":couple:" ["👫"]) + (":two_men_holding_hands:" ["👬"]) + (":men_holding_hands:" ["👬"]) + (":two_women_holding_hands:" ["👭"]) + (":women_holding_hands:" ["👭"]) + (":female-police-officer:" ["👮♀️"]) + (":male-police-officer:" ["👮♂️"]) + (":cop:" ["👮"]) + (":women-with-bunny-ears-partying:" ["👯♀️"]) + (":woman-with-bunny-ears-partying:" ["👯♀️"]) + (":men-with-bunny-ears-partying:" ["👯♂️"]) + (":man-with-bunny-ears-partying:" ["👯♂️"]) + (":dancers:" ["👯"]) + (":woman_with_veil:" ["👰♀️"]) + (":man_with_veil:" ["👰♂️"]) + (":bride_with_veil:" ["👰"]) + (":blond-haired-woman:" ["👱♀️"]) + (":blond-haired-man:" ["👱♂️"]) + (":person_with_blond_hair:" ["👱"]) + (":man_with_gua_pi_mao:" ["👲"]) + (":woman-wearing-turban:" ["👳♀️"]) + (":man-wearing-turban:" ["👳♂️"]) + (":man_with_turban:" ["👳"]) + (":older_man:" ["👴"]) + (":older_woman:" ["👵"]) + (":baby:" ["👶"]) + (":female-construction-worker:" ["👷♀️"]) + (":male-construction-worker:" ["👷♂️"]) + (":construction_worker:" ["👷"]) + (":princess:" ["👸"]) + (":japanese_ogre:" ["👹"]) + (":japanese_goblin:" ["👺"]) + (":ghost:" ["👻"]) + (":angel:" ["👼"]) + (":alien:" ["👽"]) + (":space_invader:" ["👾"]) + (":imp:" ["👿"]) + (":skull:" ["💀"]) + (":woman-tipping-hand:" ["💁♀️"]) + (":man-tipping-hand:" ["💁♂️"]) + (":information_desk_person:" ["💁"]) + (":female-guard:" ["💂♀️"]) + (":male-guard:" ["💂♂️"]) + (":guardsman:" ["💂"]) + (":dancer:" ["💃"]) + (":lipstick:" ["💄"]) + (":nail_care:" ["💅"]) + (":woman-getting-massage:" ["💆♀️"]) + (":man-getting-massage:" ["💆♂️"]) + (":massage:" ["💆"]) + (":woman-getting-haircut:" ["💇♀️"]) + (":man-getting-haircut:" ["💇♂️"]) + (":haircut:" ["💇"]) + (":barber:" ["💈"]) + (":syringe:" ["💉"]) + (":pill:" ["💊"]) + (":kiss:" ["💋"]) + (":love_letter:" ["💌"]) + (":ring:" ["💍"]) + (":gem:" ["💎"]) + (":couplekiss:" ["💏"]) + (":bouquet:" ["💐"]) + (":couple_with_heart:" ["💑"]) + (":wedding:" ["💒"]) + (":heartbeat:" ["💓"]) + (":broken_heart:" ["💔"]) + ("</3" ["💔"]) + (":two_hearts:" ["💕"]) + (":sparkling_heart:" ["💖"]) + (":heartpulse:" ["💗"]) + (":cupid:" ["💘"]) + (":blue_heart:" ["💙"]) + ("<3" ["💙"]) + (":green_heart:" ["💚"]) + ("<3" ["💚"]) + (":yellow_heart:" ["💛"]) + ("<3" ["💛"]) + (":purple_heart:" ["💜"]) + ("<3" ["💜"]) + (":gift_heart:" ["💝"]) + (":revolving_hearts:" ["💞"]) + (":heart_decoration:" ["💟"]) + (":diamond_shape_with_a_dot_inside:" ["💠"]) + (":bulb:" ["💡"]) + (":anger:" ["💢"]) + (":bomb:" ["💣"]) + (":zzz:" ["💤"]) + (":boom:" ["💥"]) + (":collision:" ["💥"]) + (":sweat_drops:" ["💦"]) + (":droplet:" ["💧"]) + (":dash:" ["💨"]) + (":hankey:" ["💩"]) + (":poop:" ["💩"]) + (":shit:" ["💩"]) + (":muscle:" ["💪"]) + (":dizzy:" ["💫"]) + (":speech_balloon:" ["💬"]) + (":thought_balloon:" ["💭"]) + (":white_flower:" ["💮"]) + (":100:" ["💯"]) + (":moneybag:" ["💰"]) + (":currency_exchange:" ["💱"]) + (":heavy_dollar_sign:" ["💲"]) + (":credit_card:" ["💳"]) + (":yen:" ["💴"]) + (":dollar:" ["💵"]) + (":euro:" ["💶"]) + (":pound:" ["💷"]) + (":money_with_wings:" ["💸"]) + (":chart:" ["💹"]) + (":seat:" ["💺"]) + (":computer:" ["💻"]) + (":briefcase:" ["💼"]) + (":minidisc:" ["💽"]) + (":floppy_disk:" ["💾"]) + (":cd:" ["💿"]) + (":dvd:" ["📀"]) + (":file_folder:" ["📁"]) + (":open_file_folder:" ["📂"]) + (":page_with_curl:" ["📃"]) + (":page_facing_up:" ["📄"]) + (":date:" ["📅"]) + (":calendar:" ["📆"]) + (":card_index:" ["📇"]) + (":chart_with_upwards_trend:" ["📈"]) + (":chart_with_downwards_trend:" ["📉"]) + (":bar_chart:" ["📊"]) + (":clipboard:" ["📋"]) + (":pushpin:" ["📌"]) + (":round_pushpin:" ["📍"]) + (":paperclip:" ["📎"]) + (":straight_ruler:" ["📏"]) + (":triangular_ruler:" ["📐"]) + (":bookmark_tabs:" ["📑"]) + (":ledger:" ["📒"]) + (":notebook:" ["📓"]) + (":notebook_with_decorative_cover:" ["📔"]) + (":closed_book:" ["📕"]) + (":book:" ["📖"]) + (":open_book:" ["📖"]) + (":green_book:" ["📗"]) + (":blue_book:" ["📘"]) + (":orange_book:" ["📙"]) + (":books:" ["📚"]) + (":name_badge:" ["📛"]) + (":scroll:" ["📜"]) + (":memo:" ["📝"]) + (":pencil:" ["📝"]) + (":telephone_receiver:" ["📞"]) + (":pager:" ["📟"]) + (":fax:" ["📠"]) + (":satellite_antenna:" ["📡"]) + (":loudspeaker:" ["📢"]) + (":mega:" ["📣"]) + (":outbox_tray:" ["📤"]) + (":inbox_tray:" ["📥"]) + (":package:" ["📦"]) + (":e-mail:" ["📧"]) + (":incoming_envelope:" ["📨"]) + (":envelope_with_arrow:" ["📩"]) + (":mailbox_closed:" ["📪"]) + (":mailbox:" ["📫"]) + (":mailbox_with_mail:" ["📬"]) + (":mailbox_with_no_mail:" ["📭"]) + (":postbox:" ["📮"]) + (":postal_horn:" ["📯"]) + (":newspaper:" ["📰"]) + (":iphone:" ["📱"]) + (":calling:" ["📲"]) + (":vibration_mode:" ["📳"]) + (":mobile_phone_off:" ["📴"]) + (":no_mobile_phones:" ["📵"]) + (":signal_strength:" ["📶"]) + (":camera:" ["📷"]) + (":camera_with_flash:" ["📸"]) + (":video_camera:" ["📹"]) + (":tv:" ["📺"]) + (":radio:" ["📻"]) + (":vhs:" ["📼"]) + (":film_projector:" ["📽️"]) + (":prayer_beads:" ["📿"]) + (":twisted_rightwards_arrows:" ["🔀"]) + (":repeat:" ["🔁"]) + (":repeat_one:" ["🔂"]) + (":arrows_clockwise:" ["🔃"]) + (":arrows_counterclockwise:" ["🔄"]) + (":low_brightness:" ["🔅"]) + (":high_brightness:" ["🔆"]) + (":mute:" ["🔇"]) + (":speaker:" ["🔈"]) + (":sound:" ["🔉"]) + (":loud_sound:" ["🔊"]) + (":battery:" ["🔋"]) + (":electric_plug:" ["🔌"]) + (":mag:" ["🔍"]) + (":mag_right:" ["🔎"]) + (":lock_with_ink_pen:" ["🔏"]) + (":closed_lock_with_key:" ["🔐"]) + (":key:" ["🔑"]) + (":lock:" ["🔒"]) + (":unlock:" ["🔓"]) + (":bell:" ["🔔"]) + (":no_bell:" ["🔕"]) + (":bookmark:" ["🔖"]) + (":link:" ["🔗"]) + (":radio_button:" ["🔘"]) + (":back:" ["🔙"]) + (":end:" ["🔚"]) + (":on:" ["🔛"]) + (":soon:" ["🔜"]) + (":top:" ["🔝"]) + (":underage:" ["🔞"]) + (":keycap_ten:" ["🔟"]) + (":capital_abcd:" ["🔠"]) + (":abcd:" ["🔡"]) + (":1234:" ["🔢"]) + (":symbols:" ["🔣"]) + (":abc:" ["🔤"]) + (":fire:" ["🔥"]) + (":flashlight:" ["🔦"]) + (":wrench:" ["🔧"]) + (":hammer:" ["🔨"]) + (":nut_and_bolt:" ["🔩"]) + (":hocho:" ["🔪"]) + (":knife:" ["🔪"]) + (":gun:" ["🔫"]) + (":microscope:" ["🔬"]) + (":telescope:" ["🔭"]) + (":crystal_ball:" ["🔮"]) + (":six_pointed_star:" ["🔯"]) + (":beginner:" ["🔰"]) + (":trident:" ["🔱"]) + (":black_square_button:" ["🔲"]) + (":white_square_button:" ["🔳"]) + (":red_circle:" ["🔴"]) + (":large_blue_circle:" ["🔵"]) + (":large_orange_diamond:" ["🔶"]) + (":large_blue_diamond:" ["🔷"]) + (":small_orange_diamond:" ["🔸"]) + (":small_blue_diamond:" ["🔹"]) + (":small_red_triangle:" ["🔺"]) + (":small_red_triangle_down:" ["🔻"]) + (":arrow_up_small:" ["🔼"]) + (":arrow_down_small:" ["🔽"]) + (":om_symbol:" ["🕉️"]) + (":dove_of_peace:" ["🕊️"]) + (":kaaba:" ["🕋"]) + (":mosque:" ["🕌"]) + (":synagogue:" ["🕍"]) + (":menorah_with_nine_branches:" ["🕎"]) + (":clock1:" ["🕐"]) + (":clock2:" ["🕑"]) + (":clock3:" ["🕒"]) + (":clock4:" ["🕓"]) + (":clock5:" ["🕔"]) + (":clock6:" ["🕕"]) + (":clock7:" ["🕖"]) + (":clock8:" ["🕗"]) + (":clock9:" ["🕘"]) + (":clock10:" ["🕙"]) + (":clock11:" ["🕚"]) + (":clock12:" ["🕛"]) + (":clock130:" ["🕜"]) + (":clock230:" ["🕝"]) + (":clock330:" ["🕞"]) + (":clock430:" ["🕟"]) + (":clock530:" ["🕠"]) + (":clock630:" ["🕡"]) + (":clock730:" ["🕢"]) + (":clock830:" ["🕣"]) + (":clock930:" ["🕤"]) + (":clock1030:" ["🕥"]) + (":clock1130:" ["🕦"]) + (":clock1230:" ["🕧"]) + (":candle:" ["🕯️"]) + (":mantelpiece_clock:" ["🕰️"]) + (":hole:" ["🕳️"]) + (":man_in_business_suit_levitating:" ["🕴️"]) + (":female-detective:" ["🕵️♀️"]) + (":male-detective:" ["🕵️♂️"]) + (":sleuth_or_spy:" ["🕵️"]) + (":dark_sunglasses:" ["🕶️"]) + (":spider:" ["🕷️"]) + (":spider_web:" ["🕸️"]) + (":joystick:" ["🕹️"]) + (":man_dancing:" ["🕺"]) + (":linked_paperclips:" ["🖇️"]) + (":lower_left_ballpoint_pen:" ["🖊️"]) + (":lower_left_fountain_pen:" ["🖋️"]) + (":lower_left_paintbrush:" ["🖌️"]) + (":lower_left_crayon:" ["🖍️"]) + (":raised_hand_with_fingers_splayed:" ["🖐️"]) + (":middle_finger:" ["🖕"]) + (":reversed_hand_with_middle_finger_extended:" ["🖕"]) + (":spock-hand:" ["🖖"]) + (":black_heart:" ["🖤"]) + (":desktop_computer:" ["🖥️"]) + (":printer:" ["🖨️"]) + (":three_button_mouse:" ["🖱️"]) + (":trackball:" ["🖲️"]) + (":frame_with_picture:" ["🖼️"]) + (":card_index_dividers:" ["🗂️"]) + (":card_file_box:" ["🗃️"]) + (":file_cabinet:" ["🗄️"]) + (":wastebasket:" ["🗑️"]) + (":spiral_note_pad:" ["🗒️"]) + (":spiral_calendar_pad:" ["🗓️"]) + (":compression:" ["🗜️"]) + (":old_key:" ["🗝️"]) + (":rolled_up_newspaper:" ["🗞️"]) + (":dagger_knife:" ["🗡️"]) + (":speaking_head_in_silhouette:" ["🗣️"]) + (":left_speech_bubble:" ["🗨️"]) + (":right_anger_bubble:" ["🗯️"]) + (":ballot_box_with_ballot:" ["🗳️"]) + (":world_map:" ["🗺️"]) + (":mount_fuji:" ["🗻"]) + (":tokyo_tower:" ["🗼"]) + (":statue_of_liberty:" ["🗽"]) + (":japan:" ["🗾"]) + (":moyai:" ["🗿"]) + (":grinning:" ["😀"]) + (":D" ["😀"]) + (":grin:" ["😁"]) + (":joy:" ["😂"]) + (":smiley:" ["😃"]) + (":)" ["😃"]) + ("=)" ["😃"]) + ("=-)" ["😃"]) + (":smile:" ["😄"]) + (":)" ["😄"]) + ("C:" ["😄"]) + ("c:" ["😄"]) + (":D" ["😄"]) + (":-D" ["😄"]) + (":sweat_smile:" ["😅"]) + (":laughing:" ["😆"]) + (":satisfied:" ["😆"]) + (":>" ["😆"]) + (":->" ["😆"]) + (":innocent:" ["😇"]) + (":smiling_imp:" ["😈"]) + (":wink:" ["😉"]) + (";)" ["😉"]) + (";-)" ["😉"]) + (":blush:" ["😊"]) + (":)" ["😊"]) + (":yum:" ["😋"]) + (":relieved:" ["😌"]) + (":heart_eyes:" ["😍"]) + (":sunglasses:" ["😎"]) + ("8)" ["😎"]) + (":smirk:" ["😏"]) + (":neutral_face:" ["😐"]) + (":|" ["😐"]) + (":-|" ["😐"]) + (":expressionless:" ["😑"]) + (":unamused:" ["😒"]) + (":(" ["😒"]) + (":sweat:" ["😓"]) + (":pensive:" ["😔"]) + (":confused:" ["😕"]) + (":\\" ["😕"]) + (":-\\" ["😕"]) + (":/" ["😕"]) + (":-/" ["😕"]) + (":confounded:" ["😖"]) + (":kissing:" ["😗"]) + (":kissing_heart:" ["😘"]) + (":*" ["😘"]) + (":-*" ["😘"]) + (":kissing_smiling_eyes:" ["😙"]) + (":kissing_closed_eyes:" ["😚"]) + (":stuck_out_tongue:" ["😛"]) + (":p" ["😛"]) + (":-p" ["😛"]) + (":P" ["😛"]) + (":-P" ["😛"]) + (":b" ["😛"]) + (":-b" ["😛"]) + (":stuck_out_tongue_winking_eye:" ["😜"]) + (";p" ["😜"]) + (";-p" ["😜"]) + (";b" ["😜"]) + (";-b" ["😜"]) + (";P" ["😜"]) + (";-P" ["😜"]) + (":stuck_out_tongue_closed_eyes:" ["😝"]) + (":disappointed:" ["😞"]) + (":(" ["😞"]) + ("):" ["😞"]) + (":-(" ["😞"]) + (":worried:" ["😟"]) + (":angry:" ["😠"]) + (">:(" ["😠"]) + (">:-(" ["😠"]) + (":rage:" ["😡"]) + (":cry:" ["😢"]) + (":'(" ["😢"]) + (":persevere:" ["😣"]) + (":triumph:" ["😤"]) + (":disappointed_relieved:" ["😥"]) + (":frowning:" ["😦"]) + (":anguished:" ["😧"]) + ("D:" ["😧"]) + (":fearful:" ["😨"]) + (":weary:" ["😩"]) + (":sleepy:" ["😪"]) + (":tired_face:" ["😫"]) + (":grimacing:" ["😬"]) + (":sob:" ["😭"]) + (":'(" ["😭"]) + (":face_exhaling:" ["😮💨"]) + (":open_mouth:" ["😮"]) + (":o" ["😮"]) + (":-o" ["😮"]) + (":O" ["😮"]) + (":-O" ["😮"]) + (":hushed:" ["😯"]) + (":cold_sweat:" ["😰"]) + (":scream:" ["😱"]) + (":astonished:" ["😲"]) + (":flushed:" ["😳"]) + (":sleeping:" ["😴"]) + (":face_with_spiral_eyes:" ["😵💫"]) + (":dizzy_face:" ["😵"]) + (":face_in_clouds:" ["😶🌫️"]) + (":no_mouth:" ["😶"]) + (":mask:" ["😷"]) + (":smile_cat:" ["😸"]) + (":joy_cat:" ["😹"]) + (":smiley_cat:" ["😺"]) + (":heart_eyes_cat:" ["😻"]) + (":smirk_cat:" ["😼"]) + (":kissing_cat:" ["😽"]) + (":pouting_cat:" ["😾"]) + (":crying_cat_face:" ["😿"]) + (":scream_cat:" ["🙀"]) + (":slightly_frowning_face:" ["🙁"]) + (":slightly_smiling_face:" ["🙂"]) + (":)" ["🙂"]) + ("(:" ["🙂"]) + (":-)" ["🙂"]) + (":upside_down_face:" ["🙃"]) + (":face_with_rolling_eyes:" ["🙄"]) + (":woman-gesturing-no:" ["🙅♀️"]) + (":man-gesturing-no:" ["🙅♂️"]) + (":no_good:" ["🙅"]) + (":woman-gesturing-ok:" ["🙆♀️"]) + (":man-gesturing-ok:" ["🙆♂️"]) + (":ok_woman:" ["🙆"]) + (":woman-bowing:" ["🙇♀️"]) + (":man-bowing:" ["🙇♂️"]) + (":bow:" ["🙇"]) + (":see_no_evil:" ["🙈"]) + (":hear_no_evil:" ["🙉"]) + (":speak_no_evil:" ["🙊"]) + (":woman-raising-hand:" ["🙋♀️"]) + (":man-raising-hand:" ["🙋♂️"]) + (":raising_hand:" ["🙋"]) + (":raised_hands:" ["🙌"]) + (":woman-frowning:" ["🙍♀️"]) + (":man-frowning:" ["🙍♂️"]) + (":person_frowning:" ["🙍"]) + (":woman-pouting:" ["🙎♀️"]) + (":man-pouting:" ["🙎♂️"]) + (":person_with_pouting_face:" ["🙎"]) + (":pray:" ["🙏"]) + (":rocket:" ["🚀"]) + (":helicopter:" ["🚁"]) + (":steam_locomotive:" ["🚂"]) + (":railway_car:" ["🚃"]) + (":bullettrain_side:" ["🚄"]) + (":bullettrain_front:" ["🚅"]) + (":train2:" ["🚆"]) + (":metro:" ["🚇"]) + (":light_rail:" ["🚈"]) + (":station:" ["🚉"]) + (":tram:" ["🚊"]) + (":train:" ["🚋"]) + (":bus:" ["🚌"]) + (":oncoming_bus:" ["🚍"]) + (":trolleybus:" ["🚎"]) + (":busstop:" ["🚏"]) + (":minibus:" ["🚐"]) + (":ambulance:" ["🚑"]) + (":fire_engine:" ["🚒"]) + (":police_car:" ["🚓"]) + (":oncoming_police_car:" ["🚔"]) + (":taxi:" ["🚕"]) + (":oncoming_taxi:" ["🚖"]) + (":car:" ["🚗"]) + (":red_car:" ["🚗"]) + (":oncoming_automobile:" ["🚘"]) + (":blue_car:" ["🚙"]) + (":truck:" ["🚚"]) + (":articulated_lorry:" ["🚛"]) + (":tractor:" ["🚜"]) + (":monorail:" ["🚝"]) + (":mountain_railway:" ["🚞"]) + (":suspension_railway:" ["🚟"]) + (":mountain_cableway:" ["🚠"]) + (":aerial_tramway:" ["🚡"]) + (":ship:" ["🚢"]) + (":woman-rowing-boat:" ["🚣♀️"]) + (":man-rowing-boat:" ["🚣♂️"]) + (":rowboat:" ["🚣"]) + (":speedboat:" ["🚤"]) + (":traffic_light:" ["🚥"]) + (":vertical_traffic_light:" ["🚦"]) + (":construction:" ["🚧"]) + (":rotating_light:" ["🚨"]) + (":triangular_flag_on_post:" ["🚩"]) + (":door:" ["🚪"]) + (":no_entry_sign:" ["🚫"]) + (":smoking:" ["🚬"]) + (":no_smoking:" ["🚭"]) + (":put_litter_in_its_place:" ["🚮"]) + (":do_not_litter:" ["🚯"]) + (":potable_water:" ["🚰"]) + (":non-potable_water:" ["🚱"]) + (":bike:" ["🚲"]) + (":no_bicycles:" ["🚳"]) + (":woman-biking:" ["🚴♀️"]) + (":man-biking:" ["🚴♂️"]) + (":bicyclist:" ["🚴"]) + (":woman-mountain-biking:" ["🚵♀️"]) + (":man-mountain-biking:" ["🚵♂️"]) + (":mountain_bicyclist:" ["🚵"]) + (":woman-walking:" ["🚶♀️"]) + (":man-walking:" ["🚶♂️"]) + (":walking:" ["🚶"]) + (":no_pedestrians:" ["🚷"]) + (":children_crossing:" ["🚸"]) + (":mens:" ["🚹"]) + (":womens:" ["🚺"]) + (":restroom:" ["🚻"]) + (":baby_symbol:" ["🚼"]) + (":toilet:" ["🚽"]) + (":wc:" ["🚾"]) + (":shower:" ["🚿"]) + (":bath:" ["🛀"]) + (":bathtub:" ["🛁"]) + (":passport_control:" ["🛂"]) + (":customs:" ["🛃"]) + (":baggage_claim:" ["🛄"]) + (":left_luggage:" ["🛅"]) + (":couch_and_lamp:" ["🛋️"]) + (":sleeping_accommodation:" ["🛌"]) + (":shopping_bags:" ["🛍️"]) + (":bellhop_bell:" ["🛎️"]) + (":bed:" ["🛏️"]) + (":place_of_worship:" ["🛐"]) + (":octagonal_sign:" ["🛑"]) + (":shopping_trolley:" ["🛒"]) + (":hindu_temple:" ["🛕"]) + (":hut:" ["🛖"]) + (":elevator:" ["🛗"]) + (":hammer_and_wrench:" ["🛠️"]) + (":shield:" ["🛡️"]) + (":oil_drum:" ["🛢️"]) + (":motorway:" ["🛣️"]) + (":railway_track:" ["🛤️"]) + (":motor_boat:" ["🛥️"]) + (":small_airplane:" ["🛩️"]) + (":airplane_departure:" ["🛫"]) + (":airplane_arriving:" ["🛬"]) + (":satellite:" ["🛰️"]) + (":passenger_ship:" ["🛳️"]) + (":scooter:" ["🛴"]) + (":motor_scooter:" ["🛵"]) + (":canoe:" ["🛶"]) + (":sled:" ["🛷"]) + (":flying_saucer:" ["🛸"]) + (":skateboard:" ["🛹"]) + (":auto_rickshaw:" ["🛺"]) + (":pickup_truck:" ["🛻"]) + (":roller_skate:" ["🛼"]) + (":large_orange_circle:" ["🟠"]) + (":large_yellow_circle:" ["🟡"]) + (":large_green_circle:" ["🟢"]) + (":large_purple_circle:" ["🟣"]) + (":large_brown_circle:" ["🟤"]) + (":large_red_square:" ["🟥"]) + (":large_blue_square:" ["🟦"]) + (":large_orange_square:" ["🟧"]) + (":large_yellow_square:" ["🟨"]) + (":large_green_square:" ["🟩"]) + (":large_purple_square:" ["🟪"]) + (":large_brown_square:" ["🟫"]) + (":pinched_fingers:" ["🤌"]) + (":white_heart:" ["🤍"]) + (":brown_heart:" ["🤎"]) + (":pinching_hand:" ["🤏"]) + (":zipper_mouth_face:" ["🤐"]) + (":money_mouth_face:" ["🤑"]) + (":face_with_thermometer:" ["🤒"]) + (":nerd_face:" ["🤓"]) + (":thinking_face:" ["🤔"]) + (":face_with_head_bandage:" ["🤕"]) + (":robot_face:" ["🤖"]) + (":hugging_face:" ["🤗"]) + (":the_horns:" ["🤘"]) + (":sign_of_the_horns:" ["🤘"]) + (":call_me_hand:" ["🤙"]) + (":raised_back_of_hand:" ["🤚"]) + (":left-facing_fist:" ["🤛"]) + (":right-facing_fist:" ["🤜"]) + (":handshake:" ["🤝"]) + (":crossed_fingers:" ["🤞"]) + (":hand_with_index_and_middle_fingers_crossed:" ["🤞"]) + (":i_love_you_hand_sign:" ["🤟"]) + (":face_with_cowboy_hat:" ["🤠"]) + (":clown_face:" ["🤡"]) + (":nauseated_face:" ["🤢"]) + (":rolling_on_the_floor_laughing:" ["🤣"]) + (":drooling_face:" ["🤤"]) + (":lying_face:" ["🤥"]) + (":woman-facepalming:" ["🤦♀️"]) + (":man-facepalming:" ["🤦♂️"]) + (":face_palm:" ["🤦"]) + (":sneezing_face:" ["🤧"]) + (":face_with_raised_eyebrow:" ["🤨"]) + (":face_with_one_eyebrow_raised:" ["🤨"]) + (":star-struck:" ["🤩"]) + (":grinning_face_with_star_eyes:" ["🤩"]) + (":zany_face:" ["🤪"]) + (":grinning_face_with_one_large_and_one_small_eye:" ["🤪"]) + (":shushing_face:" ["🤫"]) + (":face_with_finger_covering_closed_lips:" ["🤫"]) + (":face_with_symbols_on_mouth:" ["🤬"]) + (":serious_face_with_symbols_covering_mouth:" ["🤬"]) + (":face_with_hand_over_mouth:" ["🤭"]) + (":smiling_face_with_smiling_eyes_and_hand_covering_mouth:" ["🤭"]) + (":face_vomiting:" ["🤮"]) + (":face_with_open_mouth_vomiting:" ["🤮"]) + (":exploding_head:" ["🤯"]) + (":shocked_face_with_exploding_head:" ["🤯"]) + (":pregnant_woman:" ["🤰"]) + (":breast-feeding:" ["🤱"]) + (":palms_up_together:" ["🤲"]) + (":selfie:" ["🤳"]) + (":prince:" ["🤴"]) + (":woman_in_tuxedo:" ["🤵♀️"]) + (":man_in_tuxedo:" ["🤵♂️"]) + (":person_in_tuxedo:" ["🤵"]) + (":mrs_claus:" ["🤶"]) + (":mother_christmas:" ["🤶"]) + (":woman-shrugging:" ["🤷♀️"]) + (":man-shrugging:" ["🤷♂️"]) + (":shrug:" ["🤷"]) + (":woman-cartwheeling:" ["🤸♀️"]) + (":man-cartwheeling:" ["🤸♂️"]) + (":person_doing_cartwheel:" ["🤸"]) + (":woman-juggling:" ["🤹♀️"]) + (":man-juggling:" ["🤹♂️"]) + (":juggling:" ["🤹"]) + (":fencer:" ["🤺"]) + (":woman-wrestling:" ["🤼♀️"]) + (":man-wrestling:" ["🤼♂️"]) + (":wrestlers:" ["🤼"]) + (":woman-playing-water-polo:" ["🤽♀️"]) + (":man-playing-water-polo:" ["🤽♂️"]) + (":water_polo:" ["🤽"]) + (":woman-playing-handball:" ["🤾♀️"]) + (":man-playing-handball:" ["🤾♂️"]) + (":handball:" ["🤾"]) + (":diving_mask:" ["🤿"]) + (":wilted_flower:" ["🥀"]) + (":drum_with_drumsticks:" ["🥁"]) + (":clinking_glasses:" ["🥂"]) + (":tumbler_glass:" ["🥃"]) + (":spoon:" ["🥄"]) + (":goal_net:" ["🥅"]) + (":first_place_medal:" ["🥇"]) + (":second_place_medal:" ["🥈"]) + (":third_place_medal:" ["🥉"]) + (":boxing_glove:" ["🥊"]) + (":martial_arts_uniform:" ["🥋"]) + (":curling_stone:" ["🥌"]) + (":lacrosse:" ["🥍"]) + (":softball:" ["🥎"]) + (":flying_disc:" ["🥏"]) + (":croissant:" ["🥐"]) + (":avocado:" ["🥑"]) + (":cucumber:" ["🥒"]) + (":bacon:" ["🥓"]) + (":potato:" ["🥔"]) + (":carrot:" ["🥕"]) + (":baguette_bread:" ["🥖"]) + (":green_salad:" ["🥗"]) + (":shallow_pan_of_food:" ["🥘"]) + (":stuffed_flatbread:" ["🥙"]) + (":egg:" ["🥚"]) + (":glass_of_milk:" ["🥛"]) + (":peanuts:" ["🥜"]) + (":kiwifruit:" ["🥝"]) + (":pancakes:" ["🥞"]) + (":dumpling:" ["🥟"]) + (":fortune_cookie:" ["🥠"]) + (":takeout_box:" ["🥡"]) + (":chopsticks:" ["🥢"]) + (":bowl_with_spoon:" ["🥣"]) + (":cup_with_straw:" ["🥤"]) + (":coconut:" ["🥥"]) + (":broccoli:" ["🥦"]) + (":pie:" ["🥧"]) + (":pretzel:" ["🥨"]) + (":cut_of_meat:" ["🥩"]) + (":sandwich:" ["🥪"]) + (":canned_food:" ["🥫"]) + (":leafy_green:" ["🥬"]) + (":mango:" ["🥭"]) + (":moon_cake:" ["🥮"]) + (":bagel:" ["🥯"]) + (":smiling_face_with_3_hearts:" ["🥰"]) + (":yawning_face:" ["🥱"]) + (":smiling_face_with_tear:" ["🥲"]) + (":partying_face:" ["🥳"]) + (":woozy_face:" ["🥴"]) + (":hot_face:" ["🥵"]) + (":cold_face:" ["🥶"]) + (":ninja:" ["🥷"]) + (":disguised_face:" ["🥸"]) + (":pleading_face:" ["🥺"]) + (":sari:" ["🥻"]) + (":lab_coat:" ["🥼"]) + (":goggles:" ["🥽"]) + (":hiking_boot:" ["🥾"]) + (":womans_flat_shoe:" ["🥿"]) + (":crab:" ["🦀"]) + (":lion_face:" ["🦁"]) + (":scorpion:" ["🦂"]) + (":turkey:" ["🦃"]) + (":unicorn_face:" ["🦄"]) + (":eagle:" ["🦅"]) + (":duck:" ["🦆"]) + (":bat:" ["🦇"]) + (":shark:" ["🦈"]) + (":owl:" ["🦉"]) + (":fox_face:" ["🦊"]) + (":butterfly:" ["🦋"]) + (":deer:" ["🦌"]) + (":gorilla:" ["🦍"]) + (":lizard:" ["🦎"]) + (":rhinoceros:" ["🦏"]) + (":shrimp:" ["🦐"]) + (":squid:" ["🦑"]) + (":giraffe_face:" ["🦒"]) + (":zebra_face:" ["🦓"]) + (":hedgehog:" ["🦔"]) + (":sauropod:" ["🦕"]) + (":t-rex:" ["🦖"]) + (":cricket:" ["🦗"]) + (":kangaroo:" ["🦘"]) + (":llama:" ["🦙"]) + (":peacock:" ["🦚"]) + (":hippopotamus:" ["🦛"]) + (":parrot:" ["🦜"]) + (":raccoon:" ["🦝"]) + (":lobster:" ["🦞"]) + (":mosquito:" ["🦟"]) + (":microbe:" ["🦠"]) + (":badger:" ["🦡"]) + (":swan:" ["🦢"]) + (":mammoth:" ["🦣"]) + (":dodo:" ["🦤"]) + (":sloth:" ["🦥"]) + (":otter:" ["🦦"]) + (":orangutan:" ["🦧"]) + (":skunk:" ["🦨"]) + (":flamingo:" ["🦩"]) + (":oyster:" ["🦪"]) + (":beaver:" ["🦫"]) + (":bison:" ["🦬"]) + (":seal:" ["🦭"]) + (":guide_dog:" ["🦮"]) + (":probing_cane:" ["🦯"]) + (":bone:" ["🦴"]) + (":leg:" ["🦵"]) + (":foot:" ["🦶"]) + (":tooth:" ["🦷"]) + (":female_superhero:" ["🦸♀️"]) + (":male_superhero:" ["🦸♂️"]) + (":superhero:" ["🦸"]) + (":female_supervillain:" ["🦹♀️"]) + (":male_supervillain:" ["🦹♂️"]) + (":supervillain:" ["🦹"]) + (":safety_vest:" ["🦺"]) + (":ear_with_hearing_aid:" ["🦻"]) + (":motorized_wheelchair:" ["🦼"]) + (":manual_wheelchair:" ["🦽"]) + (":mechanical_arm:" ["🦾"]) + (":mechanical_leg:" ["🦿"]) + (":cheese_wedge:" ["🧀"]) + (":cupcake:" ["🧁"]) + (":salt:" ["🧂"]) + (":beverage_box:" ["🧃"]) + (":garlic:" ["🧄"]) + (":onion:" ["🧅"]) + (":falafel:" ["🧆"]) + (":waffle:" ["🧇"]) + (":butter:" ["🧈"]) + (":mate_drink:" ["🧉"]) + (":ice_cube:" ["🧊"]) + (":bubble_tea:" ["🧋"]) + (":woman_standing:" ["🧍♀️"]) + (":man_standing:" ["🧍♂️"]) + (":standing_person:" ["🧍"]) + (":woman_kneeling:" ["🧎♀️"]) + (":man_kneeling:" ["🧎♂️"]) + (":kneeling_person:" ["🧎"]) + (":deaf_woman:" ["🧏♀️"]) + (":deaf_man:" ["🧏♂️"]) + (":deaf_person:" ["🧏"]) + (":face_with_monocle:" ["🧐"]) + (":farmer:" ["🧑🌾"]) + (":cook:" ["🧑🍳"]) + (":person_feeding_baby:" ["🧑🍼"]) + (":mx_claus:" ["🧑🎄"]) + (":student:" ["🧑🎓"]) + (":singer:" ["🧑🎤"]) + (":artist:" ["🧑🎨"]) + (":teacher:" ["🧑🏫"]) + (":factory_worker:" ["🧑🏭"]) + (":technologist:" ["🧑💻"]) + (":office_worker:" ["🧑💼"]) + (":mechanic:" ["🧑🔧"]) + (":scientist:" ["🧑🔬"]) + (":astronaut:" ["🧑🚀"]) + (":firefighter:" ["🧑🚒"]) + (":people_holding_hands:" ["🧑🤝🧑"]) + (":person_with_probing_cane:" ["🧑🦯"]) + (":red_haired_person:" ["🧑🦰"]) + (":curly_haired_person:" ["🧑🦱"]) + (":bald_person:" ["🧑🦲"]) + (":white_haired_person:" ["🧑🦳"]) + (":person_in_motorized_wheelchair:" ["🧑🦼"]) + (":person_in_manual_wheelchair:" ["🧑🦽"]) + (":health_worker:" ["🧑⚕️"]) + (":judge:" ["🧑⚖️"]) + (":pilot:" ["🧑✈️"]) + (":adult:" ["🧑"]) + (":child:" ["🧒"]) + (":older_adult:" ["🧓"]) + (":woman_with_beard:" ["🧔♀️"]) + (":man_with_beard:" ["🧔♂️"]) + (":bearded_person:" ["🧔"]) + (":person_with_headscarf:" ["🧕"]) + (":woman_in_steamy_room:" ["🧖♀️"]) + (":man_in_steamy_room:" ["🧖♂️"]) + (":person_in_steamy_room:" ["🧖"]) + (":woman_climbing:" ["🧗♀️"]) + (":man_climbing:" ["🧗♂️"]) + (":person_climbing:" ["🧗"]) + (":woman_in_lotus_position:" ["🧘♀️"]) + (":man_in_lotus_position:" ["🧘♂️"]) + (":person_in_lotus_position:" ["🧘"]) + (":female_mage:" ["🧙♀️"]) + (":male_mage:" ["🧙♂️"]) + (":mage:" ["🧙"]) + (":female_fairy:" ["🧚♀️"]) + (":male_fairy:" ["🧚♂️"]) + (":fairy:" ["🧚"]) + (":female_vampire:" ["🧛♀️"]) + (":male_vampire:" ["🧛♂️"]) + (":vampire:" ["🧛"]) + (":mermaid:" ["🧜♀️"]) + (":merman:" ["🧜♂️"]) + (":merperson:" ["🧜"]) + (":female_elf:" ["🧝♀️"]) + (":male_elf:" ["🧝♂️"]) + (":elf:" ["🧝"]) + (":female_genie:" ["🧞♀️"]) + (":male_genie:" ["🧞♂️"]) + (":genie:" ["🧞"]) + (":female_zombie:" ["🧟♀️"]) + (":male_zombie:" ["🧟♂️"]) + (":zombie:" ["🧟"]) + (":brain:" ["🧠"]) + (":orange_heart:" ["🧡"]) + (":billed_cap:" ["🧢"]) + (":scarf:" ["🧣"]) + (":gloves:" ["🧤"]) + (":coat:" ["🧥"]) + (":socks:" ["🧦"]) + (":red_envelope:" ["🧧"]) + (":firecracker:" ["🧨"]) + (":jigsaw:" ["🧩"]) + (":test_tube:" ["🧪"]) + (":petri_dish:" ["🧫"]) + (":dna:" ["🧬"]) + (":compass:" ["🧭"]) + (":abacus:" ["🧮"]) + (":fire_extinguisher:" ["🧯"]) + (":toolbox:" ["🧰"]) + (":bricks:" ["🧱"]) + (":magnet:" ["🧲"]) + (":luggage:" ["🧳"]) + (":lotion_bottle:" ["🧴"]) + (":thread:" ["🧵"]) + (":yarn:" ["🧶"]) + (":safety_pin:" ["🧷"]) + (":teddy_bear:" ["🧸"]) + (":broom:" ["🧹"]) + (":basket:" ["🧺"]) + (":roll_of_paper:" ["🧻"]) + (":soap:" ["🧼"]) + (":sponge:" ["🧽"]) + (":receipt:" ["🧾"]) + (":nazar_amulet:" ["🧿"]) + (":ballet_shoes:" ["🩰"]) + (":one-piece_swimsuit:" ["🩱"]) + (":briefs:" ["🩲"]) + (":shorts:" ["🩳"]) + (":thong_sandal:" ["🩴"]) + (":drop_of_blood:" ["🩸"]) + (":adhesive_bandage:" ["🩹"]) + (":stethoscope:" ["🩺"]) + (":yo-yo:" ["🪀"]) + (":kite:" ["🪁"]) + (":parachute:" ["🪂"]) + (":boomerang:" ["🪃"]) + (":magic_wand:" ["🪄"]) + (":pinata:" ["🪅"]) + (":nesting_dolls:" ["🪆"]) + (":ringed_planet:" ["🪐"]) + (":chair:" ["🪑"]) + (":razor:" ["🪒"]) + (":axe:" ["🪓"]) + (":diya_lamp:" ["🪔"]) + (":banjo:" ["🪕"]) + (":military_helmet:" ["🪖"]) + (":accordion:" ["🪗"]) + (":long_drum:" ["🪘"]) + (":coin:" ["🪙"]) + (":carpentry_saw:" ["🪚"]) + (":screwdriver:" ["🪛"]) + (":ladder:" ["🪜"]) + (":hook:" ["🪝"]) + (":mirror:" ["🪞"]) + (":window:" ["🪟"]) + (":plunger:" ["🪠"]) + (":sewing_needle:" ["🪡"]) + (":knot:" ["🪢"]) + (":bucket:" ["🪣"]) + (":mouse_trap:" ["🪤"]) + (":toothbrush:" ["🪥"]) + (":headstone:" ["🪦"]) + (":placard:" ["🪧"]) + (":rock:" ["🪨"]) + (":fly:" ["🪰"]) + (":worm:" ["🪱"]) + (":beetle:" ["🪲"]) + (":cockroach:" ["🪳"]) + (":potted_plant:" ["🪴"]) + (":wood:" ["🪵"]) + (":feather:" ["🪶"]) + (":anatomical_heart:" ["🫀"]) + (":lungs:" ["🫁"]) + (":people_hugging:" ["🫂"]) + (":blueberries:" ["🫐"]) + (":bell_pepper:" ["🫑"]) + (":olive:" ["🫒"]) + (":flatbread:" ["🫓"]) + (":tamale:" ["🫔"]) + (":fondue:" ["🫕"]) + (":teapot:" ["🫖"]) + (":bangbang:" ["‼️"]) + (":interrobang:" ["⁉️"]) + (":tm:" ["™️"]) + (":information_source:" ["ℹ️"]) + (":left_right_arrow:" ["↔️"]) + (":arrow_up_down:" ["↕️"]) + (":arrow_upper_left:" ["↖️"]) + (":arrow_upper_right:" ["↗️"]) + (":arrow_lower_right:" ["↘️"]) + (":arrow_lower_left:" ["↙️"]) + (":leftwards_arrow_with_hook:" ["↩️"]) + (":arrow_right_hook:" ["↪️"]) + (":watch:" ["⌚"]) + (":hourglass:" ["⌛"]) + (":keyboard:" ["⌨️"]) + (":eject:" ["⏏️"]) + (":fast_forward:" ["⏩"]) + (":rewind:" ["⏪"]) + (":arrow_double_up:" ["⏫"]) + (":arrow_double_down:" ["⏬"]) + (":black_right_pointing_double_triangle_with_vertical_bar:" ["⏭️"]) + (":black_left_pointing_double_triangle_with_vertical_bar:" ["⏮️"]) + (":black_right_pointing_triangle_with_double_vertical_bar:" ["⏯️"]) + (":alarm_clock:" ["⏰"]) + (":stopwatch:" ["⏱️"]) + (":timer_clock:" ["⏲️"]) + (":hourglass_flowing_sand:" ["⏳"]) + (":double_vertical_bar:" ["⏸️"]) + (":black_square_for_stop:" ["⏹️"]) + (":black_circle_for_record:" ["⏺️"]) + (":m:" ["Ⓜ️"]) + (":black_small_square:" ["▪️"]) + (":white_small_square:" ["▫️"]) + (":arrow_forward:" ["▶️"]) + (":arrow_backward:" ["◀️"]) + (":white_medium_square:" ["◻️"]) + (":black_medium_square:" ["◼️"]) + (":white_medium_small_square:" ["◽"]) + (":black_medium_small_square:" ["◾"]) + (":sunny:" ["☀️"]) + (":cloud:" ["☁️"]) + (":umbrella:" ["☂️"]) + (":snowman:" ["☃️"]) + (":comet:" ["☄️"]) + (":phone:" ["☎️"]) + (":telephone:" ["☎️"]) + (":ballot_box_with_check:" ["☑️"]) + (":umbrella_with_rain_drops:" ["☔"]) + (":coffee:" ["☕"]) + (":shamrock:" ["☘️"]) + (":point_up:" ["☝️"]) + (":skull_and_crossbones:" ["☠️"]) + (":radioactive_sign:" ["☢️"]) + (":biohazard_sign:" ["☣️"]) + (":orthodox_cross:" ["☦️"]) + (":star_and_crescent:" ["☪️"]) + (":peace_symbol:" ["☮️"]) + (":yin_yang:" ["☯️"]) + (":wheel_of_dharma:" ["☸️"]) + (":white_frowning_face:" ["☹️"]) + (":relaxed:" ["☺️"]) + (":female_sign:" ["♀️"]) + (":male_sign:" ["♂️"]) + (":aries:" ["♈"]) + (":taurus:" ["♉"]) + (":gemini:" ["♊"]) + (":cancer:" ["♋"]) + (":leo:" ["♌"]) + (":virgo:" ["♍"]) + (":libra:" ["♎"]) + (":scorpius:" ["♏"]) + (":sagittarius:" ["♐"]) + (":capricorn:" ["♑"]) + (":aquarius:" ["♒"]) + (":pisces:" ["♓"]) + (":chess_pawn:" ["♟️"]) + (":spades:" ["♠️"]) + (":clubs:" ["♣️"]) + (":hearts:" ["♥️"]) + (":diamonds:" ["♦️"]) + (":hotsprings:" ["♨️"]) + (":recycle:" ["♻️"]) + (":infinity:" ["♾️"]) + (":wheelchair:" ["♿"]) + (":hammer_and_pick:" ["⚒️"]) + (":anchor:" ["⚓"]) + (":crossed_swords:" ["⚔️"]) + (":medical_symbol:" ["⚕️"]) + (":staff_of_aesculapius:" ["⚕️"]) + (":scales:" ["⚖️"]) + (":alembic:" ["⚗️"]) + (":gear:" ["⚙️"]) + (":atom_symbol:" ["⚛️"]) + (":fleur_de_lis:" ["⚜️"]) + (":warning:" ["⚠️"]) + (":zap:" ["⚡"]) + (":transgender_symbol:" ["⚧️"]) + (":white_circle:" ["⚪"]) + (":black_circle:" ["⚫"]) + (":coffin:" ["⚰️"]) + (":funeral_urn:" ["⚱️"]) + (":soccer:" ["⚽"]) + (":baseball:" ["⚾"]) + (":snowman_without_snow:" ["⛄"]) + (":partly_sunny:" ["⛅"]) + (":thunder_cloud_and_rain:" ["⛈️"]) + (":ophiuchus:" ["⛎"]) + (":pick:" ["⛏️"]) + (":helmet_with_white_cross:" ["⛑️"]) + (":chains:" ["⛓️"]) + (":no_entry:" ["⛔"]) + (":shinto_shrine:" ["⛩️"]) + (":church:" ["⛪"]) + (":mountain:" ["⛰️"]) + (":umbrella_on_ground:" ["⛱️"]) + (":fountain:" ["⛲"]) + (":golf:" ["⛳"]) + (":ferry:" ["⛴️"]) + (":boat:" ["⛵"]) + (":sailboat:" ["⛵"]) + (":skier:" ["⛷️"]) + (":ice_skate:" ["⛸️"]) + (":woman-bouncing-ball:" ["⛹️♀️"]) + (":man-bouncing-ball:" ["⛹️♂️"]) + (":person_with_ball:" ["⛹️"]) + (":tent:" ["⛺"]) + (":fuelpump:" ["⛽"]) + (":scissors:" ["✂️"]) + (":white_check_mark:" ["✅"]) + (":airplane:" ["✈️"]) + (":email:" ["✉️"]) + (":envelope:" ["✉️"]) + (":fist:" ["✊"]) + (":hand:" ["✋"]) + (":raised_hand:" ["✋"]) + (":v:" ["✌️"]) + (":writing_hand:" ["✍️"]) + (":pencil2:" ["✏️"]) + (":black_nib:" ["✒️"]) + (":heavy_check_mark:" ["✔️"]) + (":heavy_multiplication_x:" ["✖️"]) + (":latin_cross:" ["✝️"]) + (":star_of_david:" ["✡️"]) + (":sparkles:" ["✨"]) + (":eight_spoked_asterisk:" ["✳️"]) + (":eight_pointed_black_star:" ["✴️"]) + (":snowflake:" ["❄️"]) + (":sparkle:" ["❇️"]) + (":x:" ["❌"]) + (":negative_squared_cross_mark:" ["❎"]) + (":question:" ["❓"]) + (":grey_question:" ["❔"]) + (":grey_exclamation:" ["❕"]) + (":exclamation:" ["❗"]) + (":heavy_exclamation_mark:" ["❗"]) + (":heavy_heart_exclamation_mark_ornament:" ["❣️"]) + (":heart_on_fire:" ["❤️🔥"]) + (":mending_heart:" ["❤️🩹"]) + (":heart:" ["❤️"]) + ("<3" ["❤️"]) + (":heavy_plus_sign:" ["➕"]) + (":heavy_minus_sign:" ["➖"]) + (":heavy_division_sign:" ["➗"]) + (":arrow_right:" ["➡️"]) + (":curly_loop:" ["➰"]) + (":loop:" ["➿"]) + (":arrow_heading_up:" ["⤴️"]) + (":arrow_heading_down:" ["⤵️"]) + (":arrow_left:" ["⬅️"]) + (":arrow_up:" ["⬆️"]) + (":arrow_down:" ["⬇️"]) + (":black_large_square:" ["⬛"]) + (":white_large_square:" ["⬜"]) + (":star:" ["⭐"]) + (":o:" ["⭕"]) + (":wavy_dash:" ["〰️"]) + (":part_alternation_mark:" ["〽️"]) + (":congratulations:" ["㊗️"]) + (":secret:" ["㊙️"]))))))) + +(emoji--define-rules) + +(provide 'emoji) +;;; emoji.el ends here diff --git a/lisp/leim/quail/hangul.el b/lisp/leim/quail/hangul.el index 39e83f6c331..0ef5b2d5c72 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/indian.el b/lisp/leim/quail/indian.el index 23204c0cd3e..6a3582e83d0 100644 --- a/lisp/leim/quail/indian.el +++ b/lisp/leim/quail/indian.el @@ -171,7 +171,7 @@ clm) (with-temp-buffer (insert "\n") - (insert " +") + (insert "----+") (insert-char ?- 74) (insert "\n |") (setq clm 6) @@ -244,19 +244,27 @@ (insert "\n") (buffer-string)))) -(defvar quail-tamil-itrans-various-signs-and-digits-table +(defun quail-tamil-itrans-compute-signs-table (digitp) + "Compute the signs table for the tamil-itrans input method. +If DIGITP is non-nil, include the digits translation as well." (let ((various '((?ஃ . "H") ("ஸ்ரீ" . "srii") (?ௐ))) (digits "௦௧௨௩௪௫௬௭௮௯") (width 6) clm) (with-temp-buffer - (insert "\n" (make-string 18 ?-) "+" (make-string 60 ?-) "\n") + (insert "\n" (make-string 18 ?-) "+") + (when digitp (insert (make-string 60 ?-))) + (insert "\n") (insert (propertize "\t" 'display '(space :align-to 5)) "various" - (propertize "\t" 'display '(space :align-to 18)) "|" - (propertize "\t" 'display '(space :align-to 45)) "digits") - - (insert "\n" (make-string 18 ?-) "+" (make-string 60 ?-) "\n") - (setq clm 0 ) + (propertize "\t" 'display '(space :align-to 18)) "|") + (when digitp + (insert + (propertize "\t" 'display '(space :align-to 45)) "digits")) + (insert "\n" (make-string 18 ?-) "+") + (when digitp + (insert (make-string 60 ?-))) + (insert "\n") + (setq clm 0) (dotimes (i (length various)) (insert (propertize "\t" 'display (list 'space :align-to clm)) @@ -264,10 +272,11 @@ (setq clm (+ clm width))) (insert (propertize "\t" 'display '(space :align-to 18)) "|") (setq clm 20) - (dotimes (i 10) - (insert (propertize "\t" 'display (list 'space :align-to clm)) - (aref digits i)) - (setq clm (+ clm width))) + (when digitp + (dotimes (i 10) + (insert (propertize "\t" 'display (list 'space :align-to clm)) + (aref digits i)) + (setq clm (+ clm width)))) (insert "\n") (setq clm 0) (dotimes (i (length various)) @@ -276,13 +285,22 @@ (setq clm (+ clm width))) (insert (propertize "\t" 'display '(space :align-to 18)) "|") (setq clm 20) - (dotimes (i 10) - (insert (propertize "\t" 'display (list 'space :align-to clm)) - (format "%d" i)) - (setq clm (+ clm width))) - (insert "\n" (make-string 18 ?-) "+" (make-string 60 ?-) "\n") + (when digitp + (dotimes (i 10) + (insert (propertize "\t" 'display (list 'space :align-to clm)) + (format "%d" i)) + (setq clm (+ clm width)))) + (insert "\n" (make-string 18 ?-) "+") + (when digitp + (insert (make-string 60 ?-) "\n")) (buffer-string)))) +(defvar quail-tamil-itrans-various-signs-and-digits-table + (quail-tamil-itrans-compute-signs-table t)) + +(defvar quail-tamil-itrans-various-signs-table + (quail-tamil-itrans-compute-signs-table nil)) + (if nil (quail-define-package "tamil-itrans" "Tamil" "TmlIT" t "Tamil ITRANS")) (quail-define-indian-trans-package @@ -293,16 +311,39 @@ You can input characters using the following mapping tables. Example: To enter வணக்கம், type vaNakkam. ### Basic syllables (consonants + vowels) ### -\\<quail-tamil-itrans-syllable-table> +\\=\\<quail-tamil-itrans-syllable-table> + +### Miscellaneous (various signs) ### +\\=\\<quail-tamil-itrans-various-signs-table> + +### Others (numerics + symbols) ### + +Characters below have no ITRANS method associated with them. +Their descriptions are included for easy reference. +\\=\\<quail-tamil-itrans-numerics-and-symbols-table> + +Full key sequences are listed below:") + +(if nil + (quail-define-package "tamil-itrans-digits" "Tamil" "TmlITD" t "Tamil ITRANS with digits")) +(quail-define-indian-trans-package + indian-tml-itrans-digits-v5-hash "tamil-itrans-digits" "Tamil" "TmlITD" + "Tamil transliteration by ITRANS method with Tamil digits support. + +You can input characters using the following mapping tables. + Example: To enter வணக்கம், type vaNakkam. + +### Basic syllables (consonants + vowels) ### +\\=\\<quail-tamil-itrans-syllable-table> ### Miscellaneous (various signs + digits) ### -\\<quail-tamil-itrans-various-signs-and-digits-table> +\\=\\<quail-tamil-itrans-various-signs-and-digits-table> ### Others (numerics + symbols) ### Characters below have no ITRANS method associated with them. Their descriptions are included for easy reference. -\\<quail-tamil-itrans-numerics-and-symbols-table> +\\=\\<quail-tamil-itrans-numerics-and-symbols-table> Full key sequences are listed below:") @@ -479,6 +520,13 @@ Full key sequences are listed below:") "tamil-inscript" "Tamil" "TmlIS" "Tamil keyboard Inscript.") +(if nil + (quail-define-package "tamil-inscript-digits" "Tamil" "TmlISD" t "Tamil keyboard Inscript with digits.")) +(quail-define-inscript-package + indian-tml-base-digits-table inscript-tml-keytable + "tamil-inscript-digits" "Tamil" "TmlISD" + "Tamil keyboard Inscript with Tamil digits support.") + ;; Probhat Input Method (quail-define-package "bengali-probhat" "Bengali" "BngPB" t @@ -648,4 +696,1079 @@ Full key sequences are listed below:") (quail-defrule "|" ?) (quail-defrule "||" ?) +(quail-define-package + "brahmi" "Brahmi" "𑀲" t "Brahmi phonetic input method. + + `\\=`' is used to switch levels instead of Alt-Gr. +" nil t t t t nil nil nil nil nil t) + +(quail-define-rules + ("``" ?₹) + ("1" ?𑁧) + ("`1" ?1) + ("`!" ?𑁒) + ("2" ?𑁨) + ("`2" ?2) + ("`@" ?𑁓) + ("3" ?𑁩) + ("`3" ?3) + ("`#" ?𑁔) + ("4" ?𑁪) + ("`4" ?4) + ("`$" ?𑁕) + ("5" ?𑁫) + ("`5" ?5) + ("`%" ?𑁖) + ("6" ?𑁬) + ("`6" ?6) + ("`^" ?𑁗) + ("7" ?𑁭) + ("`7" ?7) + ("`&" ?𑁘) + ("8" ?𑁮) + ("`8" ?8) + ("`*" ?𑁙) + ("9" ?𑁯) + ("`9" ?9) + ("`(" ?𑁚) + ("0" ?𑁦) + ("`0" ?0) + ("`)" ?𑁛) + ("`-" ?𑁜) + ("`_" ?𑁝) + ("`=" ?𑁞) + ("`+" ?𑁟) + ("`\\" ?𑁇) + ("`|" ?𑁈) + ("`" ?𑀝) + ("q" ?𑀝) + ("Q" ?𑀞) + ("`q" ?𑀃) + ("`Q" ?𑁠) + ("w" ?𑀟) + ("W" ?𑀠) + ("`w" ?𑀄) + ("`W" ?𑁡) + ("e" ?𑁂) + ("E" ?𑁃) + ("`e" ?𑀏) + ("`E" ?𑀐) + ("r" ?𑀭) + ("R" ?𑀾) + ("`r" ?𑀋) + ("`R" ?𑀶) + ("t" ?𑀢) + ("T" ?𑀣) + ("`t" ?𑁢) + ("y" ?𑀬) + ("Y" ?𑁣) + ("`y" ?𑁤) + ("`Y" ?𑁥) + ("u" ?𑀼) + ("U" ?𑀽) + ("`u" ?𑀉) + ("`U" ?𑀊) + ("i" ?𑀺) + ("I" ?𑀻) + ("`i" ?𑀇) + ("`I" ?𑀈) + ("o" ?𑁄) + ("O" ?𑁅) + ("`o" ?𑀑) + ("`O" ?𑀒) + ("p" ?𑀧) + ("P" ?𑀨) + ("`p" ?𑁳) + ("`P" ?𑁱) + ("`[" ?𑁴) + ("`{" ?𑁲) + ("a" ?𑀸) + ("A" ?𑀆) + ("`a" ?𑀅) + ("`A" ?𑀹) + ("s" ?𑀲) + ("S" ?𑀰) + ("`s" ?𑀱) + ("d" ?𑀤) + ("D" ?𑀥) + ("`d" ?𑀶) + ("f" ?𑁆) + ("F" ?𑀿) + ("`f" ?𑀌) + ("`F" ?𑁰) + ("g" ?𑀕) + ("G" ?𑀖) + ("h" ?𑀳) + ("H" ?𑀂) + ("j" ?𑀚) + ("J" ?𑀛) + ("k" ?𑀓) + ("K" ?𑀔) + ("l" ?𑀮) + ("L" ?𑀴) + ("`l" ?𑀵) + ("`L" ?𑁵) + ("z" ?𑁀) + ("Z" ?𑀍) + ("`z" ?𑁁) + ("`Z" ?𑀎) + ("x" ?𑁉) + ("X" ?𑁊) + ("`x" ?𑁋) + ("`X" ?𑁌) + ("c" ?𑀘) + ("C" ?𑀙) + ("`c" #x200C) ; ZWNJ + ("`C" #x200D) ; ZWJ + ("v" ?𑀯) + ("V" ?𑀷) + ("b" ?𑀩) + ("B" ?𑀪) + ("n" ?𑀦) + ("N" ?𑀡) + ("`n" ?𑀗) + ("`N" ?𑀜) + ("m" ?𑀫) + ("M" ?𑀁) + ("`m" ?𑀀) + ("<" ?𑁍) + ("`/" ?𑁿) + ) + +(quail-define-package + "kaithi" "Kaithi" "𑂍𑂶" t "Kaithi phonetic input method. + + `\\=`' is used to switch levels instead of Alt-Gr. +" nil t t t t nil nil nil nil nil t) + +(quail-define-rules +("``" ?₹) +("1" ?१) +("`1" ?1) +("2" ?२) +("`2" ?2) +("3" ?३) +("`3" ?3) +("4" ?४) +("`4" ?4) +("5" ?५) +("`5" ?5) +("6" ?६) +("`6" ?6) +("7" ?७) +("`7" ?7) +("8" ?८) +("`8" ?8) +("9" ?९) +("`9" ?9) +("0" ?०) +("`0" ?0) +("`)" ?𑂻) +("`\\" ?𑃀) +("`|" ?𑃁) +("`" ?𑂗) +("q" ?𑂗) +("Q" ?𑂘) +("w" ?𑂙) +("W" ?𑂛) +("`w" ?𑂚) +("`W" ?𑂜) +("e" ?𑂵) +("E" ?𑂶) +("`e" ?𑂉) +("`E" ?𑂊) +("r" ?𑂩) +("R" ?𑃂) +("t" ?𑂞) +("T" ?𑂟) +("y" ?𑂨) +("Y" ?⸱) +("u" ?𑂳) +("U" ?𑂴) +("`u" ?𑂇) +("`U" ?𑂈) +("i" ?𑂱) +("I" ?𑂲) +("`i" ?𑂅) +("`I" ?𑂆) +("o" ?𑂷) +("O" ?𑂸) +("`o" ?𑂋) +("`O" ?𑂌) +("p" ?𑂣) +("P" ?𑂤) +("a" ?𑂰) +("A" ?𑂄) +("`a" ?𑂃) +("s" ?𑂮) +("S" ?𑂬) +("d" ?𑂠) +("D" ?𑂡) +("`d" ?𑂼) +("`D" #x110BD) ; Kaithi Number Sign +("f" ?𑂹) +("F" #x110CD) ; Kaithi Number Sign Above +("`f" ?𑂾) +("`F" ?𑂿) +("g" ?𑂏) +("G" ?𑂐) +("h" ?𑂯) +("H" ?𑂂) +("j" ?𑂔) +("J" ?𑂕) +("k" ?𑂍) +("K" ?𑂎) +("l" ?𑂪) +("z" ?𑂖) +("Z" ?𑂑) +("x" ?𑂭) +("X" ?𑂺) +("c" ?𑂒) +("C" ?𑂓) +("`c" #x200C) ; ZWNJ +("`C" #x200D) ; ZWJ +("v" ?𑂫) +("b" ?𑂥) +("B" ?𑂦) +("n" ?𑂢) +("N" ?𑂝) +("m" ?𑂧) +("M" ?𑂁) +("`m" ?𑂀) +) + +(quail-define-package + "tirhuta" "Tirhuta" "𑒞𑒱" t "Tirhuta phonetic input method. + + `\\=`' is used to switch levels instead of Alt-Gr. +" nil t t t t nil nil nil nil nil t) + +(quail-define-rules +("``" ?₹) +("1" ?𑓑) +("`1" ?1) +("2" ?𑓒) +("`2" ?2) +("3" ?𑓓) +("`3" ?3) +("4" ?𑓔) +("`4" ?4) +("5" ?𑓕) +("`5" ?5) +("6" ?𑓖) +("`6" ?6) +("7" ?𑓗) +("`7" ?7) +("8" ?𑓘) +("`8" ?8) +("9" ?𑓙) +("`9" ?9) +("0" ?𑓐) +("`0" ?0) +("`)" ?𑓆) +("`\\" ?।) +("`|" ?॥) +("`" ?𑒙) +("q" ?𑒙) +("Q" ?𑒚) +("w" ?𑒛) +("W" ?𑒜) +("e" ?𑒺) +("E" ?𑒹) +("`e" ?𑒋) +("r" ?𑒩) +("R" ?𑒵) +("`r" ?𑒇) +("t" ?𑒞) +("T" ?𑒟) +("y" ?𑒨) +("Y" ?𑒻) +("`y" ?𑒌) +("u" ?𑒳) +("U" ?𑒴) +("`u" ?𑒅) +("`U" ?𑒆) +("i" ?𑒱) +("I" ?𑒲) +("`i" ?𑒃) +("`I" ?𑒄) +("o" ?𑒽) +("O" ?𑒼) +("`o" ?𑒍) +("p" ?𑒣) +("P" ?𑒤) +("a" ?𑒰) +("A" ?𑒂) +("`a" ?𑒁) +("s" ?𑒮) +("S" ?𑒬) +("d" ?𑒠) +("D" ?𑒡) +("f" ?𑓂) +("F" ?𑒶) +("`f" ?𑒈) +("g" ?𑒑) +("G" ?𑒒) +("h" ?𑒯) +("H" ?𑓁) +("j" ?𑒖) +("J" ?𑒗) +("k" ?𑒏) +("K" ?𑒐) +("l" ?𑒪) +("L" ?𑒷) +("`l" ?𑒉) +("z" ?𑒘) +("Z" ?𑒓) +("`z" ?𑒸) +("`Z" ?𑒊) +("x" ?𑒭) +("X" ?𑓃) +("c" ?𑒔) +("C" ?𑒕) +("`c" #x200C) ; ZWNJ +("v" ?𑒫) +("V" ?𑒾) +("`v" ?𑒎) +("b" ?𑒥) +("B" ?𑒦) +("`b" ?𑒀) +("`B" ?𑓄) +("n" ?𑒢) +("N" ?𑒝) +("`n" ?𑓇) +("`N" ?𑓅) +("m" ?𑒧) +("M" ?𑓀) +("`m" ?𑒿) +) + +(quail-define-package + "sharada" "Sharada" "𑆯𑆳" t "Sharada phonetic input method. + + `\\=`' is used to switch levels instead of Alt-Gr. +" nil t t t t nil nil nil nil nil t) + +(quail-define-rules +("``" ?₹) +("1" ?𑇑) +("`1" ?1) +("2" ?𑇒) +("`2" ?2) +("3" ?𑇓) +("`3" ?3) +("4" ?𑇔) +("`4" ?4) +("5" ?𑇕) +("`5" ?5) +("6" ?𑇖) +("`6" ?6) +("7" ?𑇗) +("`7" ?7) +("8" ?𑇘) +("`8" ?8) +("9" ?𑇙) +("`9" ?9) +("0" ?𑇐) +("`0" ?0) +("`)" ?𑇇) +("`\\" ?𑇅) +("`|" ?𑇆) +("`" ?𑆛) +("q" ?𑆛) +("Q" ?𑆜) +("`q" ?𑇈) +("`Q" ?𑇉) +("w" ?𑆝) +("W" ?𑆞) +("`w" ?𑇋) +("`W" ?𑇍) +("e" ?𑆼) +("E" ?𑆽) +("`e" ?𑆍) +("`E" ?𑆎) +("r" ?𑆫) +("R" ?𑆸) +("`r" ?𑆉) +("`R" ?𑇎) +("t" ?𑆠) +("T" ?𑆡) +("y" ?𑆪) +("u" ?𑆶) +("U" ?𑆷) +("`u" ?𑆇) +("`U" ?𑆈) +("i" ?𑆴) +("I" ?𑆵) +("`i" ?𑆅) +("`I" ?𑆆) +("o" ?𑆾) +("O" ?𑆿) +("`o" ?𑆏) +("`O" ?𑆐) +("p" ?𑆥) +("P" ?𑆦) +("`p" ?𑇃) +("a" ?𑆳) +("A" ?𑆄) +("`a" ?𑆃) +("s" ?𑆱) +("S" ?𑆯) +("d" ?𑆢) +("D" ?𑆣) +("`d" ?𑇚) +("`D" ?𑇛) +("f" ?𑇀) +("F" ?𑆹) +("`f" ?𑆊) +("`F" ?𑇌) +("g" ?𑆓) +("G" ?𑆔) +("`g" ?𑇜) +("`G" ?𑇝) +("h" ?𑆲) +("H" ?𑆂) +("`h" ?𑇞) +("`H" ?𑇟) +("j" ?𑆘) +("J" ?𑆙) +("`j" ?᳘) +("`J" ?᳕) +("k" ?𑆑) +("K" ?𑆒) +("`k" ?𑇂) +("l" ?𑆬) +("L" ?𑆭) +("`l" ?𑆺) +("`L" ?𑆋) +("z" ?𑆚) +("Z" ?𑆕) +("`z" ?𑆻) +("`Z" ?𑆌) +("x" ?𑆰) +("X" ?𑇊) +("c" ?𑆖) +("C" ?𑆗) +("`c" #x200C) ; ZWNJ +("v" ?𑆮) +("b" ?𑆧) +("B" ?𑆨) +("n" ?𑆤) +("N" ?𑆟) +("`n" ?𑇄) +("`N" ?𑇁) +("m" ?𑆩) +("M" ?𑆁) +("`m" ?𑆀) +("`M" ?𑇏) +) + +(quail-define-package + "siddham" "Sharada" "𑖭𑖰" t "Siddham phonetic input method. + + `\\=`' is used to switch levels instead of Alt-Gr. +" nil t t t t nil nil nil nil nil t) + +(quail-define-rules +("``" ?₹) +("`1" ?𑗊) +("`!" ?𑗔) +("`2" ?𑗋) +("`@" ?𑗕) +("`3" ?𑗌) +("`#" ?𑗖) +("`4" ?𑗍) +("`$" ?𑗗) +("`5" ?𑗎) +("`%" ?𑗅) +("`6" ?𑗏) +("`^" ?𑗆) +("`7" ?𑗐) +("`&" ?𑗇) +("`8" ?𑗑) +("`*" ?𑗈) +("`9" ?𑗒) +("`(" ?𑗉) +("`0" ?𑗓) +("`)" ?𑗄) +("`\\" ?𑗂) +("`|" ?𑗃) +("`" ?𑖘) +("q" ?𑖘) +("Q" ?𑖙) +("`q" ?𑗘) +("`Q" ?𑗙) +("w" ?𑖚) +("W" ?𑖛) +("`w" ?𑗚) +("`W" ?𑗛) +("e" ?𑖸) +("E" ?𑖹) +("`e" ?𑖊) +("`E" ?𑖋) +("r" ?𑖨) +("R" ?𑖴) +("`r" ?𑖆) +("t" ?𑖝) +("T" ?𑖞) +("`t" ?𑗜) +("`T" ?𑗝) +("y" ?𑖧) +("u" ?𑖲) +("U" ?𑖳) +("`u" ?𑖄) +("`U" ?𑖅) +("i" ?𑖰) +("I" ?𑖱) +("`i" ?𑖂) +("`I" ?𑖃) +("o" ?𑖺) +("O" ?𑖻) +("`o" ?𑖌) +("`O" ?𑖍) +("p" ?𑖢) +("P" ?𑖣) +("a" ?𑖯) +("A" ?𑖁) +("`a" ?𑖀) +("s" ?𑖭) +("S" ?𑖫) +("d" ?𑖟) +("D" ?𑖠) +("`d" ?𑗁) +("f" ?𑖿) +("F" ?𑖵) +("`f" ?𑖇) +("g" ?𑖐) +("G" ?𑖑) +("h" ?𑖮) +("H" ?𑖾) +("j" ?𑖕) +("J" ?𑖖) +("k" ?𑖎) +("K" ?𑖏) +("l" ?𑖩) +("L" ?𑖈) +("`l" ?𑖉) +("z" ?𑖗) +("Z" ?𑖒) +("x" ?𑖬) +("X" ?𑗀) +("c" ?𑖓) +("C" ?𑖔) +("`c" #x200C) ; ZWNJ +("v" ?𑖪) +("b" ?𑖤) +("B" ?𑖥) +("n" ?𑖡) +("N" ?𑖜) +("m" ?𑖦) +("M" ?𑖽) +("`m" ?𑖼) +) + + +(quail-define-package + "syloti-nagri" "Syloti Nagri" "ꠍꠤ" t "Syloti Nagri phonetic input method. + + `\\=`' is used to switch levels instead of Alt-Gr. +" nil t t t t nil nil nil nil nil t) + +(quail-define-rules +("``" ?₹) +("`~" ?৳) +("1" ?১) +("`1" ?1) +("2" ?২) +("`2" ?2) +("3" ?৩) +("`3" ?3) +("4" ?৪) +("`4" ?4) +("5" ?৫) +("`5" ?5) +("6" ?৬) +("`6" ?6) +("7" ?৭) +("`7" ?7) +("8" ?৮) +("`8" ?8) +("9" ?৯) +("`9" ?9) +("0" ?০) +("`0" ?0) +("`\\" ?𑇅) +("`|" ?𑇆) +("`" ?ꠐ) +("q" ?ꠐ) +("Q" ?ꠑ) +("`q" ?꠨) +("`Q" ?꠩) +("w" ?ꠒ) +("W" ?ꠓ) +("`w" ?꠪) +("`W" ?꠫) +("e" ?ꠦ) +("E" ?ꠄ) +("r" ?ꠞ) +("R" ?ꠠ) +("t" ?ꠔ) +("T" ?ꠕ) +("y" ?ꠂ) +("u" ?ꠥ) +("U" ?ꠃ) +("i" ?ꠤ) +("I" ?ꠁ) +("o" ?ꠧ) +("O" ?ꠅ) +("p" ?ꠙ) +("P" ?ꠚ) +("a" ?ꠣ) +("A" ?ꠀ) +("s" ?ꠡ) +("d" ?ꠖ) +("D" ?ꠗ) +("f" ?꠆) +("F" ?꠬) +("g" ?ꠉ) +("G" ?ꠊ) +("h" ?ꠢ) +("j" ?ꠎ) +("J" ?ꠏ) +("k" ?ꠇ) +("K" ?ꠈ) +("l" ?ꠟ) +("c" ?ꠌ) +("C" ?ꠍ) +("`c" #x200C) ; ZWNJ +("b" ?ꠛ) +("B" ?ꠜ) +("n" ?ꠘ) +("m" ?ꠝ) +("M" ?ꠋ) +) + +(quail-define-package + "modi" "Modi" "𑘦𑘻" t "Modi phonetic input method. + + `\\=`' is used to switch levels instead of Alt-Gr. +" nil t t t t nil nil nil nil nil t) + +(quail-define-rules +("``" ?₹) +("1" ?𑙑) +("`1" ?1) +("2" ?𑙒) +("`2" ?2) +("3" ?𑙓) +("`3" ?3) +("4" ?𑙔) +("`4" ?4) +("5" ?𑙕) +("`5" ?5) +("6" ?𑙖) +("`6" ?6) +("7" ?𑙗) +("`7" ?7) +("8" ?𑙘) +("`8" ?8) +("9" ?𑙙) +("`9" ?9) +("0" ?𑙐) +("`0" ?0) +("`)" ?𑙃) +("`\\" ?𑙁) +("`|" ?𑙂) +("`" ?𑘘) +("q" ?𑘘) +("Q" ?𑘙) +("`q" ?𑙄) +("w" ?𑘚) +("W" ?𑘛) +("e" ?𑘹) +("E" ?𑘺) +("`e" ?𑘊) +("`E" ?𑘋) +("r" ?𑘨) +("R" ?𑘵) +("`r" ?𑘆) +("t" ?𑘝) +("T" ?𑘞) +("y" ?𑘧) +("u" ?𑘳) +("U" ?𑘴) +("`u" ?𑘄) +("`U" ?𑘅) +("i" ?𑘱) +("I" ?𑘲) +("`i" ?𑘂) +("`I" ?𑘃) +("o" ?𑘻) +("O" ?𑘼) +("`o" ?𑘌) +("`O" ?𑘍) +("p" ?𑘢) +("P" ?𑘣) +("a" ?𑘰) +("A" ?𑘁) +("`a" ?𑘀) +("s" ?𑘭) +("S" ?𑘫) +("d" ?𑘟) +("D" ?𑘠) +("f" ?𑘿) +("F" ?𑘶) +("`f" ?𑘇) +("g" ?𑘐) +("G" ?𑘑) +("h" ?𑘮) +("H" ?𑘾) +("j" ?𑘕) +("J" ?𑘖) +("k" ?𑘎) +("K" ?𑘏) +("l" ?𑘩) +("L" ?𑘯) +("`l" ?𑘷) +("`L" ?𑘈) +("z" ?𑘗) +("Z" ?𑘒) +("`z" ?𑘸) +("`Z" ?𑘉) +("x" ?𑘬) +("X" ?𑙀) +("c" ?𑘓) +("C" ?𑘔) +("`c" #x200C) ; ZWNJ +("v" ?𑘪) +("b" ?𑘤) +("B" ?𑘥) +("n" ?𑘡) +("N" ?𑘜) +("m" ?𑘦) +("M" ?𑘽) +) + +(quail-define-package + "odia" "Odia" "ଓ" t "Odia phonetic input method. + + `\\=`' is used to switch levels instead of Alt-Gr. +" nil t t t t nil nil nil nil nil t) + +(quail-define-rules +("``" ?₹) +("1" ?୧) +("`1" ?1) +("`!" ?୲) +("2" ?୨) +("`2" ?2) +("`@" ?୳) +("3" ?୩) +("`3" ?3) +("`#" ?୴) +("4" ?୪) +("`4" ?4) +("`$" ?୵) +("5" ?୫) +("`5" ?5) +("`%" ?୶) +("6" ?୬) +("`6" ?6) +("`^" ?୷) +("7" ?୭) +("`7" ?7) +("8" ?୮) +("`8" ?8) +("9" ?୯) +("`9" ?9) +("0" ?୦) +("`0" ?0) +("`\\" ?।) +("`|" ?॥) +("`" ?ଟ) +("q" ?ଟ) +("Q" ?ଠ) +("`q" ?୰) +("`Q" ?୕) +("w" ?ଡ) +("W" ?ଢ) +("`w" ?ଡ଼) +("`W" ?ଢ଼) +("e" ?େ) +("E" ?ୈ) +("`e" ?ଏ) +("`E" ?ଐ) +("r" ?ର) +("R" ?ୃ) +("`r" ?ଋ) +("t" ?ତ) +("T" ?ଥ) +("`t" ?ୖ) +("`T" ?ୗ) +("y" ?ଯ) +("Y" ?ୟ) +("u" ?ୁ) +("U" ?ୂ) +("`u" ?ଉ) +("`U" ?ଊ) +("i" ?ି) +("I" ?ୀ) +("`i" ?ଇ) +("`I" ?ଈ) +("o" ?ୋ) +("O" ?ୌ) +("`o" ?ଓ) +("`O" ?ଔ) +("p" ?ପ) +("P" ?ଫ) +("a" ?ା) +("A" ?ଆ) +("`a" ?ଅ) +("s" ?ସ) +("S" ?ଶ) +("d" ?ଦ) +("D" ?ଧ) +("f" ?୍) +("F" ?ୄ) +("`f" ?ୠ) +("g" ?ଗ) +("G" ?ଘ) +("h" ?ହ) +("H" ?ଃ) +("j" ?ଜ) +("J" ?ଝ) +("k" ?କ) +("K" ?ଖ) +("l" ?ଲ) +("L" ?ଳ) +("`l" ?ୢ) +("`L" ?ଌ) +("z" ?ଞ) +("Z" ?ଙ) +("`z" ?ୣ) +("`Z" ?ୡ) +("x" ?ଷ) +("X" ?଼) +("c" ?ଚ) +("C" ?ଛ) +("`c" #x200C) ; ZWNJ +("`C" #x200D) ; ZWJ +("v" ?ଵ) +("V" ?ୱ) +("b" ?ବ) +("B" ?ଭ) +("n" ?ନ) +("N" ?ଣ) +("m" ?ମ) +("M" ?ଂ) +("`m" ?ଁ) +("`M" ?ଽ) +) + +(quail-define-package + "limbu" "Limbu" "ᤕ" t "Limbu phonetic input method. + + `\\=`' is used to switch levels instead of Alt-Gr. +" nil t t t t nil nil nil nil nil t) + +(quail-define-rules +("``" ?₹) +("1" ?᥇) +("`1" ?1) +("`!" ?᥄) +("2" ?᥈) +("`2" ?2) +("3" ?᥉) +("`3" ?3) +("4" ?᥊) +("`4" ?4) +("5" ?᥋) +("`5" ?5) +("6" ?᥌) +("`6" ?6) +("7" ?᥍) +("`7" ?7) +("8" ?᥎) +("`8" ?8) +("9" ?᥏) +("`9" ?9) +("0" ?᥆) +("`0" ?0) +("`\\" ?।) +("`|" ?॥) +("`" ?ᤘ) +("q" ?ᤧ) +("Q" ?ᤨ) +("`q" ?᥀) +("w" ?ᤘ) +("W" ?ᤫ) +("e" ?ᤣ) +("E" ?ᤤ) +("r" ?ᤖ) +("R" ?ᤷ) +("`r" ?ᤪ) +("t" ?ᤋ) +("T" ?ᤌ) +("`t" ?ᤳ) +("`T" ?ᤞ) +("y" ?ᤕ) +("Y" ?ᤩ) +("u" ?ᤢ) +("i" ?ᤡ) +("o" ?ᤥ) +("O" ?ᤦ) +("p" ?ᤐ) +("P" ?ᤑ) +("`p" ?ᤵ) +("a" ?ᤠ) +("A" ?ᤀ) +("s" ?ᤛ) +("S" ?ᤙ) +("d" ?ᤍ) +("D" ?ᤎ) +("f" ?᤻) +("g" ?ᤃ) +("G" ?ᤄ) +("`g" ?ᤝ) +("h" ?ᤜ) +("j" ?ᤈ) +("J" ?ᤉ) +("k" ?ᤁ) +("K" ?ᤂ) +("`k" ?ᤰ) +("l" ?ᤗ) +("L" ?ᤸ) +("z" ?ᤊ) +("Z" ?ᤅ) +("x" ?ᤚ) +("X" ?᤹) +("c" ?ᤆ) +("C" ?ᤇ) +("`c" #x200C) ; ZWNJ +("v" ?᤺) +("b" ?ᤒ) +("B" ?ᤓ) +("n" ?ᤏ) +("N" ?ᤴ) +("m" ?ᤔ) +("M" ?ᤱ) +("`m" ?ᤲ) +("`?" ?᥅) +) + +(quail-define-package + "grantha" "Grantha" "𑌗𑍍𑌰" t "Grantha phonetic input method. + + `\\=`' is used to switch levels instead of Alt-Gr." + nil t t t t nil nil nil nil nil t) + +(quail-define-rules + ("``" ?₹) + ("1" ?௧) + ("`1" ?1) + ("`!" ?𑍧) + ("2" ?௨) + ("`2" ?2) + ("`@" ?𑍨) + ("3" ?௩) + ("`3" ?3) + ("`#" ?𑍩) + ("4" ?௪) + ("`4" ?4) + ("`$" ?𑍪) + ("5" ?௫) + ("`5" ?5) + ("`%" ?𑍫) + ("6" ?௬) + ("`6" ?6) + ("`^" ?𑍬) + ("7" ?௭) + ("`7" ?7) + ("8" ?௮) + ("`8" ?8) + ("9" ?௯) + ("`9" ?9) + ("0" ?௦) + ("`0" ?0) + ("q" ?𑌟) + ("Q" ?𑌠) + ("`q" ?𑍐) + ("`Q" ?𑍝) + ("w" ?𑌡) + ("W" ?𑌢) + ("`w" ?𑍞) + ("`W" ?𑍟) + ("e" ?𑍇) + ("E" ?𑍈) + ("`e" ?𑌏) + ("`E" ?𑌐) + ("r" ?𑌰) + ("R" ?𑍃) + ("`r" ?𑌋) + ("t" ?𑌤) + ("T" ?𑌥) + ("`t" ?𑍗) + ("y" ?𑌯) + ("u" ?𑍁) + ("U" ?𑍂) + ("`u" ?𑌉) + ("`U" ?𑌊) + ("i" ?𑌿) + ("I" ?𑍀) + ("`i" ?𑌇) + ("`I" ?𑌈) + ("o" ?𑍋) + ("O" ?𑍌) + ("`o" ?𑌓) + ("`O" ?𑌔) + ("p" ?𑌪) + ("P" ?𑌫) + ("`p" ?𑍴) + ("a" ?𑌾) + ("A" ?𑌆) + ("`a" ?𑌅) + ("`A" ?𑍰) + ("s" ?𑌸) + ("S" ?𑌶) + ("d" ?𑌦) + ("D" ?𑌧) + ("f" ?𑍍) + ("F" ?𑍄) + ("`f" ?𑍠) + ("g" ?𑌗) + ("G" ?𑌘) + ("h" ?𑌹) + ("H" ?𑌃) + ("j" ?𑌜) + ("J" ?𑌝) + ("k" ?𑌕) + ("K" ?𑌖) + ("`k" ?𑍱) + ("l" ?𑌲) + ("L" ?𑌳) + ("`l" ?𑍢) + ("`L" ?𑌌) + ("z" ?𑌞) + ("Z" ?𑌙) + ("`z" ?𑍣) + ("`Z" ?𑍡) + ("x" ?𑌷) + ("X" ?𑌼) + ("`x" ?𑌻) + ("c" ?𑌚) + ("C" ?𑌛) + ("`c" #x200C) ; ZWNJ + ("v" ?𑌵) + ("V" ?𑌽) + ("`v" ?𑍳) + ("b" ?𑌬) + ("B" ?𑌭) + ("n" ?𑌨) + ("N" ?𑌣) + ("`n" ?𑍲) + ("m" ?𑌮) + ("M" ?𑌂) + ("`m" ?𑌁) + ("`M" ?𑌀)) + ;;; indian.el ends here diff --git a/lisp/leim/quail/indonesian.el b/lisp/leim/quail/indonesian.el new file mode 100644 index 00000000000..8d0d158076a --- /dev/null +++ b/lisp/leim/quail/indonesian.el @@ -0,0 +1,557 @@ +;;; indonesian.el --- Quail package for inputting Indonesian characters -*- lexical-binding: t; -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; Author: समीर सिंह Sameer Singh <lumarzeli30@gmail.com> +;; Keywords: multilingual, input method, i18n, Indonesia + +;; 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: + +;; Input methods for Indonesian languages. + +;;; Code: + +(require 'quail) + +;; This input method supports languages like Buginese, Balinese, Sundanese and +;; Javanese. + +(quail-define-package + "balinese" "Balinese" "ᬩ" t "Balinese phonetic input method. + + `\\=`' is used to switch levels instead of Alt-Gr. +" nil t t t t nil nil nil nil nil t) + +(quail-define-rules + ("1" ?᭑) + ("`1" ?1) + ("`!" ?᭫) + ("2" ?᭒) + ("`2" ?2) + ("`@" ?᭬) + ("3" ?᭓) + ("`3" ?3) + ("`#" ?᭭) + ("4" ?᭔) + ("`4" ?4) + ("`$" ?᭮) + ("5" ?᭕) + ("`5" ?5) + ("`%" ?᭯) + ("6" ?᭖) + ("`6" ?6) + ("`^" ?᭰) + ("7" ?᭗) + ("`7" ?7) + ("`&" ?᭱) + ("8" ?᭘) + ("`8" ?8) + ("`*" ?᭲) + ("9" ?᭙) + ("`9" ?9) + ("`(" ?᭳) + ("0" ?᭐) + ("`0" ?0) + ("`)" ?᭼) + ("`\\" ?᭞) + ("`|" ?᭟) + ("`" ?ᬝ) + ("q" ?ᬝ) + ("Q" ?ᬞ) + ("`q" ?᭚) + ("`Q" ?᭽) + ("w" ?ᬟ) + ("W" ?ᬠ) + ("`w" ?᭛) + ("`W" ?᭾) + ("e" ?ᬾ) + ("E" ?ᬿ) + ("`e" ?ᬏ) + ("`E" ?ᬐ) + ("r" ?ᬭ) + ("R" ?ᬃ) + ("`r" ?ᬺ) + ("`R" ?ᬋ) + ("t" ?ᬢ) + ("T" ?ᬣ) + ("`t" ?᭜) + ("`T" ?᭝) + ("y" ?ᬬ) + ("Y" ?ᭂ) + ("`y" ?ᭃ) + ("`Y" ?᭴) + ("u" ?ᬸ) + ("U" ?ᬹ) + ("`u" ?ᬉ) + ("`U" ?ᬊ) + ("i" ?ᬶ) + ("I" ?ᬷ) + ("`i" ?ᬇ) + ("`I" ?ᬈ) + ("o" ?ᭀ) + ("O" ?ᭁ) + ("`o" ?ᬑ) + ("`O" ?ᬒ) + ("p" ?ᬧ) + ("P" ?ᬨ) + ("`p" ?ᭈ) + ("`P" ?᭠) + ("a" ?ᬵ) + ("A" ?ᬆ) + ("`a" ?ᬅ) + ("`A" ?᭵) + ("s" ?ᬲ) + ("S" ?ᬰ) + ("`s" ?᭡) + ("`S" ?᭢) + ("d" ?ᬤ) + ("D" ?ᬥ) + ("`d" ?᭣) + ("`D" ?᭤) + ("f" ?᭄) + ("F" ?ᬻ) + ("`f" ?ᬌ) + ("`F" ?᭶) + ("g" ?ᬕ) + ("G" ?ᬖ) + ("`g" ?᭥) + ("`G" ?᭦) + ("h" ?ᬳ) + ("H" ?ᬄ) + ("`h" ?᭧) + ("`H" ?᭨) + ("j" ?ᬚ) + ("J" ?ᬛ) + ("`j" ?ᭌ) + ("`J" ?᭩) + ("k" ?ᬓ) + ("K" ?ᬔ) + ("`k" ?ᭅ) + ("`K" ?ᭆ) + ("l" ?ᬮ) + ("L" ?ᬼ) + ("`l" ?ᬍ) + ("`L" ?᭪) + ("z" ?ᭊ) + ("Z" ?ᬽ) + ("`z" ?ᬎ) + ("`Z" ?᭷) + ("x" ?ᬱ) + ("X" ?᬴) + ("`x" ?᭸) + ("c" ?ᬘ) + ("C" ?ᬙ) + ("`c" #x200C) ; ZWNJ + ("v" ?ᬯ) + ("V" ?ᭉ) + ("`v" ?᭹) + ("`V" ?᭺) + ("b" ?ᬩ) + ("B" ?ᬪ) + ("`b" ?᭻) + ("n" ?ᬦ) + ("N" ?ᬡ) + ("`n" ?ᬗ) + ("`N" ?ᬜ) + ("m" ?ᬫ) + ("M" ?ᬂ) + ("`m" ?ᬁ) + ("`M" ?ᬀ)) + +(quail-define-package + "javanese" "Javanese" "ꦗ" t "Javanese phonetic input method. + + `\\=`' is used to switch levels instead of Alt-Gr. +" nil t t t t nil nil nil nil nil t) + +(quail-define-rules + ("1" ?꧑) + ("`1" ?1) + ("`!" ?꧁) + ("2" ?꧒) + ("`2" ?2) + ("`@" ?꧂) + ("3" ?꧓) + ("`3" ?3) + ("`#" ?꧃) + ("4" ?꧔) + ("`4" ?4) + ("`$" ?꧄) + ("5" ?꧕) + ("`5" ?5) + ("`%" ?꧅) + ("6" ?꧖) + ("`6" ?6) + ("`^" ?꧆) + ("7" ?꧗) + ("`7" ?7) + ("`&" ?꧇) + ("8" ?꧘) + ("`8" ?8) + ("`*" ?꧈) + ("9" ?꧙) + ("`9" ?9) + ("`(" ?꧉) + ("0" ?꧐) + ("`0" ?0) + ("`)" ?꧞) + ("`\\" ?꧊) + ("`|" ?꧋) + ("`" ?ꦛ) + ("q" ?ꦛ) + ("Q" ?ꦜ) + ("`q" ?꧟) + ("`Q" ?ꧏ) + ("w" ?ꦝ) + ("W" ?ꦞ) + ("`w" ?꧌) + ("`W" ?꧍) + ("e" ?ꦺ) + ("E" ?ꦻ) + ("`e" ?ꦌ) + ("`E" ?ꦍ) + ("r" ?ꦫ) + ("R" ?ꦬ) + ("`r" ?ꦿ) + ("`R" ?ꦂ) + ("t" ?ꦠ) + ("T" ?ꦡ) + ("`t" ?ꦼ) + ("y" ?ꦪ) + ("Y" ?ꦾ) + ("u" ?ꦸ) + ("U" ?ꦹ) + ("`u" ?ꦈ) + ("`U" ?ꦅ) + ("i" ?ꦶ) + ("I" ?ꦷ) + ("`i" ?ꦆ) + ("`I" ?ꦇ) + ("o" ?ꦎ) + ("p" ?ꦥ) + ("P" ?ꦦ) + ("`p" ?ꦉ) + ("a" ?ꦴ) + ("A" ?ꦄ) + ("`a" ?ꦵ) + ("s" ?ꦱ) + ("S" ?ꦯ) + ("d" ?ꦢ) + ("D" ?ꦣ) + ("f" ?꧀) + ("F" ?ꦽ) + ("`f" ?ꦉ) + ("g" ?ꦒ) + ("G" ?ꦓ) + ("h" ?ꦲ) + ("H" ?ꦃ) + ("j" ?ꦗ) + ("J" ?ꦙ) + ("`j" ?ꦘ) + ("k" ?ꦏ) + ("K" ?ꦑ) + ("`k" ?ꦐ) + ("l" ?ꦭ) + ("L" ?ꦊ) + ("`l" ?ꦋ) + ("z" ?ꦚ) + ("Z" ?ꦔ) + ("x" ?ꦰ) + ("X" ?꦳) + ("c" ?ꦕ) + ("C" ?ꦖ) + ("`c" #x200C) ; ZWNJ + ("v" ?ꦮ) + ("V" ?ᭉ) + ("b" ?ꦧ) + ("B" ?ꦨ) + ("n" ?ꦤ) + ("N" ?ꦟ) + ("m" ?ꦩ) + ("M" ?ꦁ) + ("`m" ?ꦀ)) + +(quail-define-package + "sundanese" "Sundanese" "ᮞᮥ" t "Sundanese phonetic input method. + + `\\=`' is used to switch levels instead of Alt-Gr. +" nil t t t t nil nil nil nil nil t) + +(quail-define-rules + ("1" ?᮱) + ("`1" ?1) + ("`!" ?᳀) + ("2" ?᮲) + ("`2" ?2) + ("`@" ?᳁) + ("3" ?᮳) + ("`3" ?3) + ("`#" ?᳂) + ("4" ?᮴) + ("`4" ?4) + ("`$" ?᳃) + ("5" ?᮵) + ("`5" ?5) + ("6" ?᮶) + ("`6" ?6) + ("7" ?᮷) + ("`7" ?7) + ("8" ?᮸) + ("`8" ?8) + ("9" ?᮹) + ("`9" ?9) + ("0" ?᮰) + ("`0" ?0) + ("`" ?ᮒ) + ("q" ?ᮋ) + ("w" ?ᮝ) + ("W" ?ᮭ) + ("e" ?ᮨ) + ("E" ?ᮩ) + ("`e" ?ᮈ) + ("`E" ?ᮉ) + ("r" ?ᮛ) + ("R" ?ᮢ) + ("`r" ?ᮁ) + ("`R" ?ᮻ) + ("t" ?ᮒ) + ("y" ?ᮚ) + ("Y" ?ᮡ) + ("u" ?ᮥ) + ("U" ?ᮅ) + ("i" ?ᮤ) + ("I" ?ᮄ) + ("o" ?ᮧ) + ("O" ?ᮇ) + ("p" ?ᮕ) + ("P" ?ᮖ) + ("a" ?ᮃ) + ("A" ?ᮦ) + ("`a" ?ᮆ) + ("s" ?ᮞ) + ("S" ?ᮯ) + ("d" ?ᮓ) + ("D" ?᳆) + ("f" ?᮪) + ("F" ?᮫) + ("g" ?ᮌ) + ("h" ?ᮠ) + ("H" ?ᮂ) + ("j" ?ᮏ) + ("k" ?ᮊ) + ("K" ?ᮮ) + ("`k" ?ᮾ) + ("`K" ?᳅) + ("l" ?ᮜ) + ("L" ?ᮣ) + ("`l" ?ᮼ) + ("`L" ?᳄) + ("z" ?ᮐ) + ("x" ?ᮟ) + ("c" ?ᮎ) + ("`c" #x200C) ; ZWNJ + ("b" ?ᮘ) + ("B" ?ᮽ) + ("`b" ?ᮺ) + ("`B" ?᳇) + ("n" ?ᮔ) + ("N" ?ᮍ) + ("`n" ?ᮑ) + ("m" ?ᮙ) + ("M" ?ᮀ) + ("`m" ?ᮿ) + ("`M" ?ᮬ)) + +(quail-define-package + "batak" "Batak" "ᯅ" t "Batak phonetic input method, + used by languages such as Karo, Toba, Pakpak, Mandailing + and Simalungun. + + `\\=`' is used to switch levels instead of Alt-Gr. +" nil t t t t nil nil nil nil nil t) + +(quail-define-rules + ("q" ?᯼) + ("Q" ?᯽) + ("w" ?ᯋ) + ("W" ?ᯌ) + ("`w" ?ᯍ) + ("e" ?ᯧ) + ("E" ?ᯨ) + ("`e" ?ᯩ) + ("r" ?ᯒ) + ("R" ?ᯓ) + ("t" ?ᯖ) + ("T" ?ᯗ) + ("y" ?ᯛ) + ("Y" ?ᯜ) + ("u" ?ᯮ) + ("U" ?ᯥ) + ("`u" ?ᯯ) + ("i" ?ᯪ) + ("I" ?ᯫ) + ("`i" ?ᯤ) + ("o" ?ᯬ) + ("O" ?ᯭ) + ("p" ?ᯇ) + ("P" ?ᯈ) + ("a" ?ᯀ) + ("A" ?ᯁ) + ("s" ?ᯘ) + ("S" ?ᯙ) + ("`s" ?ᯚ) + ("d" ?ᯑ) + ("f" ?᯲) + ("F" ?᯳) + ("g" ?ᯎ) + ("G" ?ᯏ) + ("h" ?ᯂ) + ("H" ?ᯃ) + ("`h" ?ᯄ) + ("`H" ?ᯱ) + ("j" ?ᯐ) + ("k" ?᯦) + ("l" ?ᯞ) + ("L" ?ᯟ) + ("z" ?ᯝ) + ("Z" ?ᯰ) + ("x" ?ᯠ) + ("c" ?ᯡ) + ("v" ?᯾) + ("V" ?᯿) + ("b" ?ᯅ) + ("B" ?ᯆ) + ("n" ?ᯉ) + ("N" ?ᯊ) + ("`n" ?ᯢ) + ("m" ?ᯔ) + ("M" ?ᯕ) + ("`m" ?ᯣ)) + +(quail-define-package + "rejang" "Rejang" "ꤽꥍ" nil "Rejang phonetic input method." + nil t t t t nil nil nil nil nil t) + +(quail-define-rules + ("q" ?꥟) + ("w" ?ꥀ) + ("e" ?ꥉ) + ("E" ?ꥊ) + ("r" ?ꤽ) + ("R" ?ꥑ) + ("t" ?ꤳ) + ("y" ?ꤿ) + ("u" ?ꥈ) + ("U" ?ꥍ) + ("i" ?ꥇ) + ("o" ?ꥋ) + ("O" ?ꥌ) + ("p" ?ꤶ) + ("a" ?ꥆ) + ("A" ?ꥎ) + ("s" ?ꤼ) + ("d" ?ꤴ) + ("D" ?ꥄ) + ("f" ?꥓) + ("F" ?ꥃ) + ("g" ?ꤱ) + ("h" ?ꥁ) + ("H" ?ꥒ) + ("j" ?ꤺ) + ("k" ?ꤰ) + ("l" ?ꤾ) + ("z" ?ꤲ) + ("Z" ?ꥏ) + ("x" ?ꤻ) + ("X" ?ꥅ) + ("c" ?ꤹ) + ("b" ?ꤷ) + ("n" ?ꤵ) + ("N" ?ꥐ) + ("m" ?ꤸ) + ("M" ?ꥂ)) + +(quail-define-package + "makasar" "Makasar" "𑻪" nil "Makasar phonetic input method." + nil t t t t nil nil nil nil nil t) + +(quail-define-rules + ("q" ?𑻷) + ("Q" ?𑻸) + ("e" ?𑻵) + ("r" ?𑻭) + ("t" ?𑻦) + ("y" ?𑻬) + ("u" ?𑻴) + ("i" ?𑻳) + ("o" ?𑻶) + ("p" ?𑻣) + ("a" ?𑻱) + ("s" ?𑻰) + ("d" ?𑻧) + ("g" ?𑻡) + ("j" ?𑻪) + ("k" ?𑻠) + ("l" ?𑻮) + ("z" ?𑻢) + ("Z" ?𑻲) + ("x" ?𑻫) + ("c" ?𑻩) + ("v" ?𑻯) + ("b" ?𑻤) + ("n" ?𑻨) + ("m" ?𑻥)) + +(quail-define-package + "lontara" "Lontara" "ᨒ" nil "Lontara phonetic input method." + nil t t t t nil nil nil nil nil t) + +(quail-define-rules + ("q" ?᨞) + ("Q" ?᨟) + ("e" ?ᨙ) + ("E" ?ᨛ) + ("r" ?ᨑ) + ("t" ?ᨈ) + ("y" ?ᨐ) + ("u" ?ᨘ) + ("i" ?ᨗ) + ("o" ?ᨚ) + ("p" ?ᨄ) + ("a" ?ᨕ) + ("s" ?ᨔ) + ("d" ?ᨉ) + ("g" ?ᨁ) + ("h" ?ᨖ) + ("j" ?ᨍ) + ("k" ?ᨀ) + ("l" ?ᨒ) + ("z" ?ᨂ) + ("Z" ?ᨃ) + ("x" ?ᨎ) + ("X" ?ᨏ) + ("c" ?ᨌ) + ("v" ?ᨓ) + ("b" ?ᨅ) + ("n" ?ᨊ) + ("N" ?ᨋ) + ("m" ?ᨆ) + ("M" ?ᨇ)) + +(provide 'indonesian) +;;; indonesian.el ends here diff --git a/lisp/leim/quail/ipa.el b/lisp/leim/quail/ipa.el index 0ef6e383bd1..773dc31f9b7 100644 --- a/lisp/leim/quail/ipa.el +++ b/lisp/leim/quail/ipa.el @@ -269,7 +269,7 @@ QUAIL-KEYMAP is a cons that satisfies `quail-map-p'; TO-PREPEND is a string." (when (consp quail-keymap) (setq quail-keymap (cdr quail-keymap))) (if (or (integerp quail-keymap) - (and (fboundp 'characterp) (characterp quail-keymap))) + (characterp quail-keymap)) (setq quail-keymap (list (string quail-keymap))) (if (stringp quail-keymap) (setq quail-keymap (list quail-keymap)) @@ -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 c18ed862d4e..acb3ef8ede9 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 f6c63cb0552..b6a26e0b2c5 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/leim/quail/misc-lang.el b/lisp/leim/quail/misc-lang.el new file mode 100644 index 00000000000..bdb86ab5281 --- /dev/null +++ b/lisp/leim/quail/misc-lang.el @@ -0,0 +1,101 @@ +;;; misc-lang.el --- Quail package for inputting Miscellaneous characters -*- lexical-binding: t; -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; Author: समीर सिंह Sameer Singh <lumarzeli30@gmail.com> +;; Keywords: multilingual, input method, i18n, Miscellaneous + +;; 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: + +;; Input methods for Miscellaneous languages. + +;;; Code: + +(require 'quail) + +(quail-define-package + "hanifi-rohingya" "Hanifi Rohingya" "𐴌𐴟" t "Hanifi Rohingya phonetic input method. + + `\\=`' is used to switch levels instead of Alt-Gr. +" nil t t t t nil nil nil nil nil t) + +(quail-define-rules + ("1" ?𐴱) + ("`1" ?1) + ("2" ?𐴲) + ("`2" ?2) + ("3" ?𐴳) + ("`3" ?3) + ("4" ?𐴴) + ("`4" ?4) + ("5" ?𐴵) + ("`5" ?5) + ("6" ?𐴶) + ("`6" ?6) + ("7" ?𐴷) + ("`7" ?7) + ("8" ?𐴸) + ("`8" ?8) + ("9" ?𐴹) + ("`9" ?9) + ("0" ?𐴰) + ("`0" ?0) + ("q" ?𐴄) + ("w" ?𐴋) + ("W" ?𐴍) + ("e" ?𐴠) + ("E" ?𐴤) + ("r" ?𐴌) + ("R" ?𐴥) + ("t" ?𐴃) + ("T" ?𐴦) + ("y" ?𐴘) + ("Y" ?𐴙) + ("u" ?𐴟) + ("U" ?𐴧) + ("i" ?𐴞) + ("o" ?𐴡) + ("p" ?𐴂) + ("a" ?𐴀) + ("A" ?𐴝) + ("s" ?𐴏) + ("S" ?𐴐) + ("d" ?𐴊) + ("f" ?𐴉) + ("F" ?𐴢) + ("g" ?𐴒) + ("h" ?𐴇) + ("j" ?𐴅) + ("k" ?𐴑) + ("K" ?𐴈) + ("l" ?𐴓) + ("z" ?𐴎) + ("c" ?𐴆) + ("C" #x200C) ; ZWNJ + ("v" ?𐴖) + ("V" ?𐴗) + ("`v" ?𐴜) + ("b" ?𐴁) + ("n" ?𐴕) + ("N" ?𐴚) + ("`n" ?𐴛) + ("`N" ?𐴣) + ("m" ?𐴔)) + +(provide 'misc-lang) +;;; misc-lang.el ends here diff --git a/lisp/leim/quail/philippine.el b/lisp/leim/quail/philippine.el new file mode 100644 index 00000000000..9afbdc354e3 --- /dev/null +++ b/lisp/leim/quail/philippine.el @@ -0,0 +1,152 @@ +;;; philippine.el --- Quail package for inputting Philippine characters -*- lexical-binding: t; -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; Author: समीर सिंह Sameer Singh <lumarzeli30@gmail.com> +;; Keywords: multilingual, input method, i18n, Philippines + +;; 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: + +;; Input methods for Philippine languages. + +;;; Code: + +(require 'quail) + +;; This input method supports languages like Tagalog, Hanunoo, Buhid and +;; Tagbanwa, using the Baybayin script. +(quail-define-package + "tagalog" "Tagalog" "ᜊ" nil "Tagalog phonetic input method." + nil t t t t nil nil nil nil nil t) + +(quail-define-rules + ("q" ?₱) + ("w" ?ᜏ) + ("r" ?ᜍ) + ("R" ?ᜟ) + ("t" ?ᜆ) + ("y" ?ᜌ) + ("u" ?ᜓ) + ("U" ?ᜂ) + ("i" ?ᜒ) + ("I" ?ᜁ) + ("p" ?ᜉ) + ("a" ?ᜀ) + ("s" ?ᜐ) + ("d" ?ᜇ) + ("f" ?᜔) + ("g" ?ᜄ) + ("h" ?ᜑ) + ("j" ?᜵) + ("J" ?᜶) + ("k" ?ᜃ) + ("l" ?ᜎ) + ("v" ?᜕) + ("b" ?ᜊ) + ("n" ?ᜈ) + ("N" ?ᜅ) + ("m" ?ᜋ)) + +(quail-define-package + "hanunoo" "Hanunoo" "ᜱ" nil "Hanunoo phonetic input method." + nil t t t t nil nil nil nil nil t) + +(quail-define-rules + ("q" ?₱) + ("w" ?ᜯ) + ("r" ?ᜭ) + ("t" ?ᜦ) + ("y" ?ᜬ) + ("u" ?ᜳ) + ("U" ?ᜢ) + ("i" ?ᜲ) + ("I" ?ᜡ) + ("p" ?ᜩ) + ("a" ?ᜠ) + ("s" ?ᜰ) + ("d" ?ᜧ) + ("f" ?᜴) + ("g" ?ᜤ) + ("h" ?ᜱ) + ("j" ?᜵) + ("J" ?᜶) + ("k" ?ᜣ) + ("l" ?ᜮ) + ("b" ?ᜪ) + ("n" ?ᜨ) + ("N" ?ᜥ) + ("m" ?ᜫ)) + +(quail-define-package + "buhid" "Buhid" "ᝊᝓ" nil "Buhid phonetic input method." + nil t t t t nil nil nil nil nil t) + +(quail-define-rules + ("q" ?₱) + ("w" ?ᝏ) + ("r" ?ᝍ) + ("t" ?ᝆ) + ("y" ?ᝌ) + ("u" ?ᝓ) + ("U" ?ᝂ) + ("i" ?ᝒ) + ("I" ?ᝁ) + ("p" ?ᝉ) + ("a" ?ᝀ) + ("s" ?ᝐ) + ("d" ?ᝇ) + ("g" ?ᝄ) + ("h" ?ᝑ) + ("j" ?᜵) + ("J" ?᜶) + ("k" ?ᝃ) + ("l" ?ᝎ) + ("b" ?ᝊ) + ("n" ?ᝈ) + ("N" ?ᝅ) + ("m" ?ᝋ)) + +(quail-define-package + "tagbanwa" "Tagbanwa" "ᝦ" nil "Tagbanwa phonetic input method." + nil t t t t nil nil nil nil nil t) + +(quail-define-rules + ("q" ?₱) + ("w" ?ᝯ) + ("t" ?ᝦ) + ("y" ?ᝬ) + ("u" ?ᝳ) + ("U" ?ᝢ) + ("i" ?ᝲ) + ("I" ?ᝡ) + ("p" ?ᝩ) + ("a" ?ᝠ) + ("s" ?ᝰ) + ("d" ?ᝧ) + ("g" ?ᝤ) + ("j" ?᜵) + ("J" ?᜶) + ("k" ?ᝣ) + ("l" ?ᝮ) + ("b" ?ᝪ) + ("n" ?ᝨ) + ("N" ?ᝥ) + ("m" ?ᝫ)) + +(provide 'philippine) +;;; philippine.el ends here diff --git a/lisp/leim/quail/symbol-ksc.el b/lisp/leim/quail/symbol-ksc.el index 042465697a1..d440058902a 100644 --- a/lisp/leim/quail/symbol-ksc.el +++ b/lisp/leim/quail/symbol-ksc.el @@ -39,7 +39,7 @@ "한글심벌입력표: 【(】괄호열기【arrow】화살【sex】♂♀【index】첨자 【accent】악센트 【)】괄호닫기【music】음악【dot】점 【quote】따옴표【xtext】§※¶¡¿ - 【Unit】℃Å¢℉【math】수학기호【pic】상형문자【line】선문자 + 【Unit】℃Å¢℉【math】수학기호【pic】상형문자【line】선문자 【unit】단위 【frac】분수 【textline】―∥\∼ 【wn】㈜【ks】㉿【No】№【㏇】㏇ 【dag】† 【ddag】‡【percent】‰ 【am】㏂【pm】㏘【™】™【Tel】℡【won】₩ 【yen】¥ 【pound】£ @@ -65,7 +65,7 @@ ("dot" "·‥…¨ː") ("quote" "、。〃‘’“”°′″´˝") ("textline" "―∥\∼") - ("Unit" "℃Å¢℉") + ("Unit" "℃Å¢℉") ("sex" "♂♀") ("accent" "~ˇ˘˚˙¸˛") ("percent" "‰") diff --git a/lisp/linum.el b/lisp/linum.el index e121618b69f..d491da52066 100644 --- a/lisp/linum.el +++ b/lisp/linum.el @@ -74,6 +74,9 @@ and you have to scroll or press \\[recenter-top-bottom] to update the numbers." ;;;###autoload (define-minor-mode linum-mode "Toggle display of line numbers in the left margin (Linum mode). +This mode has been largely replaced by `display-line-numbers-mode' +(which is much faster and has fewer interaction problems with other +modes). Linum mode is a buffer-local minor mode." :lighter "" ; for desktop.el diff --git a/lisp/loadhist.el b/lisp/loadhist.el index 48058f40535..39481ab0684 100644 --- a/lisp/loadhist.el +++ b/lisp/loadhist.el @@ -157,38 +157,35 @@ documentation of `unload-feature' for details.") ;; mode, or proposed is not nil and not major-mode, and so we use it. (funcall (or proposed 'fundamental-mode))))))) +(defvar loadhist-unload-filename nil) + (cl-defgeneric loadhist-unload-element (x) - "Unload an element from the `load-history'." + "Unload an element from the `load-history'. +The variable `loadhist-unload-filename' holds the name of the file we're +unloading." (message "Unexpected element %S in load-history" x)) -;; In `load-history', the definition of a previously autoloaded -;; function is represented by 2 entries: (t . SYMBOL) comes before -;; (defun . SYMBOL) and says we should restore SYMBOL's autoload when -;; we undefine it. -;; So we use this auxiliary variable to keep track of the last (t . SYMBOL) -;; that occurred. -(defvar loadhist--restore-autoload nil - "If non-nil, is a symbol for which to try to restore a previous autoload.") - -(cl-defmethod loadhist-unload-element ((x (head t))) - (setq loadhist--restore-autoload (cdr x))) - -(defun loadhist--unload-function (x) - (let ((fun (cdr x))) - (when (fboundp fun) - (when (fboundp 'ad-unadvise) - (ad-unadvise fun)) - (let ((aload (get fun 'autoload))) - (defalias fun - (if (and aload (eq fun loadhist--restore-autoload)) - (cons 'autoload aload) - nil))))) - (setq loadhist--restore-autoload nil)) - (cl-defmethod loadhist-unload-element ((x (head defun))) - (loadhist--unload-function x)) -(cl-defmethod loadhist-unload-element ((x (head autoload))) - (loadhist--unload-function x)) + (let* ((fun (cdr x)) + (hist (get fun 'function-history))) + (cond + ((null hist) + (defalias fun nil) + ;; Override the change that `defalias' just recorded. + (put fun 'function-history nil)) + ((equal (car hist) loadhist-unload-filename) + (defalias fun (cadr hist)) + ;; Set the history afterwards, to override the change that + ;; `defalias' records otherwise. + (put fun 'function-history (cddr hist))) + (t + ;; Unloading a file whose definition is "inactive" (i.e. has been + ;; overridden by another file): just remove it from the history, + ;; so future unloading of that other file has a chance to DTRT. + (let* ((tmp (plist-member hist loadhist-unload-filename)) + (pos (- (length hist) (length tmp)))) + (cl-assert (> pos 1)) + (setcdr (nthcdr (- pos 2) hist) (cdr tmp))))))) (cl-defmethod loadhist-unload-element ((_ (head require))) nil) (cl-defmethod loadhist-unload-element ((_ (head defface))) nil) @@ -257,6 +254,7 @@ something strange, such as redefining an Emacs function." (prin1-to-string dependents) file)))) (let* ((unload-function-defs-list (feature-symbols feature)) (file (pop unload-function-defs-list)) + (loadhist-unload-filename file) (name (symbol-name feature)) (unload-hook (intern-soft (concat name "-unload-hook"))) (unload-func (intern-soft (concat name "-unload-function")))) diff --git a/lisp/loadup.el b/lisp/loadup.el index f7b36445360..aa15a3bbe8f 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -128,9 +128,11 @@ (set-buffer "*scratch*") (setq buffer-undo-list t) +(load "emacs-lisp/debug-early") (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. @@ -194,11 +196,10 @@ (setq definition-prefixes new)) (load "button") ;After loaddefs, because of define-minor-mode! -(load "emacs-lisp/nadvice") (load "emacs-lisp/cl-preloaded") +(load "emacs-lisp/oclosure") ;Used by cl-generic (load "obarray") ;abbrev.el is implemented in terms of obarrays. (load "abbrev") ;lisp-mode.el and simple.el use define-abbrev-table. -(load "simple") (load "help") @@ -244,11 +245,15 @@ (load "language/khmer") (load "language/burmese") (load "language/cham") +(load "language/philippine") +(load "language/indonesian") (load "indent") (let ((max-specpdl-size (max max-specpdl-size 1800))) ;; A particularly demanding file to load; 1600 does not seem to be enough. (load "emacs-lisp/cl-generic")) +(load "simple") +(load "emacs-lisp/nadvice") (load "minibuffer") ;Needs cl-generic (and define-minor-mode). (load "frame") (load "startup") @@ -302,6 +307,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 @@ -334,6 +344,13 @@ (load "international/mule-util") (load "international/ucs-normalize") (load "term/ns-win")))) +(if (featurep 'pgtk) + (progn + (load "term/common-win") + ;; Don't load ucs-normalize.el unless uni-*.el files were + ;; already produced, because it needs uni-*.el files that might + ;; not be built early enough during bootstrap. + (load "term/pgtk-win"))) (if (fboundp 'x-create-frame) ;; Do it after loading term/foo-win.el since the value of the ;; mouse-wheel-*-event vars depends on those files being loaded or not. @@ -559,6 +576,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/locate.el b/lisp/locate.el index 95b66f275a1..20ef052184e 100644 --- a/lisp/locate.el +++ b/lisp/locate.el @@ -238,6 +238,8 @@ that is, with a prefix arg, you get the default behavior." ;; Functions (defun locate-default-make-command-line (search-string) + (unless (executable-find locate-command) + (error "Can't find the %s command" locate-command)) (list locate-command search-string)) (defun locate-word-at-point () @@ -461,13 +463,11 @@ Specific `locate-mode' commands, such as \\[locate-find-directory], do not work in subdirectories. \\{locate-mode-map}" - ;; Avoid clobbering this variable - (make-local-variable 'dired-subdir-alist) (setq default-directory "/" buffer-read-only t) (add-to-invisibility-spec '(dired . t)) (dired-alist-add-1 default-directory (point-min-marker)) - (setq-local dired-directory "/") + (setq dired-directory "/") (setq-local dired-subdir-switches locate-ls-subdir-switches) (setq dired-switches-alist nil) ;; This should support both Unix and Windoze style names diff --git a/lisp/lpr.el b/lisp/lpr.el index 01617ef912a..88b0607b119 100644 --- a/lisp/lpr.el +++ b/lisp/lpr.el @@ -125,7 +125,7 @@ and print the result." (defcustom print-region-function (if (memq system-type '(ms-dos windows-nt)) (progn - (declare-function w32-direct-print-region-function "w32-fns") + (declare-function w32-direct-print-region-function "dos-w32") #'w32-direct-print-region-function) #'call-process-region) "Function to call to print the region on a printer. diff --git a/lisp/ls-lisp.el b/lisp/ls-lisp.el index 247b07627f3..33dd98ef8d2 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 @@ -795,7 +784,7 @@ SWITCHES and TIME-INDEX give the full switch list and time data." ;; In GNU ls, -h affects the size in blocks, displayed ;; by -s, as well. (if (memq ?h switches) - (format "%6s " + (format "%7s " (file-size-human-readable ;; We use 1K as "block size", although ;; most Windows volumes use 4KB to 8KB @@ -892,7 +881,7 @@ All ls time options, namely c, t and u, are handled." ls-lisp-filesize-f-fmt ls-lisp-filesize-d-fmt) file-size) - (format " %6s" (file-size-human-readable file-size)))) + (format " %7s" (file-size-human-readable file-size)))) (defun ls-lisp-unload-function () "Unload ls-lisp library." @@ -902,7 +891,7 @@ All ls time options, namely c, t and u, are handled." nil) (defun ls-lisp--sanitize-switches (switches) - "Convert long options of GNU 'ls' to their short form. + "Convert long options of GNU \"ls\" to their short form. Conversion is done only for flags supported by ls-lisp. Long options not supported by ls-lisp are removed. Supported options are: A a B C c F G g h i n R r S s t U u v X. diff --git a/lisp/macros.el b/lisp/macros.el index 4cb4e98d3fd..0baf3804332 100644 --- a/lisp/macros.el +++ b/lisp/macros.el @@ -46,6 +46,16 @@ " ") ?\])) +(defun macro--string-to-vector (str) + "Convert an old-style string key sequence to the vector form." + (let ((vec (string-to-vector str))) + (unless (multibyte-string-p str) + (dotimes (i (length vec)) + (let ((k (aref vec i))) + (when (> k 127) + (setf (aref vec i) (+ k ?\M-\C-@ -128)))))) + vec)) + ;;;###autoload (defun insert-kbd-macro (macroname &optional keys) "Insert in buffer the definition of kbd macro MACRONAME, as Lisp code. @@ -72,70 +82,36 @@ use this command, and then save the file." (setq macroname 'last-kbd-macro definition last-kbd-macro) (insert "(setq ")) (setq definition (symbol-function macroname)) - (insert "(fset '")) + ;; Prefer `defalias' over `fset' since it additionally keeps + ;; track of the file where the users added it, and it interacts + ;; better with `advice-add' (and hence things like ELP). + (insert "(defalias '")) (prin1 macroname (current-buffer)) (insert "\n ") - (if (stringp definition) - (let ((beg (point)) end) - (prin1 definition (current-buffer)) - (setq end (point-marker)) - (goto-char beg) - (while (< (point) end) - (let ((char (following-char))) - (cond ((= char 0) - (delete-region (point) (1+ (point))) - (insert "\\C-@")) - ((< char 27) - (delete-region (point) (1+ (point))) - (insert "\\C-" (+ 96 char))) - ((= char ?\C-\\) - (delete-region (point) (1+ (point))) - (insert "\\C-\\\\")) - ((< char 32) - (delete-region (point) (1+ (point))) - (insert "\\C-" (+ 64 char))) - ((< char 127) - (forward-char 1)) - ((= char 127) - (delete-region (point) (1+ (point))) - (insert "\\C-?")) - ((= char 128) - (delete-region (point) (1+ (point))) - (insert "\\M-\\C-@")) - ((= char (aref "\M-\C-\\" 0)) - (delete-region (point) (1+ (point))) - (insert "\\M-\\C-\\\\")) - ((< char 155) - (delete-region (point) (1+ (point))) - (insert "\\M-\\C-" (- char 32))) - ((< char 160) - (delete-region (point) (1+ (point))) - (insert "\\M-\\C-" (- char 64))) - ((= char (aref "\M-\\" 0)) - (delete-region (point) (1+ (point))) - (insert "\\M-\\\\")) - ((< char 255) - (delete-region (point) (1+ (point))) - (insert "\\M-" (- char 128))) - ((= char 255) - (delete-region (point) (1+ (point))) - (insert "\\M-\\C-?")))))) - (if (vectorp definition) - (macros--insert-vector-macro definition) - (pcase (kmacro-extract-lambda definition) - (`(,vecdef ,counter ,format) - (insert "(kmacro-lambda-form ") - (macros--insert-vector-macro vecdef) - (insert " ") - (prin1 counter (current-buffer)) - (insert " ") - (prin1 format (current-buffer)) - (insert ")")) - (_ (prin1 definition (current-buffer)))))) + (when (stringp definition) + (setq definition (macro--string-to-vector definition))) + (if (vectorp definition) + (setq definition (kmacro definition))) + (if (kmacro-p definition) + (let ((vecdef (kmacro--keys definition)) + (counter (kmacro--counter definition)) + (format (kmacro--format definition))) + (insert "(kmacro ") + (prin1 (key-description vecdef) (current-buffer)) + ;; FIXME: Do we really want to store the counter? + (unless (and (equal counter 0) (equal format "%d")) + (insert " ") + (prin1 counter (current-buffer)) + (insert " ") + (prin1 format (current-buffer))) + (insert ")")) + ;; FIXME: Shouldn't this signal an error? + (prin1 definition (current-buffer))) (insert ")\n") (if keys - (let ((keys (or (where-is-internal (symbol-function macroname) - '(keymap)) + (let ((keys (or (and (symbol-function macroname) + (where-is-internal (symbol-function macroname) + '(keymap))) (where-is-internal macroname '(keymap))))) (while keys (insert "(global-set-key ") diff --git a/lisp/mail/emacsbug.el b/lisp/mail/emacsbug.el index 1bda609d105..df2b7a7453b 100644 --- a/lisp/mail/emacsbug.el +++ b/lisp/mail/emacsbug.el @@ -488,7 +488,14 @@ and send the mail again%s." Interactively, you will be prompted for SUBJECT and a patch FILE name (which will be attached to the mail). You will end up in a Message buffer where you can explain more about the patch." - (interactive "sThis patch is about: \nfPatch file name: ") + (interactive + (let* ((file (read-file-name "Patch file name: ")) + (guess (with-temp-buffer + (insert-file-contents file) + (mail-fetch-field "Subject")))) + (list (read-string (format-prompt "This patch is about" guess) + nil nil guess) + file))) (switch-to-buffer "*Patch Help*") (let ((inhibit-read-only t)) (erase-buffer) @@ -509,6 +516,7 @@ Message buffer where you can explain more about the patch." (view-mode 1) (button-mode 1)) (message-mail-other-window report-emacs-bug-address subject) + (message-goto-body) (insert "\n\n\n") (emacs-bug--system-description) (mml-attach-file file "text/patch" nil "attachment") diff --git a/lisp/mail/feedmail.el b/lisp/mail/feedmail.el index fe686cb6f86..af12417f706 100644 --- a/lisp/mail/feedmail.el +++ b/lisp/mail/feedmail.el @@ -1317,7 +1317,7 @@ feedmail-queue-buffer-file-name is restored to nil. Example advice for mail-send: - (advice-add 'mail-send :around #'my-feedmail-mail-send-advice) + (advice-add \\='mail-send :around #\\='my-feedmail-mail-send-advice) (defun my-feedmail-mail-send-advice (orig-fun &rest args) (let ((feedmail-queue-buffer-file-name buffer-file-name) (buffer-file-name nil)) @@ -1619,7 +1619,8 @@ local gurus." (if (null mail-interactive) '("-oem" "-odb"))))) (declare-function smtpmail-via-smtp "smtpmail" - (recipient smtpmail-text-buffer &optional ask-for-password)) + (recipient smtpmail-text-buffer &optional ask-for-password + send-attempts)) (defvar smtpmail-smtp-server) ;; provided by jam@austin.asc.slb.com (James A. McLaughlin); @@ -1742,7 +1743,7 @@ applied to a file after you've just read it from disk: for example, a feedmail FQM message file from a queue. You could use something like this: - (add-to-list 'auto-mode-alist \\='(\"\\\\.fqm\\\\\\='\" . feedmail-vm-mail-mode))" + (add-to-list \\='auto-mode-alist \\='(\"\\\\.fqm\\\\\\='\" . feedmail-vm-mail-mode))" (feedmail-say-debug ">in-> feedmail-vm-mail-mode") (let ((the-buf (current-buffer))) (vm-mail) @@ -2336,19 +2337,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 +2843,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 626fc1982d5..29e16c419be 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/ietf-drums-date.el b/lisp/mail/ietf-drums-date.el new file mode 100644 index 00000000000..ddef7f11b66 --- /dev/null +++ b/lisp/mail/ietf-drums-date.el @@ -0,0 +1,274 @@ +;;; ietf-drums-date.el --- parse time/date for ietf-drums.el -*- lexical-binding: t -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; Author: Bob Rogers <rogers@rgrjr.com> +;; Keywords: mail, util + +;; 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: + +;; 'ietf-drums-parse-date-string' parses a time and/or date in a +;; string and returns a list of values, just like `decode-time', where +;; unspecified elements in the string are returned as nil (except +;; unspecified DST is returned as -1). `encode-time' may be applied +;; on these values to obtain an internal time value. + +;; Historically, `parse-time-string' was used for this purpose, but it +;; was gradually but imperfectly extended to handle other date +;; formats. 'ietf-drums-parse-date-string' is compatible in that it +;; uses the same return value format and parses the same email date +;; formats by default, but can be made stricter if desired. + +;;; Code: + +(require 'cl-lib) +(require 'parse-time) + +(define-error 'date-parse-error "Date/time parse error" 'error) + +(defconst ietf-drums-date--slot-names + '(second minute hour day month year weekday dst zone) + "Names of return value slots, for better error messages +See the decoded-time defstruct.") + +(defconst ietf-drums-date--slot-ranges + '((0 60) (0 59) (0 23) (1 31) (1 12) (1 9999)) + "Numeric slot ranges, for bounds checking. +Note that RFC5322 explicitly requires that seconds go up to 60, +to allow for leap seconds (see Mills, D., \"Network Time +Protocol\", STD 12, RFC 1119, September 1989).") + +(defsubst ietf-drums-date--ignore-char-p (char) + ;; Ignore whitespace and commas. + (memq char '(?\s ?\t ?\r ?\n ?,))) + +(defun ietf-drums-date--tokenize-string (string &optional comment-eof) + "Turn STRING into tokens, separated only by whitespace and commas. +Multiple commas are ignored. Pure digit sequences are turned +into integers. If COMMENT-EOF is true, then a comment as +defined by RFC5322 (strictly, the CFWS production that also +accepts comments) is treated as an end-of-file, and no further +tokens are recognized, otherwise we strip out all comments and +treat them as whitespace (per RFC822)." + (let ((index 0) + (end (length string)) + (list ())) + (cl-flet ((skip-ignored () + ;; Skip ignored characters at index (the scan + ;; position). Skip RFC822 comments in matched parens, + ;; but do not complain about unterminated comments. + (let ((char nil) + (nest 0)) + (while (and (< index end) + (setq char (aref string index)) + (or (> nest 0) + (ietf-drums-date--ignore-char-p char) + (and (not comment-eof) (eql char ?\()))) + (cl-incf index) + ;; FWS bookkeeping. + (cond ((and (eq char ?\\) + (< (1+ index) end)) + ;; Move to the next char but don't check + ;; it to see if it might be a paren. + (cl-incf index)) + ((eq char ?\() (cl-incf nest)) + ((eq char ?\)) (cl-decf nest))))))) + (skip-ignored) ;; Skip leading whitespace. + (while (and (< index end) + (not (and comment-eof + (eq (aref string index) ?\()))) + (let* ((start index) + (char (aref string index)) + (all-digits (<= ?0 char ?9))) + ;; char is valid; look for more valid characters. + (when (and (eq char ?\\) + (< (1+ index) end)) + ;; Escaped character, which might be a "(". If so, we are + ;; correct to include it in the token, even though the + ;; caller is sure to barf. If not, we violate RFC2?822 by + ;; not removing the backslash, but no characters in valid + ;; RFC2?822 dates need escaping anyway, so it shouldn't + ;; matter that this is not done strictly correctly. -- + ;; rgr, 24-Dec-21. + (cl-incf index)) + (while (and (< (cl-incf index) end) + (setq char (aref string index)) + (not (or (ietf-drums-date--ignore-char-p char) + (eq char ?\()))) + (unless (<= ?0 char ?9) + (setq all-digits nil)) + (when (and (eq char ?\\) + (< (1+ index) end)) + ;; Escaped character, see above. + (cl-incf index))) + (push (if all-digits + (cl-parse-integer string :start start :end index) + (substring string start index)) + list) + (skip-ignored))) + (nreverse list)))) + +(defun ietf-drums-parse-date-string (time-string &optional error no-822) + "Parse an RFC5322 or RFC822 date, passed as TIME-STRING. +The optional ERROR parameter causes syntax errors to be flagged +by signalling an instance of the date-parse-error condition. The +optional NO-822 parameter disables the more lax RFC822 syntax, +which is permitted by default. + +The result is a list of (SEC MIN HOUR DAY MON YEAR DOW DST TZ), +which can be accessed as a decoded-time defstruct (q.v.), +e.g. `decoded-time-year' to extract the year, and turned into an +Emacs timestamp by `encode-time'. + +The strict syntax for RFC5322 is as follows: + + [ day-of-week \",\" ] day FWS month-name FWS year FWS time [CFWS] + +where the \"time\" production is: + + 2DIGIT \":\" 2DIGIT [ \":\" 2DIGIT ] FWS ( \"+\" / \"-\" ) 4DIGIT + +and FWS is \"folding white space,\" and CFWS is \"comments and/or +folding white space\", where comments are included in nesting +parentheses and are equivalent to white space. RFC822 also +accepts comments in random places (all of which is handled by +ietf-drums-date--tokenize-string) and two-digit years. For +two-digit years, 50 and up are interpreted as 1950 through 1999 +and 00 through 49 as 200 through 2049. + +We are somewhat more lax in what we accept (specifically, the +hours don't have to be two digits, and the TZ and the comma after +the DOW are optional), but we do insist that the items that are +present do appear in this order. Unspecified/unrecognized +elements in the string are returned as nil (except unspecified +DST is returned as -1)." + (let ((tokens (ietf-drums-date--tokenize-string (downcase time-string) + no-822)) + (time (list nil nil nil nil nil nil nil -1 nil))) + (cl-labels ((set-matched-slot (slot index token) + ;; Assign a slot value from match data if index is + ;; non-nil, else from token, signalling an error if + ;; enabled and it's out of range. + (let ((value (if index + (cl-parse-integer (match-string index token)) + token))) + (when error + (let ((range (nth slot ietf-drums-date--slot-ranges))) + (when (and range + (not (<= (car range) value (cadr range)))) + (signal 'date-parse-error + (list "Slot out of range" + (nth slot ietf-drums-date--slot-names) + token (car range) (cadr range)))))) + (setf (nth slot time) value))) + (set-numeric (slot token) + ;; Only assign the slot if the token is a number. + (cond ((natnump token) + (set-matched-slot slot nil token)) + (error + (signal 'date-parse-error + (list "Not a number" + (nth slot ietf-drums-date--slot-names) + token)))))) + ;; Check for weekday. + (let ((dow (assoc (car tokens) parse-time-weekdays))) + (when dow + ;; Day of the week. + (set-matched-slot 6 nil (cdr dow)) + (pop tokens))) + ;; Day. + (set-numeric 3 (pop tokens)) + ;; Alphabetic month. + (let* ((month (pop tokens)) + (match (assoc month parse-time-months))) + (cond (match + (set-matched-slot 4 nil (cdr match))) + (error + (signal 'date-parse-error + (list "Expected an alphabetic month" month))) + (t + (push month tokens)))) + ;; Year. + (let ((year (pop tokens))) + ;; Check the year for the right number of digits. + (cond ((not (natnump year)) + (when error + (signal 'date-parse-error + (list "Expected a year" year))) + (push year tokens)) + ((>= year 1000) + (set-numeric 5 year)) + ((or no-822 + (>= year 100)) + (when error + (signal 'date-parse-error + (list "Four-digit years are required" year))) + (push year tokens)) + ((>= year 50) + ;; second half of the 20th century. + (set-numeric 5 (+ 1900 year))) + (t + ;; first half of the 21st century. + (set-numeric 5 (+ 2000 year))))) + ;; Time. + (let ((time (pop tokens))) + (cond ((or (null time) (natnump time)) + (when error + (signal 'date-parse-error + (list "Expected a time" time))) + (push time tokens)) + ((string-match + "^\\([0-9][0-9]?\\):\\([0-9][0-9]\\):\\([0-9][0-9]\\)$" + time) + (set-matched-slot 2 1 time) + (set-matched-slot 1 2 time) + (set-matched-slot 0 3 time)) + ((string-match "^\\([0-9][0-9]?\\):\\([0-9][0-9]\\)$" time) + ;; Time without seconds. + (set-matched-slot 2 1 time) + (set-matched-slot 1 2 time) + (set-matched-slot 0 nil 0)) + (error + (signal 'date-parse-error + (list "Expected a time" time))))) + ;; Timezone. + (let* ((zone (pop tokens)) + (match (assoc zone parse-time-zoneinfo))) + (cond (match + (set-matched-slot 8 nil (cadr match)) + (set-matched-slot 7 nil (caddr match))) + ((and (stringp zone) + (string-match "^[-+][0-9][0-9][0-9][0-9]$" zone)) + ;; Numeric time zone. + (set-matched-slot + 8 nil + (* 60 + (+ (cl-parse-integer zone :start 3 :end 5) + (* 60 (cl-parse-integer zone :start 1 :end 3))) + (if (= (aref zone 0) ?-) -1 1)))) + ((and zone error) + (signal 'date-parse-error + (list "Expected a timezone" zone))))) + (when (and tokens error) + (signal 'date-parse-error + (list "Extra token(s)" (car tokens))))) + time)) + +(provide 'ietf-drums-date) + +;;; ietf-drums-date.el ends here diff --git a/lisp/mail/ietf-drums.el b/lisp/mail/ietf-drums.el index 51c3e63e044..d1ad671b160 100644 --- a/lisp/mail/ietf-drums.el +++ b/lisp/mail/ietf-drums.el @@ -25,16 +25,6 @@ ;; library is based on draft-ietf-drums-msg-fmt-05.txt, released on ;; 1998-08-05. -;; Pending a real regression self test suite, Simon Josefsson added -;; various self test expressions snipped from bug reports, and their -;; expected value, below. I you believe it could be useful, please -;; add your own test cases, or write a real self test suite, or just -;; remove this. - -;; <m3oekvfd50.fsf@whitebox.m5r.de> -;; (ietf-drums-parse-address "'foo' <foo@example.com>") -;; => ("foo@example.com" . "'foo'") - ;;; Code: (eval-when-compile (require 'cl-lib)) @@ -75,6 +65,21 @@ backslash and doublequote.") (modify-syntax-entry ?\' "_" table) table)) +(defvar ietf-drums-comment-syntax-table + (let ((table (copy-syntax-table ietf-drums-syntax-table))) + (modify-syntax-entry ?\" "w" table) + table) + "In comments, DQUOTE is normal and does not start a string.") + +(defun ietf-drums--skip-comment () + ;; From just before the start of a comment, go to the end. Returns + ;; point. If the comment is unterminated, go to point-max. + (condition-case () + (with-syntax-table ietf-drums-comment-syntax-table + (forward-sexp 1)) + (scan-error (goto-char (point-max)))) + (point)) + (defun ietf-drums-token-to-list (token) "Translate TOKEN into a list of characters." (let ((i 0) @@ -119,14 +124,7 @@ backslash and doublequote.") (forward-sexp 1) (error (goto-char (point-max))))) ((eq c ?\() - (delete-region - (point) - (condition-case nil - (with-syntax-table (copy-syntax-table ietf-drums-syntax-table) - (modify-syntax-entry ?\" "w") - (forward-sexp 1) - (point)) - (error (point-max))))) + (delete-region (point) (ietf-drums--skip-comment))) (t (forward-char 1)))) (buffer-string)))) @@ -140,9 +138,11 @@ backslash and doublequote.") (setq c (char-after)) (cond ((eq c ?\") - (forward-sexp 1)) + (condition-case () + (forward-sexp 1) + (scan-error (goto-char (point-max))))) ((eq c ?\() - (forward-sexp 1)) + (ietf-drums--skip-comment)) ((memq c '(?\ ?\t ?\n ?\r)) (delete-char 1)) (t @@ -191,6 +191,8 @@ the Content-Transfer-Encoding header of a mail." "Parse STRING and return a MAILBOX / DISPLAY-NAME pair. If DECODE, the DISPLAY-NAME will have RFC2047 decoding performed (that's the \"=?utf...q...=?\") stuff." + (when decode + (require 'rfc2047)) (with-temp-buffer (let (display-name mailbox c display-string) (ietf-drums-init string) @@ -240,7 +242,7 @@ If DECODE, the DISPLAY-NAME will have RFC2047 decoding performed (cons (mapconcat #'identity (nreverse display-name) "") (ietf-drums-get-comment string))) - (cons mailbox (if decode + (cons mailbox (if (and decode display-string) (rfc2047-decode-string display-string) display-string)))))) @@ -292,9 +294,13 @@ a list of address strings." (replace-match " " t t)) (goto-char (point-min))) +(declare-function ietf-drums-parse-date-string "ietf-drums-date" + (time-string &optional error? no-822?)) + (defun ietf-drums-parse-date (string) "Return an Emacs time spec from STRING." - (encode-time (parse-time-string string))) + (require 'ietf-drums-date) + (encode-time (ietf-drums-parse-date-string string))) (defun ietf-drums-narrow-to-header () "Narrow to the header section in the current buffer." diff --git a/lisp/mail/mail-parse.el b/lisp/mail/mail-parse.el index 23894e59b77..ec719850e2e 100644 --- a/lisp/mail/mail-parse.el +++ b/lisp/mail/mail-parse.el @@ -76,7 +76,8 @@ The return value is a list with mail/name pairs." (delq nil (mapcar (lambda (elem) - (or (mail-header-parse-address elem) + (or (ignore-errors + (mail-header-parse-address elem)) (mail-header-parse-address-lax elem))) (mail-header-parse-addresses string t)))) diff --git a/lisp/mail/mail-utils.el b/lisp/mail/mail-utils.el index 9711dc7db12..952970d07c0 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/rfc2047.el b/lisp/mail/rfc2047.el index b3c45100f6d..bb0d646346c 100644 --- a/lisp/mail/rfc2047.el +++ b/lisp/mail/rfc2047.el @@ -46,7 +46,7 @@ ("Followup-To" . nil) ("Message-ID" . nil) ("\\(Resent-\\)?\\(From\\|Cc\\|To\\|Bcc\\|\\(In-\\)?Reply-To\\|Sender\ -\\|Mail-Followup-To\\|Mail-Copies-To\\|Approved\\)" . address-mime) +\\|Mail-Followup-To\\|Mail-Copies-To\\|Approved\\|Disposition-Notification-To\\)" . address-mime) (t . mime)) "Header/encoding method alist. The list is traversed sequentially. The keys can either be diff --git a/lisp/mail/rmail.el b/lisp/mail/rmail.el index 49eaeb560e0..adb61aa09db 100644 --- a/lisp/mail/rmail.el +++ b/lisp/mail/rmail.el @@ -41,8 +41,6 @@ (require 'rfc2047) (require 'auth-source) -(require 'rmail-loaddefs) - (declare-function compilation--message->loc "compile" (cl-x) t) (declare-function epa--find-coding-system-for-mime-charset "epa" (mime-charset)) @@ -539,7 +537,7 @@ Examples: ;; Note: this is matched with case-fold-search bound to t. (defcustom rmail-re-abbrevs "\\(RE\\|رد\\|回复\\|回覆\\|SV\\|Antw\\|VS\\|REF\\|AW\\|ΑΠ\\|ΣΧΕΤ\\|השב\\|Vá\\|R\\|RIF\\|BLS\\|RES\\|Odp\\|YNT\\|ATB\\)" - "Regexp with localized 'Re:' abbreviations in various languages." + "Regexp with localized \"Re:\" abbreviations in various languages." :version "28.1" :type 'regexp) @@ -4125,10 +4123,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 +4132,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) @@ -4497,10 +4489,7 @@ password." :max 1 :user user :host host :require '(:secret))))) (if found - (let ((secret (plist-get found :secret))) - (if (functionp secret) - (funcall secret) - secret)) + (auth-info-password found) (read-passwd (if imap "IMAP password: " "POP password: ")))))) @@ -4603,8 +4592,6 @@ Argument MIME is non-nil if this is a mime message." armor-end-regexp (buffer-substring armor-start (- (point-max) after-end))))) -(declare-function rmail-mime-entity-truncated "rmailmm" (entity)) - ;; Should this have a key-binding, or be in a menu? ;; There doesn't really seem to be an appropriate menu. ;; Eg the edit command is not in a menu either. diff --git a/lisp/mail/rmailedit.el b/lisp/mail/rmailedit.el index d6eee405dd1..79bd02fd67e 100644 --- a/lisp/mail/rmailedit.el +++ b/lisp/mail/rmailedit.el @@ -484,8 +484,4 @@ HEADER-DIFF should be a return value from `rmail-edit-diff-headers'." (provide 'rmailedit) -;; Local Variables: -;; generated-autoload-file: "rmail-loaddefs.el" -;; End: - ;;; rmailedit.el ends here diff --git a/lisp/mail/rmailkwd.el b/lisp/mail/rmailkwd.el index f2b80b689f1..6535d68456b 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)))) @@ -191,8 +188,4 @@ With prefix argument N moves forward N messages with these labels." (provide 'rmailkwd) -;; Local Variables: -;; generated-autoload-file: "rmail-loaddefs.el" -;; End: - ;;; rmailkwd.el ends here diff --git a/lisp/mail/rmailmm.el b/lisp/mail/rmailmm.el index 0d0e83f2a58..79f421bdcd6 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)) @@ -796,17 +796,14 @@ directly." ((string-match "text/" content-type) (setq type 'text)) ((string-match "image/\\(.*\\)" content-type) - (setq type (image-type-from-file-name + (setq type (image-supported-file-p (concat "." (match-string 1 content-type)))) - (if (and (boundp 'image-types) - (memq type image-types) - (image-type-available-p type)) - (if (and rmail-mime-show-images - (not (eq rmail-mime-show-images 'button)) - (or (not (numberp rmail-mime-show-images)) - (< size rmail-mime-show-images))) - (setq to-show t)) - (setq type nil)))) + (when (and type + rmail-mime-show-images + (not (eq rmail-mime-show-images 'button)) + (or (not (numberp rmail-mime-show-images)) + (< size rmail-mime-show-images))) + (setq to-show t)))) (setcar bulk-data size) (setcdr bulk-data type) to-show)) @@ -1569,8 +1566,4 @@ This is the usual value of `rmail-insert-mime-forwarded-message-function'." (provide 'rmailmm) -;; Local Variables: -;; generated-autoload-file: "rmail-loaddefs.el" -;; End: - ;;; rmailmm.el ends here diff --git a/lisp/mail/rmailmsc.el b/lisp/mail/rmailmsc.el index 26bf651f22d..93463af46cf 100644 --- a/lisp/mail/rmailmsc.el +++ b/lisp/mail/rmailmsc.el @@ -54,8 +54,4 @@ This applies only to the current session." (setq rmail-inbox-list inbox-list))) (rmail-show-message-1 rmail-current-message)) -;; Local Variables: -;; generated-autoload-file: "rmail-loaddefs.el" -;; End: - ;;; rmailmsc.el ends here diff --git a/lisp/mail/rmailout.el b/lisp/mail/rmailout.el index 0d996e65403..c1371308d4f 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/rmailsort.el b/lisp/mail/rmailsort.el index d6fe312efe3..c203cf858e5 100644 --- a/lisp/mail/rmailsort.el +++ b/lisp/mail/rmailsort.el @@ -250,8 +250,4 @@ Numeric keys are sorted numerically, all others as strings." (provide 'rmailsort) -;; Local Variables: -;; generated-autoload-file: "rmail-loaddefs.el" -;; End: - ;;; rmailsort.el ends here diff --git a/lisp/mail/rmailsum.el b/lisp/mail/rmailsum.el index 54dce3c4673..b23fbc3f600 100644 --- a/lisp/mail/rmailsum.el +++ b/lisp/mail/rmailsum.el @@ -1475,18 +1475,16 @@ argument says to read a file name and use that file as the inbox." (forward-line -1)) (declare-function rmail-abort-edit "rmailedit" ()) -(declare-function rmail-cease-edit "rmailedit"()) +(declare-function rmail-cease-edit "rmailedit" (&optional abort)) (declare-function rmail-set-label "rmailkwd" (l state &optional n)) (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." @@ -1879,8 +1877,4 @@ the summary is only showing a subset of messages." (provide 'rmailsum) -;; Local Variables: -;; generated-autoload-file: "rmail-loaddefs.el" -;; End: - ;;; rmailsum.el ends here diff --git a/lisp/mail/sendmail.el b/lisp/mail/sendmail.el index ccb112cda6f..c55cdc8412a 100644 --- a/lisp/mail/sendmail.el +++ b/lisp/mail/sendmail.el @@ -877,7 +877,7 @@ The variable is used to trigger insertion of the \"Mail-Followup-To\" header when sending a message to a mailing list." :type '(repeat string)) -(declare-function mml-to-mime "mml" ()) +(declare-function mm-long-lines-p "mm-bodies" (length)) (defun mail-send () "Send the message in the current buffer. @@ -955,7 +955,11 @@ the user from the mailer." (error "Invalid header line (maybe a continuation line lacks initial whitespace)")) (forward-line 1))) (goto-char opoint) - (when mail-encode-mml + (require 'mml) + (when (or mail-encode-mml + ;; When we have long lines, we have to MIME encode + ;; to get line folding. + (mm-long-lines-p 1000)) (mml-to-mime) (setq mail-encode-mml nil)) (run-hooks 'mail-send-hook) @@ -1391,8 +1395,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 +1411,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/smtpmail.el b/lisp/mail/smtpmail.el index 8ac0cd7e7c0..88e55e968c4 100644 --- a/lisp/mail/smtpmail.el +++ b/lisp/mail/smtpmail.el @@ -554,11 +554,9 @@ for `smtpmail-try-auth-method'.") :create ask-for-password))) (mech (or (plist-get auth-info :smtp-auth) (car mechs))) (user (plist-get auth-info :user)) - (password (plist-get auth-info :secret)) + (password (auth-info-password auth-info)) (save-function (and ask-for-password (plist-get auth-info :save-function)))) - (when (functionp password) - (setq password (funcall password))) (when (and user (not password)) ;; The user has stored the user name, but not the password, so @@ -573,9 +571,7 @@ for `smtpmail-try-auth-method'.") :user smtpmail-smtp-user :require '(:user :secret) :create t)) - password (plist-get auth-info :secret))) - (when (functionp password) - (setq password (funcall password))) + password (auth-info-password auth-info))) (let ((result (catch 'done (if (and mech user password) (smtpmail-try-auth-method process mech user password) diff --git a/lisp/mail/supercite.el b/lisp/mail/supercite.el index b56ceed2cc0..5dc5ee38ffd 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 9e367dc6349..2672cfca1fb 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/mail/undigest.el b/lisp/mail/undigest.el index 03e77a83ce3..c6d29bc4e77 100644 --- a/lisp/mail/undigest.el +++ b/lisp/mail/undigest.el @@ -41,7 +41,8 @@ You may need to customize it for local needs." (defconst rmail-digest-methods - '(rmail-digest-parse-mime + '(rmail-digest-parse-mixed-mime + rmail-digest-parse-mime rmail-digest-parse-rfc1153strict rmail-digest-parse-rfc1153sloppy rmail-digest-parse-rfc934) @@ -52,6 +53,53 @@ A function returns nil if it cannot parse the digest. If it can, it returns a list of cons pairs containing the start and end positions of each undigestified message as markers.") +(defun rmail-content-type-boundary (type) + "If Content-type is of type TYPE, return its boundary; otherwise, return nil." + (goto-char (point-min)) + (let ((head-end (save-excursion (search-forward "\n\n" nil t) (point)))) + (when (re-search-forward + (concat "^Content-type: " type ";" + "\\s-* boundary=\"?\\([^\";\n]+\\)[\";\n]") + head-end t) + (match-string 1)))) + +(defun rmail-digest-parse-mixed-mime () + "Like `rmail-digest-parse-mime', but for multipart/mixed messages." + (when-let ((boundary (rmail-content-type-boundary "multipart/mixed"))) + (let ((global-sep (concat "\n--" boundary)) + (digest (concat "^Content-type: multipart/digest;" + "\\s-* boundary=\"?\\([^\";\n]+\\)[\";\n]")) + result) + (search-forward global-sep nil t) + (while (not (or result (eobp))) + ;; For each part, see if it is a multipart/digest. + (let* ((limit (save-excursion (search-forward global-sep nil 'move) + (point))) + (beg (and (re-search-forward digest limit t) + (match-beginning 0))) + digest-sep) + (when (and beg + (setq digest-sep (concat "\n--" (match-string 1))) + ;; Search for 1st sep. + (search-forward digest-sep nil t)) + ;; Skip body part headers. + (search-forward "\n\n" nil t) + ;; Push the 1st message. + (push (cons (copy-marker beg) (copy-marker (point-marker) t)) + result) + ;; Push the rest of the messages. + (let ((start (make-marker)) + done) + (while (and (search-forward digest-sep limit 'move) (not done)) + (move-marker start (match-beginning 0)) + (and (looking-at "--$") (setq done t)) + (search-forward "\n\n") + (push (cons (copy-marker start) + (copy-marker (point-marker) t)) + result)))) + (goto-char limit))) + (nreverse result)))) + (defun rmail-digest-parse-mime () (goto-char (point-min)) (when (let ((head-end (progn (search-forward "\n\n" nil t) (point)))) diff --git a/lisp/man.el b/lisp/man.el index a5ff2371494..951e0ef9add 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))) @@ -1970,6 +1976,34 @@ Uses `Man-name-local-regexp'." (bookmark-default-handler `("" (buffer . ,buf) . ,(bookmark-get-bookmark-record bookmark))))) +(put 'Man-bookmark-jump 'bookmark-handler-type "Man") + +;;; Mouse support +(defun Man-at-mouse (e) + "Open man manual at point." + (interactive "e") + (save-excursion + (mouse-set-point e) + (man (Man-default-man-entry)))) + +;;;###autoload +(defun Man-context-menu (menu click) + "Populate MENU with commands that open a man page at point." + (save-excursion + (mouse-set-point click) + (when (save-excursion + (skip-syntax-backward "^ ") + (and (looking-at + "[[:space:]]*\\([[:alnum:]_-]+([[:alnum:]]+)\\)") + (match-string 1))) + (define-key-after menu [man-separator] menu-bar-separator + 'middle-separator) + (define-key-after menu [man-at-mouse] + '(menu-item "Open man page" Man-at-mouse + :help "Open man page around mouse click") + 'man-separator))) + menu) + ;; Init the man package variables, if not already done. (Man-init-defvars) diff --git a/lisp/menu-bar.el b/lisp/menu-bar.el index 849d400be6f..488bf05f3ab 100644 --- a/lisp/menu-bar.el +++ b/lisp/menu-bar.el @@ -96,18 +96,28 @@ (bindings--define-key menu [separator-print] menu-bar-separator) - (unless (featurep 'ns) - (bindings--define-key menu [close-tab] - '(menu-item "Close Tab" tab-close - :visible (fboundp 'tab-close) - :help "Close currently selected tab")) - (bindings--define-key menu [make-tab] - '(menu-item "New Tab" tab-new - :visible (fboundp 'tab-new) - :help "Open a new tab")) - - (bindings--define-key menu [separator-tab] - menu-bar-separator)) + (bindings--define-key menu [close-tab] + '(menu-item "Close Tab" tab-close + :visible (fboundp 'tab-close) + :help "Close currently selected tab")) + (bindings--define-key menu [make-tab] + '(menu-item "New Tab" tab-new + :visible (fboundp 'tab-new) + :help "Open a new tab")) + + (bindings--define-key menu [separator-tab] + menu-bar-separator) + + (bindings--define-key menu [undelete-frame-mode] + '(menu-item "Allow Undeleting Frames" undelete-frame-mode + :help "Allow frames to be restored after deletion" + :button (:toggle . undelete-frame-mode))) + + (bindings--define-key menu [undelete-last-deleted-frame] + '(menu-item "Undelete Frame" undelete-frame + :enable (and undelete-frame-mode + (car undelete-frame--deleted-frames)) + :help "Undelete the most recently deleted frame")) ;; Don't use delete-frame as event name because that is a special ;; event. @@ -121,9 +131,9 @@ :visible (fboundp 'make-frame-on-monitor) :help "Open a new frame on another monitor")) (bindings--define-key menu [make-frame-on-display] - '(menu-item "New Frame on Display..." make-frame-on-display + '(menu-item "New Frame on Display Server..." make-frame-on-display :visible (fboundp 'make-frame-on-display) - :help "Open a new frame on another display")) + :help "Open a new frame on a display server")) (bindings--define-key menu [make-frame] '(menu-item "New Frame" make-frame-command :visible (fboundp 'make-frame-command) @@ -168,17 +178,23 @@ t)) :help "Recover edits from a crashed session")) (bindings--define-key menu [revert-buffer] - '(menu-item "Revert Buffer" revert-buffer - :enable (or (not (eq revert-buffer-function - 'revert-buffer--default)) - (not (eq - revert-buffer-insert-file-contents-function - 'revert-buffer-insert-file-contents--default-function)) - (and buffer-file-number - (or (buffer-modified-p) - (not (verify-visited-file-modtime - (current-buffer)))))) - :help "Re-read current buffer from its file")) + '(menu-item + "Revert Buffer" revert-buffer + :enable + (or (not (eq revert-buffer-function + 'revert-buffer--default)) + (not (eq + revert-buffer-insert-file-contents-function + 'revert-buffer-insert-file-contents--default-function)) + (and buffer-file-number + (or (buffer-modified-p) + (not (verify-visited-file-modtime + (current-buffer))) + ;; Enable if the buffer has a different + ;; writeability than the file. + (not (eq (not buffer-read-only) + (file-writable-p buffer-file-name)))))) + :help "Re-read current buffer from its file")) (bindings--define-key menu [write-file] '(menu-item "Save As..." write-file :enable (and (menu-bar-menu-frame-live-and-visible-p) @@ -295,7 +311,7 @@ (isearch-update-ring string t) (re-search-backward string))) -;; The Edit->Search->Incremental Search menu +;; The Edit->Incremental Search menu (defvar menu-bar-i-search-menu (let ((menu (make-sparse-keymap "Incremental Search"))) (bindings--define-key menu [isearch-forward-symbol-at-point] @@ -323,12 +339,6 @@ (defvar menu-bar-search-menu (let ((menu (make-sparse-keymap "Search"))) - - (bindings--define-key menu [i-search] - `(menu-item "Incremental Search" ,menu-bar-i-search-menu)) - (bindings--define-key menu [separator-tag-isearch] - menu-bar-separator) - (bindings--define-key menu [tags-continue] '(menu-item "Continue Tags Search" fileloop-continue :enable (and (featurep 'fileloop) @@ -413,8 +423,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")) @@ -479,6 +495,9 @@ (bindings--define-key menu [replace] `(menu-item "Replace" ,menu-bar-replace-menu)) + (bindings--define-key menu [i-search] + `(menu-item "Incremental Search" ,menu-bar-i-search-menu)) + (bindings--define-key menu [search] `(menu-item "Search" ,menu-bar-search-menu)) @@ -514,7 +533,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 +546,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)) @@ -571,7 +603,8 @@ "Insert the clipboard contents, or the last stretch of killed text." (interactive "*") (let ((select-enable-clipboard t) - ;; Ensure that we defeat the DWIM login in `gui-selection-value'. + ;; Ensure that we defeat the DWIM logic in `gui-selection-value' + ;; (i.e., that gui--clipboard-selection-unchanged-p returns nil). (gui--last-selected-text-clipboard nil)) (yank))) @@ -1328,14 +1361,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 +1950,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 +2192,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 +2221,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 () @@ -2284,8 +2320,29 @@ Buffers menu is regenerated." (cdr elt))) buf))) -;; Used to cache the menu entries for commands in the Buffers menu -(defvar menu-bar-buffers-menu-command-entries nil) +(defvar menu-bar-buffers-menu-command-entries + (list '(command-separator "--") + (list 'next-buffer + 'menu-item + "Next Buffer" + 'next-buffer + :help "Switch to the \"next\" buffer in a cyclic order") + (list 'previous-buffer + 'menu-item + "Previous Buffer" + 'previous-buffer + :help "Switch to the \"previous\" buffer in a cyclic order") + (list 'select-named-buffer + 'menu-item + "Select Named Buffer..." + 'switch-to-buffer + :help "Prompt for a buffer name, and select that buffer in the current window") + (list 'list-all-buffers + 'menu-item + "List All Buffers" + 'list-buffers + :help "Pop up a window listing all Emacs buffers")) + "Entries to be included at the end of the \"Buffers\" menu.") (defvar menu-bar-select-buffer-function 'switch-to-buffer "Function to select the buffer chosen from the `Buffers' menu-bar menu. @@ -2310,9 +2367,13 @@ It must accept a buffer as its only required argument.") (and (lookup-key (current-global-map) [menu-bar buffer]) (or force (frame-or-buffer-changed-p)) (let ((buffers (buffer-list)) - (frames (frame-list)) - buffers-menu) - + frames buffers-menu) + ;; Ignore the initial frame if present. It can happen if + ;; Emacs was started as a daemon. (bug#53740) + (dolist (frame (frame-list)) + (unless (equal (terminal-name (frame-terminal frame)) + "initial_terminal") + (push frame frames))) ;; Make the menu of buffers proper. (setq buffers-menu (let ((i 0) @@ -2366,35 +2427,7 @@ It must accept a buffer as its only required argument.") `((frames-separator "--") (frames menu-item "Frames" ,frames-menu)))))) - ;; Add in some normal commands at the end of the menu. We use - ;; the copy cached in `menu-bar-buffers-menu-command-entries' - ;; if it's been set already. Note that we can't use constant - ;; lists for the menu-entries, because the low-level menu-code - ;; modifies them. - (unless menu-bar-buffers-menu-command-entries - (setq menu-bar-buffers-menu-command-entries - (list '(command-separator "--") - (list 'next-buffer - 'menu-item - "Next Buffer" - 'next-buffer - :help "Switch to the \"next\" buffer in a cyclic order") - (list 'previous-buffer - 'menu-item - "Previous Buffer" - 'previous-buffer - :help "Switch to the \"previous\" buffer in a cyclic order") - (list 'select-named-buffer - 'menu-item - "Select Named Buffer..." - 'switch-to-buffer - :help "Prompt for a buffer name, and select that buffer in the current window") - (list 'list-all-buffers - 'menu-item - "List All Buffers" - 'list-buffers - :help "Pop up a window listing all Emacs buffers" - )))) + ;; Add in some normal commands at the end of the menu. (setq buffers-menu (nconc buffers-menu menu-bar-buffers-menu-command-entries)) @@ -2505,7 +2538,7 @@ Use \\[menu-bar-mode] to make the menu bar appear.")))) (put 'menu-bar-mode 'standard-value '(t)) (defun toggle-menu-bar-mode-from-frame (&optional arg) - "Toggle display of the menu bar of the current frame. + "Toggle display of the menu bar. See `menu-bar-mode' for more information." (interactive (list (or current-prefix-arg 'toggle))) (if (eq arg 'toggle) @@ -2517,6 +2550,8 @@ 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 pgtk-menu-bar-open "term/pgtk-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." @@ -2595,8 +2630,11 @@ FROM-MENU-BAR, if non-nil, means we are dropping one of menu-bar's menus." ;; `setup-specified-language-environment', for instance, ;; expects this to be set from a menu keymap. (setq last-command-event (car (last event))) - ;; mouse-major-mode-menu was using `command-execute' instead. - (call-interactively cmd)))) + (setq from--tty-menu-p nil) + ;; Signal use-dialog-box-p this command was invoked from a menu. + (let ((from--tty-menu-p t)) + ;; mouse-major-mode-menu was using `command-execute' instead. + (call-interactively cmd))))) (defun popup-menu-normalize-position (position) "Convert the POSITION to the form which `popup-menu' expects internally. @@ -2642,9 +2680,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 +2692,8 @@ 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)) + ((eq type 'pgtk) (pgtk-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 f49a5fbab25..805b0820b03 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 2a11aa979c0..f39caac893d 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 0c9b72c51d3..a9f6274e9d4 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 ab585409184..7a09429e4ef 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 059a8e08813..872f0d79d29 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 1388f393b09..09df0465eda 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 8a8922b77c7..ef0a76b9a49 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 5b587a2b805..c341b096834 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 63a2d98129c..43eaeb7aa0f 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 0a71e6b67a3..4e3e1012315 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 edb0df83208..3e731e22a1f 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 @@ -143,7 +143,7 @@ Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command." ;;; Support Routines (defun mh-subject-to-sequence (all) - "Put all following messages with same subject in sequence 'subject. + "Put all following messages with same subject in sequence `subject'. If arg ALL is t, move to beginning of folder buffer to collect all messages. If arg ALL is nil, collect only messages from current one on forward. @@ -161,7 +161,7 @@ Return number of messages put in the sequence: (mh-subject-to-sequence-unthreaded all))) (defun mh-subject-to-sequence-threaded (all) - "Put all messages with the same subject in the 'subject sequence. + "Put all messages with the same subject in the `subject' sequence. This function works when the folder is threaded. In this situation the subject could get truncated and so the normal @@ -192,7 +192,7 @@ are taken into account." It would be desirable to avoid hard-coding this.") (defun mh-subject-to-sequence-unthreaded (all) - "Put all following messages with same subject in sequence 'subject. + "Put all following messages with same subject in sequence `subject'. This function only works with an unthreaded folder. If arg ALL is t, move to beginning of folder buffer to collect all messages. If @@ -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 0630fa92b1f..d2e07977e5d 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)) @@ -1796,11 +1764,10 @@ initialized. Always use the command `mh-have-file-command'.") ;;;###mh-autoload (defun mh-have-file-command () "Return t if `file' command is on the system. -'file -i' is used to get MIME type of composition insertion." +\"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 c2affb10d99..06381a2e0ed 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 c078c9f91b0..c5519eba0ac 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 f87aaa5f15e..a95c7c03d17 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 e6eddef8dcd..cc76b8d7e61 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 862ddbcab56..a7e9c9bd678 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 de90e97da7a..139e9b74cbb 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 00a9fa724c5..17df075cfac 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 6e5337d9606..d7a92be5b5f 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 7e5f469319b..b144c58d696 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 4617ec293d8..3e309a5c881 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 0ef846ccd78..cdbde2d3405 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-2022 Free Software Foundation, Inc. @@ -864,7 +864,11 @@ Intended to be called via `clear-message-function'." (setq minibuffer-message-timer nil)) (when (overlayp minibuffer-message-overlay) (delete-overlay minibuffer-message-overlay) - (setq minibuffer-message-overlay nil)))) + (setq minibuffer-message-overlay nil))) + + ;; Return nil telling the caller that the message + ;; should be also handled by the caller. + nil) (setq clear-message-function 'clear-minibuffer-message) @@ -894,13 +898,25 @@ If the current buffer is not a minibuffer, erase its entire contents." (defcustom completion-auto-help t "Non-nil means automatically provide help for invalid completion input. -If the value is t the *Completions* buffer is displayed whenever completion +If the value is t, the *Completions* buffer is displayed whenever completion is requested but cannot be done. If the value is `lazy', the *Completions* buffer is only displayed after -the second failed attempt to complete." - :type '(choice (const nil) (const t) (const lazy))) - -(defconst completion-styles-alist +the second failed attempt to complete. +If the value is `always', the *Completions* buffer is always shown +after a completion attempt, and the list of completions is updated if +already visible. +If the value is `visible', the *Completions* buffer is displayed +whenever completion is requested but cannot be done for the first time, +but remains visible thereafter, and the list of completions in it is +updated for subsequent attempts to complete.." + :type '(choice (const :tag "Don't show" nil) + (const :tag "Show only when cannot complete" t) + (const :tag "Show after second failed completion attempt" lazy) + (const :tag + "Leave visible after first failed completion" visible) + (const :tag "Always visible" always))) + +(defvar completion-styles-alist '((emacs21 completion-emacs21-try-completion completion-emacs21-all-completions "Simple prefix-based completion. @@ -1008,7 +1024,9 @@ an association list that can specify properties such as: - `styles': the list of `completion-styles' to use for that category. - `cycle': the `completion-cycle-threshold' to use for that category. Categories are symbols such as `buffer' and `file', used when -completing buffer and file names, respectively.") +completing buffer and file names, respectively. + +Also see `completion-category-overrides'.") (defcustom completion-category-overrides nil "List of category-specific user overrides for completion styles. @@ -1018,7 +1036,9 @@ an association list that can specify properties such as: - `cycle': the `completion-cycle-threshold' to use for that category. Categories are symbols such as `buffer' and `file', used when completing buffer and file names, respectively. -This overrides the defaults specified in `completion-category-defaults'." + +If a property in a category is specified by this variable, it +overrides the default specified in `completion-category-defaults'." :version "25.1" :type `(alist :key-type (choice :tag "Category" (const buffer) @@ -1080,9 +1100,10 @@ This overrides the defaults specified in `completion-category-defaults'." (result-and-style (completion--some (lambda (style) - (let ((probe (funcall (nth n (assq style - completion-styles-alist)) - string table pred point))) + (let ((probe (funcall + (or (nth n (assq style completion-styles-alist)) + (error "Invalid completion style %s" style)) + string table pred point))) (and probe (cons probe style)))) (completion--styles md))) (adjust-fn (get (cdr result-and-style) 'completion--adjust-metadata))) @@ -1123,6 +1144,7 @@ Moves point to the end of the new text." ;; The properties on `newtext' include things like the ;; `completions-first-difference' face, which we don't want to ;; include upon insertion. + (setq newtext (copy-sequence newtext)) ;Don't modify the arg by side-effect. (if minibuffer-allow-text-properties ;; If we're preserving properties, then just remove the faces ;; and other properties added by the completion machinery. @@ -1172,6 +1194,18 @@ completion candidates than this number." :version "24.1" :type completion--cycling-threshold-type) +(defcustom completions-sort 'alphabetical + "Sort candidates in the *Completions* buffer. + +The value can be nil to disable sorting, `alphabetical' for +alphabetical sorting or a custom sorting function. The sorting +function takes and returns a list of completion candidate +strings." + :type '(choice (const :tag "No sorting" nil) + (const :tag "Alphabetical sorting" alphabetical) + (function :tag "Custom function")) + :version "29.1") + (defcustom completions-group nil "Enable grouping of completion candidates in the *Completions* buffer. See also `completions-group-format' and `completions-group-sort'." @@ -1330,16 +1364,18 @@ when the buffer's text is already an exact match." (completion--cache-all-sorted-completions beg end comps) (minibuffer-force-complete beg end)) (completed - ;; We could also decide to refresh the completions, - ;; if they're displayed (and assuming there are - ;; completions left). - (minibuffer-hide-completions) - (if exact - ;; If completion did not put point at end of field, - ;; it's a sign that completion is not finished. - (completion--done completion - (if (< comp-pos (length completion)) - 'exact 'unknown)))) + (cond + ((pcase completion-auto-help + ('visible (get-buffer-window "*Completions*" 0)) + ('always t)) + (minibuffer-completion-help beg end)) + (t (minibuffer-hide-completions) + (when exact + ;; If completion did not put point at end of field, + ;; it's a sign that completion is not finished. + (completion--done completion + (if (< comp-pos (length completion)) + 'exact 'unknown)))))) ;; Show the completion table, if requested. ((not exact) (if (pcase completion-auto-help @@ -1385,20 +1421,40 @@ scroll the window of possible completions." (eq t (frame-visible-p (window-frame minibuffer-scroll-window)))) (let ((window minibuffer-scroll-window)) (with-current-buffer (window-buffer window) - (if (pos-visible-in-window-p (point-max) window) - ;; If end is in view, scroll up to the beginning. - (set-window-start window (point-min) nil) - ;; Else scroll down one screen. - (with-selected-window window - (scroll-up))) - nil))) + (cond + ;; Here this is possible only when second-tab, but instead of + ;; scrolling the completion list window, switch to it below, + ;; outside of `with-current-buffer'. + ((eq completion-auto-select 'second-tab)) + ;; Reverse tab + ((equal (this-command-keys) [backtab]) + (if (pos-visible-in-window-p (point-min) window) + ;; If beginning is in view, scroll up to the end. + (set-window-point window (point-max)) + ;; Else scroll down one screen. + (with-selected-window window (scroll-down)))) + ;; Normal tab + (t + (if (pos-visible-in-window-p (point-max) window) + ;; If end is in view, scroll up to the end. + (set-window-start window (point-min) nil) + ;; Else scroll down one screen. + (with-selected-window window (scroll-up)))))) + (when (eq completion-auto-select 'second-tab) + (switch-to-completions)) + nil)) ;; If we're cycling, keep on cycling. ((and completion-cycling completion-all-sorted-completions) (minibuffer-force-complete beg end) t) - (t (pcase (completion--do-completion beg end) - (#b000 nil) - (_ t))))) + (t (prog1 (pcase (completion--do-completion beg end) + (#b000 nil) + (_ t)) + (when (and (eq completion-auto-select t) + (window-live-p minibuffer-scroll-window) + (eq t (frame-visible-p (window-frame minibuffer-scroll-window)))) + ;; When the completion list window was displayed, select it. + (switch-to-completions)))))) (defun completion--cache-all-sorted-completions (beg end comps) (add-hook 'after-change-functions @@ -1825,6 +1881,17 @@ Return nil if there is no valid completion, else t." This face is only used if the strings used for completions doesn't already specify a face.") +(defface completions-highlight + '((t :inherit highlight)) + "Default face for highlighting the current completion candidate." + :version "29.1") + +(defcustom completions-highlight-face 'completions-highlight + "A face name to highlight the current completion candidate. +If the value is nil, no highlighting is performed." + :type '(choice (const nil) face) + :version "29.1") + (defcustom completions-format 'horizontal "Define the appearance and sorting of completions. If the value is `vertical', display completions sorted vertically @@ -1844,6 +1911,15 @@ completions." :type 'boolean :version "28.1") +(defcustom completions-header-format + (propertize "%s possible completions:\n" 'face 'shadow) + "Format of completions header. +It may contain one %s to show the total count of completions. +When nil, no header is shown." + :type '(choice (const :tag "No header" nil) + (string :tag "Header format string")) + :version "29.1") + (defun completion--insert-strings (strings &optional group-fun) "Insert a list of STRINGS into the current buffer. The candidate strings are inserted into the buffer depending on the @@ -1983,7 +2059,8 @@ Runs of equal candidate strings are eliminated. GROUP-FUN is a (when title (insert (format completions-group-format title) "\n"))))) (completion--insert str group-fun) - (insert "\n"))))) + (insert "\n"))) + (delete-char -1))) (defun completion--insert (str group-fun) (if (not (consp str)) @@ -1995,7 +2072,7 @@ Runs of equal candidate strings are eliminated. GROUP-FUN is a (funcall group-fun str 'transform) str)) (point)) - `(mouse-face highlight completion--string ,str)) + `(mouse-face highlight cursor-face ,completions-highlight-face completion--string ,str)) ;; If `str' is a list that has 2 elements, ;; then the second element is a suffix annotation. ;; If `str' has 3 elements, then the second element @@ -2005,11 +2082,11 @@ Runs of equal candidate strings are eliminated. GROUP-FUN is a (when prefix (let ((beg (point)) (end (progn (insert prefix) (point)))) - (put-text-property beg end 'mouse-face nil))) + (add-text-properties beg end `(mouse-face nil completion--string ,(car str))))) (completion--insert (car str) group-fun) (let ((beg (point)) (end (progn (insert suffix) (point)))) - (put-text-property beg end 'mouse-face nil) + (add-text-properties beg end `(mouse-face nil completion--string ,(car str))) ;; Put the predefined face only when suffix ;; is added via annotation-function without prefix, ;; and when the caller doesn't use own face. @@ -2106,10 +2183,9 @@ candidates." (with-current-buffer standard-output (goto-char (point-max)) - (if (null completions) - (insert "There are no possible completions of what you have typed.") - (insert "Possible completions are:\n") - (completion--insert-strings completions group-fun)))) + (when completions-header-format + (insert (format completions-header-format (length completions)))) + (completion--insert-strings completions group-fun))) (run-hooks 'completion-setup-hook) nil) @@ -2181,6 +2257,19 @@ variables.") (equal pre-msg (and exit-fun (current-message)))) (completion--message message)))) +(defcustom completions-max-height nil + "Maximum height for *Completions* buffer window." + :type '(choice (const nil) natnum) + :version "29.1") + +(defun completions--fit-window-to-buffer (&optional win &rest _) + "Resize *Completions* buffer window." + (if temp-buffer-resize-mode + (let ((temp-buffer-max-height (or completions-max-height + temp-buffer-max-height))) + (resize-temp-buffer-window win)) + (fit-window-to-buffer win completions-max-height))) + (defun minibuffer-completion-help (&optional start end) "Display a list of possible completions of the current minibuffer contents." (interactive) @@ -2210,6 +2299,9 @@ variables.") (let* ((last (last completions)) (base-size (or (cdr last) 0)) (prefix (unless (zerop base-size) (substring string 0 base-size))) + (base-prefix (buffer-substring (minibuffer--completion-prompt-end) + (+ start base-size))) + (base-suffix (buffer-substring (point) (point-max))) (all-md (completion--metadata (buffer-substring-no-properties start (point)) base-size md @@ -2244,9 +2336,7 @@ variables.") ,(if (eq (selected-window) (minibuffer-window)) 'display-buffer-at-bottom 'display-buffer-below-selected)) - ,(if temp-buffer-resize-mode - '(window-height . resize-temp-buffer-window) - '(window-height . fit-window-to-buffer)) + (window-height . completions--fit-window-to-buffer) ,(when temp-buffer-resize-mode '(preserve-size . (nil . t))) (body-function @@ -2263,7 +2353,10 @@ variables.") ;; same, but not always. (setq completions (if sort-fun (funcall sort-fun completions) - (sort completions 'string-lessp))) + (pcase completions-sort + ('nil completions) + ('alphabetical (sort completions #'string-lessp)) + (_ (funcall completions-sort completions))))) ;; After sorting, group the candidates using the ;; `group-function'. @@ -2300,20 +2393,28 @@ variables.") ;; completion-all-completions does not give us the ;; necessary information. end)) + (setq-local completion-base-affixes + (list base-prefix base-suffix)) (setq-local completion-list-insert-choice-function (let ((ctable minibuffer-completion-table) (cpred minibuffer-completion-predicate) (cprops completion-extra-properties)) (lambda (start end choice) - (unless (or (zerop (length prefix)) - (equal prefix - (buffer-substring-no-properties - (max (point-min) - (- start (length prefix))) - start))) - (message "*Completions* out of date")) - ;; FIXME: Use `md' to do quoting&terminator here. - (completion--replace start end choice) + (if (and (stringp start) (stringp end)) + (progn + (delete-minibuffer-contents) + (insert start choice) + ;; Keep point after completion before suffix + (save-excursion (insert end))) + (unless (or (zerop (length prefix)) + (equal prefix + (buffer-substring-no-properties + (max (point-min) + (- start (length prefix))) + start))) + (message "*Completions* out of date")) + ;; FIXME: Use `md' to do quoting&terminator here. + (completion--replace start end choice)) (let* ((minibuffer-completion-table ctable) (minibuffer-completion-predicate cpred) (completion-extra-properties cprops) @@ -2334,6 +2435,7 @@ variables.") "Get rid of an out-of-date *Completions* buffer." ;; FIXME: We could/should use minibuffer-scroll-window here, but it ;; can also point to the minibuffer-parent-window, so it's a bit tricky. + (interactive) (let ((win (get-buffer-window "*Completions*" 0))) (if win (with-selected-window win (bury-buffer))))) @@ -2448,14 +2550,15 @@ Also respects the obsolete wrapper hook `completion-in-region-functions'. (completion-in-region-mode 1)) (completion--in-region-1 start end)))) -(defvar completion-in-region-mode-map - (let ((map (make-sparse-keymap))) - ;; FIXME: Only works if completion-in-region-mode was activated via - ;; completion-at-point called directly. - (define-key map "\M-?" 'completion-help-at-point) - (define-key map "\t" 'completion-at-point) - map) - "Keymap activated during `completion-in-region'.") +(defvar-keymap completion-in-region-mode-map + :doc "Keymap activated during `completion-in-region'." + ;; FIXME: Only works if completion-in-region-mode was activated via + ;; completion-at-point called directly. + "M-?" #'completion-help-at-point + "TAB" #'completion-at-point + "M-<up>" #'minibuffer-previous-completion + "M-<down>" #'minibuffer-next-completion + "M-RET" #'minibuffer-choose-completion) ;; It is difficult to know when to exit completion-in-region-mode (i.e. hide ;; the *Completions*). Here's how previous packages did it: @@ -2502,6 +2605,7 @@ Also respects the obsolete wrapper hook `completion-in-region-functions'. (cl-assert completion-in-region-mode-predicate) (setq completion-in-region-mode--predicate completion-in-region-mode-predicate) + (setq-local minibuffer-completion-auto-choose nil) (add-hook 'post-command-hook #'completion-in-region--postch) (push `(completion-in-region-mode . ,completion-in-region-mode-map) minor-mode-overriding-map-alist))) @@ -2651,48 +2755,44 @@ The completion method is determined by `completion-at-point-functions'." (define-key map "\n" 'exit-minibuffer) (define-key map "\r" 'exit-minibuffer)) -(defvar minibuffer-local-completion-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map minibuffer-local-map) - (define-key map "\t" 'minibuffer-complete) - ;; M-TAB is already abused for many other purposes, so we should find - ;; another binding for it. - ;; (define-key map "\e\t" 'minibuffer-force-complete) - (define-key map " " 'minibuffer-complete-word) - (define-key map "?" 'minibuffer-completion-help) - (define-key map [prior] 'switch-to-completions) - (define-key map "\M-v" 'switch-to-completions) - (define-key map "\M-g\M-c" 'switch-to-completions) - map) - "Local keymap for minibuffer input with completion.") - -(defvar minibuffer-local-must-match-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map minibuffer-local-completion-map) - (define-key map "\r" 'minibuffer-complete-and-exit) - (define-key map "\n" 'minibuffer-complete-and-exit) - map) - "Local keymap for minibuffer input with completion, for exact match.") - -(defvar minibuffer-local-filename-completion-map - (let ((map (make-sparse-keymap))) - (define-key map " " nil) - map) - "Local keymap for minibuffer input with completion for filenames. +(defvar-keymap minibuffer-local-completion-map + :doc "Local keymap for minibuffer input with completion." + :parent minibuffer-local-map + "TAB" #'minibuffer-complete + "<backtab>" #'minibuffer-complete + ;; M-TAB is already abused for many other purposes, so we should find + ;; another binding for it. + ;; "M-TAB" #'minibuffer-force-complete + "SPC" #'minibuffer-complete-word + "?" #'minibuffer-completion-help + "<prior>" #'switch-to-completions + "M-v" #'switch-to-completions + "M-g M-c" #'switch-to-completions + "M-<up>" #'minibuffer-previous-completion + "M-<down>" #'minibuffer-next-completion + "M-RET" #'minibuffer-choose-completion) + +(defvar-keymap minibuffer-local-must-match-map + :doc "Local keymap for minibuffer input with completion, for exact match." + :parent minibuffer-local-completion-map + "RET" #'minibuffer-complete-and-exit + "C-j" #'minibuffer-complete-and-exit) + +(defvar-keymap minibuffer-local-filename-completion-map + :doc "Local keymap for minibuffer input with completion for filenames. Gets combined either with `minibuffer-local-completion-map' or -with `minibuffer-local-must-match-map'.") +with `minibuffer-local-must-match-map'." + "SPC" nil) (defvar minibuffer-local-filename-must-match-map (make-sparse-keymap)) (make-obsolete-variable 'minibuffer-local-filename-must-match-map nil "24.1") -(defvar minibuffer-local-ns-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map minibuffer-local-map) - (define-key map " " #'exit-minibuffer) - (define-key map "\t" #'exit-minibuffer) - (define-key map "?" #'self-insert-and-exit) - map) - "Local keymap for the minibuffer when spaces are not allowed.") +(defvar-keymap minibuffer-local-ns-map + :doc "Local keymap for the minibuffer when spaces are not allowed." + :parent minibuffer-local-map + "SPC" #'exit-minibuffer + "TAB" #'exit-minibuffer + "?" #'self-insert-and-exit) (defun read-no-blanks-input (prompt &optional initial inherit-input-method) "Read a string from the terminal, not allowing blanks. @@ -2713,24 +2813,23 @@ If `inhibit-interaction' is non-nil, this function will signal an ;;; Major modes for the minibuffer -(defvar minibuffer-inactive-mode-map - (let ((map (make-keymap))) - (suppress-keymap map) - (define-key map "e" 'find-file-other-frame) - (define-key map "f" 'find-file-other-frame) - (define-key map "b" 'switch-to-buffer-other-frame) - (define-key map "i" 'info) - (define-key map "m" 'mail) - (define-key map "n" 'make-frame) - (define-key map [mouse-1] 'view-echo-area-messages) - ;; So the global down-mouse-1 binding doesn't clutter the execution of the - ;; above mouse-1 binding. - (define-key map [down-mouse-1] #'ignore) - map) - "Keymap for use in the minibuffer when it is not active. +(defvar-keymap minibuffer-inactive-mode-map + :doc "Keymap for use in the minibuffer when it is not active. The non-mouse bindings in this keymap can only be used in minibuffer-only frames, since the minibuffer can normally not be selected when it is -not active.") +not active." + :full t + :suppress t + "e" #'find-file-other-frame + "f" #'find-file-other-frame + "b" #'switch-to-buffer-other-frame + "i" #'info + "m" #'mail + "n" #'make-frame + "<mouse-1>" #'view-echo-area-messages + ;; So the global down-mouse-1 binding doesn't clutter the execution of the + ;; above mouse-1 binding. + "<down-mouse-1>" #'ignore) (define-derived-mode minibuffer-inactive-mode nil "InactiveMinibuffer" :abbrev-table nil ;abbrev.el is not loaded yet during dump. @@ -2739,7 +2838,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 @@ -2922,26 +3021,30 @@ same as `substitute-in-file-name'." (let* ((ustr (substitute-in-file-name qstr)) (uprefix (substring ustr 0 upos)) qprefix) - ;; Main assumption: nothing after qpos should affect the text before upos, - ;; so we can work our way backward from the end of qstr, one character - ;; at a time. - ;; Second assumptions: If qpos is far from the end this can be a bit slow, - ;; so we speed it up by doing a first loop that skips a word at a time. - ;; This word-sized loop is careful not to cut in the middle of env-vars. - (while (let ((boundary (string-match "\\(\\$+{?\\)?\\w+\\W*\\'" qstr))) - (and boundary - (progn - (setq qprefix (substring qstr 0 boundary)) + (if (eq upos (length ustr)) + ;; Easy and common case. This not only speed things up in a very + ;; common case but it also avoids problems in some cases (bug#53053). + (cons (length qstr) #'minibuffer-maybe-quote-filename) + ;; Main assumption: nothing after qpos should affect the text before upos, + ;; so we can work our way backward from the end of qstr, one character + ;; at a time. + ;; Second assumptions: If qpos is far from the end this can be a bit slow, + ;; so we speed it up by doing a first loop that skips a word at a time. + ;; This word-sized loop is careful not to cut in the middle of env-vars. + (while (let ((boundary (string-match "\\(\\$+{?\\)?\\w+\\W*\\'" qstr))) + (and boundary + (progn + (setq qprefix (substring qstr 0 boundary)) + (string-prefix-p uprefix + (substitute-in-file-name qprefix))))) + (setq qstr qprefix)) + (let ((qpos (length qstr))) + (while (and (> qpos 0) (string-prefix-p uprefix - (substitute-in-file-name qprefix))))) - (setq qstr qprefix)) - (let ((qpos (length qstr))) - (while (and (> qpos 0) - (string-prefix-p uprefix - (substitute-in-file-name - (substring qstr 0 (1- qpos))))) - (setq qpos (1- qpos))) - (cons qpos #'minibuffer-maybe-quote-filename)))) + (substitute-in-file-name + (substring qstr 0 (1- qpos))))) + (setq qpos (1- qpos))) + (cons qpos #'minibuffer-maybe-quote-filename))))) (defalias 'completion--file-name-table (completion-table-with-quoting #'completion-file-name-table @@ -3056,7 +3159,10 @@ Fourth arg MUSTMATCH can take the following values: - anything else behaves like t except that typing RET does not exit if it does non-null completion. -Fifth arg INITIAL specifies text to start with. +Fifth arg INITIAL specifies text to start with. It will be +interpreted as the trailing part of DEFAULT-FILENAME, so using a +full file name for INITIAL will usually lead to surprising +results. Sixth arg PREDICATE, if non-nil, should be a function of one argument; then a file name is considered an acceptable completion @@ -4016,7 +4122,7 @@ This turns into (prefix \"f\" any \"o\" any \"o\" any point) which is at the core of flex logic. The extra -'any' is optimized away later on." +`any' is optimized away later on." (mapcan (lambda (elem) (if (stringp elem) (mapcan (lambda (char) @@ -4160,6 +4266,7 @@ See `completing-read' for the meaning of the arguments." ;; override bindings in base-keymap. base-keymap))) (buffer (current-buffer)) + (c-i-c completion-ignore-case) (result (minibuffer-with-setup-hook (lambda () @@ -4169,7 +4276,9 @@ See `completing-read' for the meaning of the arguments." (setq-local minibuffer-completion-confirm (unless (eq require-match t) require-match)) (setq-local minibuffer--require-match require-match) - (setq-local minibuffer--original-buffer buffer)) + (setq-local minibuffer--original-buffer buffer) + ;; Copy the value from original buffer to the minibuffer. + (setq-local completion-ignore-case c-i-c)) (read-from-minibuffer prompt initial-input keymap nil hist def inherit-input-method)))) (when (and (equal result "") def) @@ -4254,6 +4363,61 @@ the minibuffer was activated, and execute the forms." (with-minibuffer-selected-window (scroll-other-window-down arg))) +(defmacro with-minibuffer-completions-window (&rest body) + "Execute the forms in BODY from the minibuffer in its completions window. +When used in a minibuffer window, select the window with completions, +and execute the forms." + (declare (indent 0) (debug t)) + `(let ((window (or (get-buffer-window "*Completions*" 0) + ;; Make sure we have a completions window. + (progn (minibuffer-completion-help) + (get-buffer-window "*Completions*" 0))))) + (when window + (with-selected-window window + ,@body)))) + +(defcustom minibuffer-completion-auto-choose t + "Non-nil means to automatically insert completions to the minibuffer. +When non-nil, then `minibuffer-next-completion' and +`minibuffer-previous-completion' will insert the completion +selected by these commands to the minibuffer." + :type 'boolean + :version "29.1") + +(defun minibuffer-next-completion (&optional n) + "Move to the next item in its completions window from the minibuffer. +When `minibuffer-completion-auto-choose' is non-nil, then also +insert the selected completion to the minibuffer." + (interactive "p") + (let ((auto-choose minibuffer-completion-auto-choose)) + (with-minibuffer-completions-window + (when completions-highlight-face + (setq-local cursor-face-highlight-nonselected-window t)) + (next-completion (or n 1)) + (when auto-choose + (let ((completion-use-base-affixes t)) + (choose-completion nil t t)))))) + +(defun minibuffer-previous-completion (&optional n) + "Move to the previous item in its completions window from the minibuffer. +When `minibuffer-completion-auto-choose' is non-nil, then also +insert the selected completion to the minibuffer." + (interactive "p") + (minibuffer-next-completion (- (or n 1)))) + +(defun minibuffer-choose-completion (&optional no-exit no-quit) + "Run `choose-completion' from the minibuffer in its completions window. +With prefix argument NO-EXIT, insert the completion at point to the +minibuffer, but don't exit the minibuffer. When the prefix argument +is not provided, then whether to exit the minibuffer depends on the value +of `completion-no-auto-exit'. +If NO-QUIT is non-nil, insert the completion at point to the +minibuffer, but don't quit the completions window." + (interactive "P") + (with-minibuffer-completions-window + (let ((completion-use-base-affixes t)) + (choose-completion nil no-exit no-quit)))) + (defcustom minibuffer-default-prompt-format " (default %s)" "Format string used to output \"default\" values. When prompting for input, there will often be a default value, diff --git a/lisp/misc.el b/lisp/misc.el index d85f889ffd3..0bb8ee6c7bc 100644 --- a/lisp/misc.el +++ b/lisp/misc.el @@ -64,15 +64,22 @@ The characters copied are inserted in the buffer before point." ;; Variation of `zap-to-char'. ;;;###autoload -(defun zap-up-to-char (arg char) +(defun zap-up-to-char (arg char &optional interactive) "Kill up to, but not including ARGth occurrence of CHAR. +When run interactively, the argument INTERACTIVE is non-nil. Case is ignored if `case-fold-search' is non-nil in the current buffer. Goes backward if ARG is negative; error if CHAR not found. -Ignores CHAR at point." +Ignores CHAR at point. +If called interactively, do a case sensitive search if CHAR +is an upper-case character." (interactive (list (prefix-numeric-value current-prefix-arg) (read-char-from-minibuffer "Zap up to char: " - nil 'read-char-history))) - (let ((direction (if (>= arg 0) 1 -1))) + nil 'read-char-history) + t)) + (let ((direction (if (>= arg 0) 1 -1)) + (case-fold-search (if (and interactive (char-uppercase-p char)) + nil + case-fold-search))) (kill-region (point) (progn (forward-char direction) diff --git a/lisp/mouse.el b/lisp/mouse.el index e5ea5475f43..737c5078704 100644 --- a/lisp/mouse.el +++ b/lisp/mouse.el @@ -42,7 +42,9 @@ :group 'editing) (defcustom mouse-yank-at-point nil - "If non-nil, mouse yank commands yank at point instead of at click." + "If non-nil, mouse yank commands yank at point instead of at click. +This also allows yanking text into an isearch without moving the +mouse cursor to the echo area." :type 'boolean) (defcustom mouse-drag-copy-region nil @@ -97,6 +99,25 @@ point at the click position." :type 'boolean :version "22.1") +(defcustom mouse-drag-and-drop-region-scroll-margin nil + "If non-nil, the scroll margin inside a window when dragging text. +If the mouse moves this many lines close to the top or bottom of +a window while dragging text, then that window will be scrolled +down and up respectively." + :type '(choice (const :tag "Don't scroll during mouse movement") + (integer :tag "This many lines from window top or bottom")) + :version "29.1") + +(defcustom mouse-drag-mode-line-buffer nil + "If non-nil, allow dragging files from the mode line. +When the buffer has an associated file, it can be dragged from +the buffer name portion of its mode line to other programs. + +This option is only supported on X, Haiku and Nextstep (GNUstep +or macOS)." + :type 'boolean + :version "29.1") + (defvar mouse--last-down nil) (defun mouse--down-1-maybe-follows-link (&optional _prompt) @@ -156,6 +177,17 @@ Expects to be bound to `(double-)mouse-1' in `key-translation-map'." (define-key key-translation-map [double-mouse-1] #'mouse--click-1-maybe-follows-link) +(defun mouse-double-click-time () + "Return a number for `double-click-time'. +In contrast to using the `double-click-time' variable directly, +which could be set to nil or t, this function is guaranteed to +always return a positive integer or zero." + (let ((ct double-click-time)) + (cond ((eq ct t) 10000) ; arbitrary number useful for sit-for + ((eq ct nil) 0) + ((and (numberp ct) (> ct 0)) ct) + (t 0)))) + ;; Provide a mode-specific menu on a mouse button. @@ -184,8 +216,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 +303,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))) @@ -298,6 +330,10 @@ and should return the same menu with changes such as added new menu items." (function-item context-menu-buffers) (function-item context-menu-vc) (function-item context-menu-ffap) + (function-item hi-lock-context-menu) + (function-item occur-context-menu) + (function-item Man-context-menu) + (function-item dictionary-context-menu) (function :tag "Custom function"))) :version "28.1") @@ -317,9 +353,13 @@ At the end, it's possible to modify the final menu by specifying the function `context-menu-filter-function'." (let* ((menu (make-sparse-keymap (propertize "Context Menu" 'hide t))) (click (or click last-input-event)) + (window (posn-window (event-start click))) (fun (mouse-posn-property (event-start click) 'context-menu-function))) + (unless (eq (selected-window) window) + (select-window window)) + (if (functionp fun) (setq menu (funcall fun menu click)) (run-hook-wrapped 'context-menu-functions @@ -327,13 +367,31 @@ 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) (last-saw-separator t)) + (while (and (consp l) + (consp (cdr l))) + (if (equal (cdr-safe (cadr l)) menu-bar-separator) + (progn + ;; The next item is a separator. Remove it if the last + ;; item we saw was a separator too. + (if last-saw-separator + (setcdr l (cddr l)) + ;; If we didn't delete this separator, update the last + ;; separator we saw to this one. + (setq last-saw-separator l + l (cdr l)))) + ;; If the next item is a cons cell, we found a non-separator + ;; item. Don't remove the next separator we see. We + ;; specifically check for cons cells to avoid treating the + ;; overall prompt string as a menu item. + (when (consp (cadr l)) + (setq last-saw-separator nil)) + (setq l (cdr l)))) + ;; If the last item we saw was a separator, remove it. + (when (consp last-saw-separator) + (setcdr last-saw-separator (cddr last-saw-separator)))) (when (functionp context-menu-filter-function) (setq menu (funcall context-menu-filter-function menu click))) @@ -514,8 +572,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 +594,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 +606,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 +661,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 +737,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 +789,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. @@ -807,8 +864,29 @@ frame instead." (interactive "e") (let* ((start (event-start start-event)) (window (posn-window start)) - (frame (window-frame window))) + (frame (window-frame window)) + (skip-tracking nil) + filename) + ;; FIXME: is there a better way of determining if the event + ;; started on a buffer name? + (when (and mouse-drag-mode-line-buffer + (eq (car (posn-string start)) + (car (with-selected-window window + (setq filename (buffer-file-name)) + mode-line-buffer-identification))) + filename + (file-exists-p filename)) + (let ((mouse-fine-grained-tracking nil)) + (track-mouse + (setq track-mouse 'drag-source) + (let ((event (read-event))) + (if (not (eq (event-basic-type event) + 'mouse-movement)) + (push event unread-command-events) + (dnd-begin-file-drag filename frame 'copy t) + (setq skip-tracking t)))))) (cond + (skip-tracking t) ((not (window-live-p window))) ((or (not (window-at-side-p window 'bottom)) ;; Allow resizing the minibuffer window if it's on the @@ -1573,8 +1651,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 +1673,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 +1910,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 +1964,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 +1977,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 +2117,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)))) @@ -2721,18 +2810,72 @@ and selects that window." (declare-function generate-fontset-menu "fontset" ()) +(defun mouse-generate-font-name-for-menu (entity) + "Return a short name for font entity ENTITY. +The name should be used to describe ENTITY in the case that its +family is already known, such as in a pane generated by +`mouse-generate-font-menu'." + (let ((weight (font-get entity :weight)) + (slant (font-get entity :slant)) + (width (font-get entity :width)) + (size (font-get entity :size)) + (adstyle (font-get entity :adstyle)) + (name "")) + (when weight + (setq name (concat name (symbol-name weight) " "))) + (when (and slant + (not (eq slant 'normal))) + (setq name (concat name (symbol-name slant) " "))) + (when (and width (not (eq width 'normal))) + (setq name (concat name (symbol-name width) " "))) + (when (and size (not (zerop size))) + (setq name (concat name (number-to-string size) " "))) + (when adstyle + (setq name (concat name (if (symbolp adstyle) + (symbol-name adstyle) + (number-to-string adstyle)) + " "))) + (string-trim-right name))) + +(defun mouse-generate-font-menu () + "Return a list of menu panes for each font family." + (let ((families (font-family-list)) + (panes (list "Font families"))) + (dolist (family families) + (when family + (let* ((fonts (list-fonts (font-spec :family family))) + (pane (if fonts (list family) + (list family (cons family family))))) + (when fonts + (dolist (font fonts) + (setq pane + (nconc pane + (list (list (or (font-get font :name) + (mouse-generate-font-name-for-menu font)) + (font-xlfd-name font))))))) + (setq panes (nconc panes (list pane)))))) + panes)) + (defun mouse-select-font () "Prompt for a font name, using `x-popup-menu', and return it." (interactive) (unless (display-multi-font-p) (error "Cannot change fonts on this display")) - (car - (x-popup-menu - (if (listp last-nonmenu-event) - last-nonmenu-event - (list '(0 0) (selected-window))) - (append x-fixed-font-alist - (list (generate-fontset-menu)))))) + (let ((result (car + (x-popup-menu + (if (listp last-nonmenu-event) + last-nonmenu-event + (list '(0 0) (selected-window))) + (append x-fixed-font-alist + (list (generate-fontset-menu)) + '(("More Fonts" ("By Family" more)))))))) + (if (eq result 'more) + (car (x-popup-menu + (if (listp last-nonmenu-event) + last-nonmenu-event + (list '(0 0) (selected-window))) + (mouse-generate-font-menu))) + result))) (declare-function text-scale-mode "face-remap") @@ -2746,12 +2889,7 @@ choose a font." (interactive (progn (unless (display-multi-font-p) (error "Cannot change fonts on this display")) - (x-popup-menu - (if (listp last-nonmenu-event) - last-nonmenu-event - (list '(0 0) (selected-window))) - ;; Append list of fontsets currently defined. - (append x-fixed-font-alist (list (generate-fontset-menu)))))) + (list (mouse-select-font)))) (if fonts (let (font) (while fonts @@ -2889,6 +3027,11 @@ in addition, temporarily highlight the original region with the :type 'boolean :version "26.1") +(defcustom mouse-drag-and-drop-region-cross-program nil + "If non-nil, allow dragging text to other programs." + :type 'boolean + :version "29.1") + (defface mouse-drag-and-drop-region '((t :inherit region)) "Face to highlight original text during dragging. This face is used by `mouse-drag-and-drop-region' to temporarily @@ -2899,6 +3042,33 @@ highlight the original region when (declare-function rectangle-dimensions "rect" (start end)) (declare-function rectangle-position-as-coordinates "rect" (position)) (declare-function rectangle-intersect-p "rect" (pos1 size1 pos2 size2)) +(declare-function x-begin-drag "xfns.c") + +(defun mouse-drag-and-drop-region-display-tooltip (tooltip) + "Display TOOLTIP, a tooltip string, using `x-show-tip'. +Call `tooltip-show-help-non-mode' instead on non-graphical displays." + (if (display-graphic-p) + (let ((params (copy-sequence tooltip-frame-parameters)) + (fg (face-attribute 'tooltip :foreground)) + (bg (face-attribute 'tooltip :background))) + (when (stringp fg) + (setf (alist-get 'foreground-color params) fg) + (setf (alist-get 'border-color params) fg)) + (when (stringp bg) + (setf (alist-get 'background-color params) bg)) + (x-show-tip tooltip nil params)) + (tooltip-show-help-non-mode tooltip))) + +(declare-function x-hide-tip "xfns.c") +(declare-function x-show-tip "xfns.c") + +(defun mouse-drag-and-drop-region-hide-tooltip () + "Hide any tooltip currently displayed. +Call `tooltip-show-help-non-mode' to clear the echo area message +instead on non-graphical displays." + (if (display-graphic-p) + (x-hide-tip) + (tooltip-show-help-non-mode nil))) (defun mouse-drag-and-drop-region (event) "Move text in the region to point where mouse is dragged to. @@ -2928,6 +3098,14 @@ is copied instead of being cut." (cdr bounds))) (region-bounds))) (region-noncontiguous (region-noncontiguous-p)) + ;; Otherwise, the mouse periodically moves on top of the + ;; tooltip. + (mouse-fine-grained-tracking t) + (was-tooltip-mode tooltip-mode) + ;; Whether or not some text was ``cut'' from Emacs to another + ;; program and the cleaanup code should not try modifying the + ;; region. + drag-was-cross-program point-to-paste point-to-paste-read-only window-to-paste @@ -2939,331 +3117,461 @@ is copied instead of being cut." value-selection ; This remains nil when event was "click". text-tooltip states - window-exempt) - - ;; STATES stores for each window on this frame its start and point - ;; positions so we can restore them on all windows but for the one - ;; where the drop occurs. For inter-frame drags we'll have to do - ;; this for all windows on all visible frames. In addition we save - ;; also the cursor type for the window's buffer so we can restore it - ;; in case we modified it. - ;; https://lists.gnu.org/r/emacs-devel/2017-12/msg00090.html - (walk-window-tree - (lambda (window) - (setq states - (cons - (list - window - (copy-marker (window-start window)) - (copy-marker (window-point window)) - (with-current-buffer (window-buffer window) - cursor-type)) - states)))) - - (ignore-errors - (track-mouse - (setq track-mouse 'dropping) - ;; When event was "click" instead of "drag", skip loop. - (while (progn - (setq event (read-key)) ; read-event or read-key - (or (mouse-movement-p event) - ;; Handle `mouse-autoselect-window'. - (memq (car event) '(select-window switch-frame)))) - ;; Obtain the dragged text in region. When the loop was - ;; skipped, value-selection remains nil. - (unless value-selection - (setq value-selection (funcall region-extract-function nil)) - (when mouse-drag-and-drop-region-show-tooltip - (let ((text-size mouse-drag-and-drop-region-show-tooltip)) - (setq text-tooltip - (if (and (integerp text-size) - (> (length value-selection) text-size)) - (concat - (substring value-selection 0 (/ text-size 2)) - "\n...\n" - (substring value-selection (- (/ text-size 2)) -1)) - value-selection)))) - - ;; Check if selected text is read-only. - (setq text-from-read-only - (or text-from-read-only - (catch 'loop - (dolist (bound (region-bounds)) - (when (text-property-not-all - (car bound) (cdr bound) 'read-only nil) - (throw 'loop t))))))) - - (setq window-to-paste (posn-window (event-end event))) - (setq point-to-paste (posn-point (event-end event))) - ;; Set nil when target buffer is minibuffer. - (setq buffer-to-paste (let (buf) - (when (windowp window-to-paste) - (setq buf (window-buffer window-to-paste)) - (when (not (minibufferp buf)) - buf)))) - (setq cursor-in-text-area (and window-to-paste - point-to-paste - buffer-to-paste)) - - (when cursor-in-text-area - ;; Check if point under mouse is read-only. - (save-window-excursion - (select-window window-to-paste) - (setq point-to-paste-read-only - (or buffer-read-only - (get-text-property point-to-paste 'read-only)))) - - ;; Check if "drag but negligible". Operation "drag but - ;; negligible" is defined as drag-and-drop the text to - ;; the original region. When modifier is pressed, the - ;; text will be inserted to inside of the original - ;; region. - ;; - ;; If the region is rectangular, check if the newly inserted - ;; rectangular text would intersect the already selected - ;; region. If it would, then set "drag-but-negligible" to t. - ;; As a special case, allow dragging the region freely anywhere - ;; to the left, as this will never trigger its contents to be - ;; inserted into the overlays tracking it. - (setq drag-but-negligible - (and (eq (overlay-buffer (car mouse-drag-and-drop-overlays)) - buffer-to-paste) - (if region-noncontiguous - (let ((dimensions (rectangle-dimensions start end)) - (start-coordinates - (rectangle-position-as-coordinates start)) - (point-to-paste-coordinates - (rectangle-position-as-coordinates - point-to-paste))) - (and (rectangle-intersect-p - start-coordinates dimensions - point-to-paste-coordinates dimensions) - (not (< (car point-to-paste-coordinates) - (car start-coordinates))))) - (and (<= (overlay-start - (car mouse-drag-and-drop-overlays)) - point-to-paste) - (<= point-to-paste - (overlay-end - (car mouse-drag-and-drop-overlays)))))))) - - ;; Show a tooltip. - (if mouse-drag-and-drop-region-show-tooltip - (tooltip-show (copy-sequence text-tooltip)) - (tooltip-hide)) - - ;; Show cursor and highlight the original region. - (when mouse-drag-and-drop-region-show-cursor - ;; Modify cursor even when point is out of frame. - (setq cursor-type (cond - ((not cursor-in-text-area) - nil) - ((or point-to-paste-read-only - drag-but-negligible) - 'hollow) - (t - 'bar))) - (when cursor-in-text-area - (dolist (overlay mouse-drag-and-drop-overlays) - (overlay-put overlay - 'face 'mouse-drag-and-drop-region)) - (deactivate-mark) ; Maintain region in other window. - (mouse-set-point event))))) - - ;; Hide a tooltip. - (when mouse-drag-and-drop-region-show-tooltip (tooltip-hide)) - - ;; Check if modifier was pressed on drop. - (setq no-modifier-on-drop - (not (member mouse-drag-and-drop-region (event-modifiers event)))) - - ;; Check if event was "click". - (setq clicked (not value-selection)) - - ;; Restore status on drag to outside of text-area or non-mouse input. - (when (or (not cursor-in-text-area) - (not (equal (event-basic-type event) mouse-button))) - (setq drag-but-negligible t - no-modifier-on-drop t)) - - ;; Do not modify any buffers when event is "click", - ;; "drag but negligible", or "drag to read-only". - (let* ((mouse-drag-and-drop-region-cut-when-buffers-differ - (if no-modifier-on-drop - mouse-drag-and-drop-region-cut-when-buffers-differ - (not mouse-drag-and-drop-region-cut-when-buffers-differ))) - (wanna-paste-to-same-buffer (equal buffer-to-paste buffer)) - (wanna-cut-on-same-buffer (and wanna-paste-to-same-buffer - no-modifier-on-drop)) - (wanna-cut-on-other-buffer - (and (not wanna-paste-to-same-buffer) - mouse-drag-and-drop-region-cut-when-buffers-differ)) - (cannot-paste (or point-to-paste-read-only - (when (or wanna-cut-on-same-buffer - wanna-cut-on-other-buffer) - text-from-read-only)))) - - (cond - ;; Move point within region. - (clicked - (deactivate-mark) - (mouse-set-point event)) - ;; Undo operation. Set back the original text as region. - ((or (and drag-but-negligible - no-modifier-on-drop) - cannot-paste) - ;; Inform user either source or destination buffer cannot be modified. - (when (and (not drag-but-negligible) - cannot-paste) - (message "Buffer is read-only")) - - ;; Select source window back and restore region. - ;; (set-window-point window point) - (select-window window) - (goto-char point) - (setq deactivate-mark nil) - (activate-mark) - (when region-noncontiguous - (rectangle-mark-mode))) - ;; Modify buffers. - (t - ;; * DESTINATION BUFFER:: - ;; Insert the text to destination buffer under mouse. - (select-window window-to-paste) - (setq window-exempt window-to-paste) - (goto-char point-to-paste) - (push-mark) - (insert-for-yank value-selection) - - ;; On success, set the text as region on destination buffer. - (when (not (equal (mark) (point))) - (setq deactivate-mark nil) - (activate-mark) - (when region-noncontiguous - (rectangle-mark-mode))) - - ;; * SOURCE BUFFER:: - ;; Set back the original text as region or delete the original - ;; text, on source buffer. - (if wanna-paste-to-same-buffer - ;; When source buffer and destination buffer are the same, - ;; remove the original text. - (when no-modifier-on-drop - (let (deactivate-mark) - (dolist (overlay mouse-drag-and-drop-overlays) - (delete-region (overlay-start overlay) - (overlay-end overlay))))) - ;; When source buffer and destination buffer are different, - ;; keep (set back the original text as region) or remove the - ;; original text. - (select-window window) ; Select window with source buffer. - (goto-char point) ; Move point to the original text on source buffer. - - (if mouse-drag-and-drop-region-cut-when-buffers-differ - ;; Remove the dragged text from source buffer like - ;; operation `cut'. - (dolist (overlay mouse-drag-and-drop-overlays) - (delete-region (overlay-start overlay) - (overlay-end overlay))) - ;; Set back the dragged text as region on source buffer - ;; like operation `copy'. - (activate-mark)) - (select-window window-to-paste)))))) - - ;; Clean up. - (dolist (overlay mouse-drag-and-drop-overlays) - (delete-overlay overlay)) - - ;; Restore old states but for the window where the drop - ;; occurred. Restore cursor types for all windows. - (dolist (state states) - (let ((window (car state))) - (when (and window-exempt - (not (eq window window-exempt))) - (set-window-start window (nth 1 state) 'noforce) - (set-marker (nth 1 state) nil) - ;; If window is selected, the following automatically sets - ;; point for that window's buffer. - (set-window-point window (nth 2 state)) - (set-marker (nth 2 state) nil)) - (with-current-buffer (window-buffer window) - (setq cursor-type (nth 3 state))))))) + window-exempt + drag-again-mouse-position) + + (unwind-protect + (progn + ;; Without this moving onto text with a help-echo will + ;; interfere with the tooltip containing dragged text. + (tooltip-mode -1) + ;; STATES stores for each window on this frame its start and point + ;; positions so we can restore them on all windows but for the one + ;; where the drop occurs. For inter-frame drags we'll have to do + ;; this for all windows on all visible frames. In addition we save + ;; also the cursor type for the window's buffer so we can restore it + ;; in case we modified it. + ;; https://lists.gnu.org/r/emacs-devel/2017-12/msg00090.html + (walk-window-tree + (lambda (window) + (setq states + (cons + (list + window + (copy-marker (window-start window)) + (copy-marker (window-point window)) + (with-current-buffer (window-buffer window) + cursor-type)) + states)))) + + (ignore-errors + (catch 'cross-program-drag + (track-mouse + (setq track-mouse (if mouse-drag-and-drop-region-cross-program + ;; When `track-mouse' is `drop', we + ;; get events with a posn-window of + ;; the grabbed frame even if some + ;; window is between that and the + ;; pointer. This makes dragging to a + ;; window on top of a frame + ;; impossible. With this value of + ;; `track-mouse', no frame is returned + ;; in that particular case, which + ;; tells us to initiate interprogram + ;; drag-and-drop. + 'drag-source + 'drop)) + ;; When event was "click" instead of "drag", skip loop. + (while (progn + (setq event (read-key)) ; read-event or read-key + (or (mouse-movement-p event) + ;; Handle `mouse-autoselect-window'. + (memq (car event) '(select-window switch-frame)))) + (catch 'drag-again + ;; If the mouse is in the drag scroll margin, scroll + ;; either up or down depending on which margin it is in. + (when mouse-drag-and-drop-region-scroll-margin + (let* ((row (cdr (posn-col-row (event-end event)))) + (window (when (windowp (posn-window (event-end event))) + (posn-window (event-end event)))) + (text-height (when window + (window-text-height window))) + ;; Make sure it's possible to scroll both up + ;; and down if the margin is too large for the + ;; window. + (margin (when text-height + (min (/ text-height 3) + mouse-drag-and-drop-region-scroll-margin)))) + (when (windowp window) + ;; At 2 lines, the window becomes too small for any + ;; meaningful scrolling. + (unless (<= text-height 2) + ;; We could end up at the beginning or end of the + ;; buffer. + (ignore-errors + (cond + ;; Inside the bottom scroll margin, scroll up. + ((> row (- text-height margin)) + (with-selected-window window + (scroll-up 1))) + ;; Inside the top scroll margin, scroll down. + ((< row margin) + (with-selected-window window + (scroll-down 1))))))))) + + ;; Obtain the dragged text in region. When the loop was + ;; skipped, value-selection remains nil. + (unless value-selection + (setq value-selection (funcall region-extract-function nil)) + (when mouse-drag-and-drop-region-show-tooltip + (let ((text-size mouse-drag-and-drop-region-show-tooltip)) + (setq text-tooltip + (if (and (integerp text-size) + (> (length value-selection) text-size)) + (concat + (substring value-selection 0 (/ text-size 2)) + "\n...\n" + (substring value-selection (- (/ text-size 2)) -1)) + value-selection)))) + + ;; Check if selected text is read-only. + (setq text-from-read-only + (or text-from-read-only + (catch 'loop + (dolist (bound (region-bounds)) + (when (text-property-not-all + (car bound) (cdr bound) 'read-only nil) + (throw 'loop t))))))) + + (when (and mouse-drag-and-drop-region-cross-program + (display-graphic-p) + (fboundp 'x-begin-drag) + (or (and (framep (posn-window (event-end event))) + (let ((location (posn-x-y (event-end event))) + (frame (posn-window (event-end event)))) + (or (< (car location) 0) + (< (cdr location) 0) + (> (car location) + (frame-pixel-width frame)) + (> (cdr location) + (frame-pixel-height frame))))) + (and (or (not drag-again-mouse-position) + (let ((mouse-position (mouse-absolute-pixel-position))) + (or (< 5 (abs (- (car drag-again-mouse-position) + (car mouse-position)))) + (< 5 (abs (- (cdr drag-again-mouse-position) + (cdr mouse-position))))))) + (not (posn-window (event-end event)))))) + (setq drag-again-mouse-position nil) + (mouse-drag-and-drop-region-hide-tooltip) + (gui-set-selection 'XdndSelection value-selection) + (let ((drag-action-or-frame + (condition-case nil + (x-begin-drag '("UTF8_STRING" "text/plain" + "text/plain;charset=utf-8" + "STRING" "TEXT" "COMPOUND_TEXT") + (if mouse-drag-and-drop-region-cut-when-buffers-differ + 'XdndActionMove + 'XdndActionCopy) + (posn-window (event-end event)) 'now + ;; On platforms where we know + ;; `return-frame' doesn't + ;; work, allow dropping on + ;; the drop frame. + (eq window-system 'haiku)) + (quit nil)))) + (when (framep drag-action-or-frame) + ;; With some window managers `x-begin-drag' + ;; returns a frame sooner than `mouse-position' + ;; will return one, due to over-wide frame windows + ;; being drawn by the window manager. To avoid + ;; that, we just require the mouse move a few + ;; pixels before beginning another cross-program + ;; drag. + (setq drag-again-mouse-position + (mouse-absolute-pixel-position)) + (throw 'drag-again nil)) + + (let ((min-char (point))) + (when (eq drag-action-or-frame 'XdndActionMove) + ;; Remove the dragged text from source buffer like + ;; operation `cut'. + (dolist (overlay mouse-drag-and-drop-overlays) + (when (< min-char (min (overlay-start overlay) + (overlay-end overlay))) + (setq min-char (min (overlay-start overlay) + (overlay-end overlay)))) + (delete-region (overlay-start overlay) + (overlay-end overlay))) + (goto-char min-char) + (setq deactivate-mark t) + (setq drag-was-cross-program t))) + + (when (eq drag-action-or-frame 'XdndActionCopy) + ;; Set back the dragged text as region on source buffer + ;; like operation `copy'. + (activate-mark))) + (throw 'cross-program-drag nil)) + + (setq window-to-paste (posn-window (event-end event))) + (setq point-to-paste (posn-point (event-end event))) + ;; Set nil when target buffer is minibuffer. + (setq buffer-to-paste (let (buf) + (when (windowp window-to-paste) + (setq buf (window-buffer window-to-paste)) + (when (not (minibufferp buf)) + buf)))) + (setq cursor-in-text-area (and window-to-paste + point-to-paste + buffer-to-paste)) + + (when cursor-in-text-area + ;; Check if point under mouse is read-only. + (save-window-excursion + (select-window window-to-paste) + (setq point-to-paste-read-only + (or buffer-read-only + (get-text-property point-to-paste 'read-only)))) + + ;; Check if "drag but negligible". Operation "drag but + ;; negligible" is defined as drag-and-drop the text to + ;; the original region. When modifier is pressed, the + ;; text will be inserted to inside of the original + ;; region. + ;; + ;; If the region is rectangular, check if the newly inserted + ;; rectangular text would intersect the already selected + ;; region. If it would, then set "drag-but-negligible" to t. + ;; As a special case, allow dragging the region freely anywhere + ;; to the left, as this will never trigger its contents to be + ;; inserted into the overlays tracking it. + (setq drag-but-negligible + (and (eq (overlay-buffer (car mouse-drag-and-drop-overlays)) + buffer-to-paste) + (if region-noncontiguous + (let ((dimensions (rectangle-dimensions start end)) + (start-coordinates + (rectangle-position-as-coordinates start)) + (point-to-paste-coordinates + (rectangle-position-as-coordinates + point-to-paste))) + (and (rectangle-intersect-p + start-coordinates dimensions + point-to-paste-coordinates dimensions) + (not (< (car point-to-paste-coordinates) + (car start-coordinates))))) + (and (<= (overlay-start + (car mouse-drag-and-drop-overlays)) + point-to-paste) + (<= point-to-paste + (overlay-end + (car mouse-drag-and-drop-overlays)))))))) + + ;; Show a tooltip. + (if mouse-drag-and-drop-region-show-tooltip + ;; Don't use tooltip-show since it has side effects + ;; which change the text properties, and + ;; `text-tooltip' can potentially be the text which + ;; will be pasted. + (mouse-drag-and-drop-region-display-tooltip text-tooltip) + (mouse-drag-and-drop-region-hide-tooltip)) + + ;; Show cursor and highlight the original region. + (when mouse-drag-and-drop-region-show-cursor + ;; Modify cursor even when point is out of frame. + (setq cursor-type (cond + ((not cursor-in-text-area) + nil) + ((or point-to-paste-read-only + drag-but-negligible) + 'hollow) + (t + 'bar))) + (when cursor-in-text-area + (dolist (overlay mouse-drag-and-drop-overlays) + (overlay-put overlay + 'face 'mouse-drag-and-drop-region)) + (deactivate-mark) ; Maintain region in other window. + (mouse-set-point event))))))) + + ;; Hide a tooltip. + (when mouse-drag-and-drop-region-show-tooltip (x-hide-tip)) + + ;; Check if modifier was pressed on drop. + (setq no-modifier-on-drop + (not (member mouse-drag-and-drop-region (event-modifiers event)))) + + ;; Check if event was "click". + (setq clicked (not value-selection)) + + ;; Restore status on drag to outside of text-area or non-mouse input. + (when (or (not cursor-in-text-area) + (not (equal (event-basic-type event) mouse-button))) + (setq drag-but-negligible t + no-modifier-on-drop t)) + + ;; Do not modify any buffers when event is "click", + ;; "drag but negligible", or "drag to read-only". + (unless drag-was-cross-program + (let* ((mouse-drag-and-drop-region-cut-when-buffers-differ + (if no-modifier-on-drop + mouse-drag-and-drop-region-cut-when-buffers-differ + (not mouse-drag-and-drop-region-cut-when-buffers-differ))) + (wanna-paste-to-same-buffer (equal buffer-to-paste buffer)) + (wanna-cut-on-same-buffer (and wanna-paste-to-same-buffer + no-modifier-on-drop)) + (wanna-cut-on-other-buffer + (and (not wanna-paste-to-same-buffer) + mouse-drag-and-drop-region-cut-when-buffers-differ)) + (cannot-paste (or point-to-paste-read-only + (when (or wanna-cut-on-same-buffer + wanna-cut-on-other-buffer) + text-from-read-only)))) + + (cond + ;; Move point within region. + (clicked + (deactivate-mark) + (mouse-set-point event)) + ;; Undo operation. Set back the original text as region. + ((or (and drag-but-negligible + no-modifier-on-drop) + cannot-paste) + ;; Inform user either source or destination buffer cannot be modified. + (when (and (not drag-but-negligible) + cannot-paste) + (message "Buffer is read-only")) + + ;; Select source window back and restore region. + ;; (set-window-point window point) + (select-window window) + (goto-char point) + (setq deactivate-mark nil) + (activate-mark) + (when region-noncontiguous + (rectangle-mark-mode))) + ;; Modify buffers. + (t + ;; * DESTINATION BUFFER:: + ;; Insert the text to destination buffer under mouse. + (select-window window-to-paste) + (setq window-exempt window-to-paste) + (goto-char point-to-paste) + (push-mark) + (insert-for-yank value-selection) + + ;; On success, set the text as region on destination buffer. + (when (not (equal (mark) (point))) + (setq deactivate-mark nil) + (activate-mark) + (when region-noncontiguous + (rectangle-mark-mode))) + + ;; * SOURCE BUFFER:: + ;; Set back the original text as region or delete the original + ;; text, on source buffer. + (if wanna-paste-to-same-buffer + ;; When source buffer and destination buffer are the same, + ;; remove the original text. + (when no-modifier-on-drop + (let (deactivate-mark) + (dolist (overlay mouse-drag-and-drop-overlays) + (delete-region (overlay-start overlay) + (overlay-end overlay))))) + ;; When source buffer and destination buffer are different, + ;; keep (set back the original text as region) or remove the + ;; original text. + (select-window window) ; Select window with source buffer. + (goto-char point) ; Move point to the original text on source buffer. + + (if mouse-drag-and-drop-region-cut-when-buffers-differ + ;; Remove the dragged text from source buffer like + ;; operation `cut'. + (dolist (overlay mouse-drag-and-drop-overlays) + (delete-region (overlay-start overlay) + (overlay-end overlay))) + ;; Set back the dragged text as region on source buffer + ;; like operation `copy'. + (activate-mark)) + (select-window window-to-paste)))))))) + + (when was-tooltip-mode + (tooltip-mode 1)) + + ;; Clean up. + (dolist (overlay mouse-drag-and-drop-overlays) + (delete-overlay overlay)) + + ;; Restore old states but for the window where the drop + ;; occurred. Restore cursor types for all windows. + (dolist (state states) + (let ((window (car state))) + (when (and window-exempt + (not (eq window window-exempt))) + (set-window-start window (nth 1 state) 'noforce) + (set-marker (nth 1 state) nil) + ;; If window is selected, the following automatically sets + ;; point for that window's buffer. + (set-window-point window (nth 2 state)) + (set-marker (nth 2 state) nil)) + (with-current-buffer (window-buffer window) + (setq cursor-type (nth 3 state)))))))) ;;; 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 4a620443f31..be493b36534 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) (featurep 'pgtk-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) (featurep 'pgtk-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 @@ -100,10 +124,10 @@ screen. It can also be a floating point number, specifying the fraction of a full screen to scroll. A near full screen is `next-screen-context-lines' less than a full screen. -If AMOUNT is the symbol 'hscroll', this means that with MODIFIER, +If AMOUNT is the symbol `hscroll', this means that with MODIFIER, the mouse wheel will scroll horizontally instead of vertically. -If AMOUNT is the symbol 'text-scale', this means that with +If AMOUNT is the symbol `text-scale', this means that with MODIFIER, the mouse wheel will change the face height instead of scrolling." :group 'mouse @@ -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) (featurep 'pgtk-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) (featurep 'pgtk-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 4d97dbcc96a..9937c022d9f 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)) @@ -2546,13 +2547,16 @@ can parse the output from a DIR listing for a host of type TYPE.") (defvar ange-ftp-after-parse-ls-hook nil "Normal hook run after parsing the text of an FTP directory listing.") +(declare-function ls-lisp--sanitize-switches "ls-lisp" (switches)) + (defun ange-ftp-ls (file lsargs parse &optional no-error wildcard) "Return the output of a `DIR' or `ls' command done over FTP. FILE is the full name of the remote file, LSARGS is any args to pass to the `ls' command, and PARSE specifies that the output should be parsed and stored away in the internal cache." - (while (string-match "^--dired\\s-+" lsargs) - (setq lsargs (replace-match "" nil t lsargs))) + (while (string-match "--" lsargs) + (require 'ls-lisp) + (setq lsargs (ls-lisp--sanitize-switches lsargs))) ;; If parse is t, we assume that file is a directory. i.e. we only parse ;; full directory listings. (let* ((ange-ftp-this-file (ange-ftp-expand-file-name file)) diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index ccfbf51e48c..362dcf25b55 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 @@ -769,21 +701,45 @@ interactively. Turn the filename into a URL with function (cond ((not (buffer-modified-p))) (browse-url-save-file (save-buffer)) (t (message "%s modified since last save" file)))))) - (when (file-remote-p file) - (setq file (file-local-copy file))) + (when (and (file-remote-p file) + (not browse-url-temp-file-name)) + (setq browse-url-temp-file-name (file-local-copy file) + file browse-url-temp-file-name)) (browse-url (browse-url-file-url file)) (run-hooks 'browse-url-of-file-hook)) +(defun browse-url--file-name-coding-system () + (if (equal system-type 'windows-nt) + ;; W32 pretends that file names are UTF-8 encoded. + 'utf-8 + (or file-name-coding-system default-file-name-coding-system))) + (defun browse-url-file-url (file) "Return the URL corresponding to FILE. Use variable `browse-url-filename-alist' to map filenames to URLs." - (let ((coding (if (equal system-type 'windows-nt) - ;; W32 pretends that file names are UTF-8 encoded. - 'utf-8 - (and (or file-name-coding-system - default-file-name-coding-system))))) - (if coding (setq file (encode-coding-string file coding)))) - (setq file (browse-url-url-encode-chars file "[*\"()',=;?% ]")) + (when-let ((coding (browse-url--file-name-coding-system))) + (setq file (encode-coding-string file coding))) + (if (and (file-remote-p file) + ;; We're applying special rules for FTP URLs for historical + ;; reasons. + (seq-find (lambda (match) + (and (string-match-p (car match) file) + (not (string-match "\\`file:" (cdr match))))) + browse-url-filename-alist)) + (setq file (browse-url-url-encode-chars file "[*\"()',=;?% ]")) + ;; Encode all other file names properly. + (let ((bits (file-name-split file))) + (setq file + (string-join + ;; On Windows, the first bit here might be "c:" or the + ;; like, so don't encode the ":" in the first bit. + (cons (let ((url-unreserved-chars + (if (file-name-absolute-p file) + (cons ?: url-unreserved-chars) + url-unreserved-chars))) + (url-hexify-string (car bits))) + (mapcar #'url-hexify-string (cdr bits))) + "/")))) (dolist (map browse-url-filename-alist) (when (and map (string-match (car map) file)) (setq file (replace-match (cdr map) t nil file)))) @@ -858,6 +814,8 @@ See `browse-url' for details." ;; A generic command to call the current browse-url-browser-function +(declare-function pgtk-backend-display-class "pgtkfns.c" (&optional terminal)) + ;;;###autoload (defun browse-url (url &rest args) "Open URL using a configurable method. @@ -895,8 +853,21 @@ If ARGS are omitted, the default is to pass ;; When connected to various displays, be careful to use the display of ;; the currently selected frame, rather than the original start display, ;; which may not even exist any more. - (if (stringp (frame-parameter nil 'display)) - (setenv "DISPLAY" (frame-parameter nil 'display))) + (let ((dpy (frame-parameter nil 'display)) + classname) + (if (stringp dpy) + (cond + ((featurep 'pgtk) + (setq classname (pgtk-backend-display-class)) + (if (equal classname "GdkWaylandDisplay") + (progn + ;; The `display' frame parameter is probably wrong. + ;; See bug#53969 for some context. + ;; (setenv "WAYLAND_DISPLAY" dpy) + ) + (setenv "DISPLAY" dpy))) + (t + (setenv "DISPLAY" dpy))))) (if (functionp function) (apply function url args) (error "No suitable browser for URL %s" url)))) @@ -1005,8 +976,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 @@ -1014,7 +983,13 @@ non-nil, or the same display as Emacs if different from the current environment, otherwise just use the current environment." (let ((display (or browse-url-browser-display (browse-url-emacs-display)))) (if display - (cons (concat "DISPLAY=" display) process-environment) + (cons (concat (if (and (eq window-system 'pgtk) + (equal (pgtk-backend-display-class) + "GdkWaylandDisplay")) + "WAYLAND_DISPLAY=" + "DISPLAY=") + display) + process-environment) process-environment))) (defun browse-url-emacs-display () @@ -1044,15 +1019,16 @@ instead of `browse-url-new-window-flag'." 'browse-url-default-windows-browser) ((memq system-type '(darwin)) 'browse-url-default-macosx-browser) + ((featurep 'haiku) + 'browse-url-default-haiku-browser) ((browse-url-can-use-xdg-open) 'browse-url-xdg-open) ;;; ((executable-find browse-url-gnome-moz-program) 'browse-url-gnome-moz) ((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 @@ -1085,82 +1061,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 @@ -1280,56 +1180,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 @@ -1380,6 +1230,36 @@ 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) + +(declare-function haiku-roster-launch "haikuselect.c") + +;;;###autoload +(defun browse-url-default-haiku-browser (url &optional _new-window) + "Browse URL with the system default browser. +Default to the URL around or before point." + (interactive (browse-url-interactive-arg "URL: ")) + (setq url (browse-url-encode-url url)) + (let* ((scheme (save-match-data + (if (string-match "\\(.+\\):/" url) + (match-string 1 url) + "http"))) + (mime (concat "application/x-vnd.Be.URL." scheme))) + (haiku-roster-launch mime (vector url)))) + +(function-put 'browse-url-default-haiku-browser + '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 @@ -1388,10 +1268,12 @@ currently selected window instead." (require 'url-handlers) (let ((parsed (url-generic-parse-url url)) (func (if same-window 'find-file 'find-file-other-window))) - (if (and (equal (url-type parsed) "file") - (file-directory-p (url-filename parsed))) - ;; It's a directory; just open it. - (funcall func (url-filename parsed)) + (if (equal (url-type parsed) "file") + ;; It's a file; just open it. + (let ((file (url-unhex-string (url-filename parsed)))) + (when-let ((coding (browse-url--file-name-coding-system))) + (setq file (decode-coding-string file 'utf-8))) + (funcall func file)) (let ((file-name-handler-alist (cons (cons url-handler-regexp 'url-file-handler) file-name-handler-alist))) @@ -1401,7 +1283,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. @@ -1751,13 +1633,11 @@ from `browse-url-elinks-wrapper'." ;;; Adding buttons to a buffer to call `browse-url' when you hit them. -(defvar browse-url-button-map - (let ((map (make-sparse-keymap))) - (define-key map "\r" #'browse-url-button-open) - (define-key map [mouse-2] #'browse-url-button-open) - (define-key map "w" #'browse-url-button-copy) - map) - "The keymap used for `browse-url' buttons.") +(defvar-keymap browse-url-button-map + :doc "The keymap used for `browse-url' buttons." + "RET" #'browse-url-button-open + "<mouse-2>" #'browse-url-button-open + "w" #'browse-url-button-copy) (defface browse-url-button '((t :inherit link)) diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index 54e8d0c5d4e..6a8bf879671 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -36,6 +36,7 @@ ;; Declare used subroutines and variables. (declare-function dbus-message-internal "dbusbind.c") (declare-function dbus--init-bus "dbusbind.c") +(declare-function libxml-parse-xml-region "xml.c") (defvar dbus-message-type-invalid) (defvar dbus-message-type-method-call) (defvar dbus-message-type-method-return) @@ -2102,7 +2103,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 +2253,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/dictionary-connection.el b/lisp/net/dictionary-connection.el index aef3c4efc74..a4afcd6647d 100644 --- a/lisp/net/dictionary-connection.el +++ b/lisp/net/dictionary-connection.el @@ -83,10 +83,10 @@ Return a data structure identifying the connection." "Return the status of the CONNECTION. Possible return values are the symbols: nil: argument is not a connection object - 'none: argument is not connected - 'up: connection is open and buffer is existing - 'down: connection is closed - 'alone: connection is not associated with a buffer" + `none': argument is not connected + `up': connection is open and buffer is existing + `down': connection is closed + `alone': connection is not associated with a buffer" (when (dictionary-connection-p connection) (let ((process (dictionary-connection-process connection)) (buffer (dictionary-connection-buffer connection))) diff --git a/lisp/net/eudc-bob.el b/lisp/net/eudc-bob.el index 6a2cd13dd03..68a0ccb3a13 100644 --- a/lisp/net/eudc-bob.el +++ b/lisp/net/eudc-bob.el @@ -86,7 +86,7 @@ `("EUDC Image Menu" ["---" nil nil] ["Toggle inline display" eudc-bob-toggle-inline-display - (eudc-bob-can-display-inline-images)] + (display-graphic-p)] ,@(cdr (cdr eudc-bob-generic-menu)))) (defvar eudc-bob-sound-menu @@ -109,14 +109,6 @@ (setq overlays (cdr overlays))) value)) -(defun eudc-bob-can-display-inline-images () - "Return non-nil if we can display images inline." - (if (fboundp 'console-type) - (and (memq (console-type) '(x mswindows)) - (fboundp 'make-glyph)) - (and (fboundp 'display-graphic-p) - (display-graphic-p)))) - (defun eudc-bob-make-button (label keymap &optional menu plist) "Create a button with LABEL. Attach KEYMAP, MENU and properties from PLIST to a new overlay covering @@ -124,7 +116,7 @@ LABEL." (let (overlay (p (point)) prop val) - (insert label) + (insert (or label "")) (put-text-property p (point) 'face 'bold) (setq overlay (make-overlay p (point))) (overlay-put overlay 'mouse-face 'highlight) @@ -142,19 +134,7 @@ LABEL." "Display the JPEG DATA at point. If INLINE is non-nil, try to inline the image otherwise simply display a button." - (cond ((fboundp 'make-glyph) - (let ((glyph (if (eudc-bob-can-display-inline-images) - (make-glyph (list (vector 'jpeg :data data) - [string :data "[JPEG Picture]"]))))) - (eudc-bob-make-button "[JPEG Picture]" - eudc-bob-image-keymap - eudc-bob-image-menu - (list 'glyph glyph - 'end-glyph (if inline glyph) - 'duplicable t - 'invisible inline - 'object-data data)))) - ((fboundp 'create-image) + (cond ((fboundp 'create-image) (let* ((image (create-image data nil t)) (props (list 'object-data data 'eudc-image image))) (when (and inline (image-type-available-p 'jpeg)) @@ -167,7 +147,7 @@ display a button." (defun eudc-bob-toggle-inline-display () "Toggle inline display of an image." (interactive) - (when (eudc-bob-can-display-inline-images) + (when (display-graphic-p) (let* ((overlays (append (overlays-at (1- (point))) (overlays-at (point)))) image) @@ -287,11 +267,13 @@ display a button." ;;;###autoload (defun eudc-display-jpeg-inline (data) "Display the JPEG DATA inline at point if possible." - (eudc-bob-display-jpeg data (eudc-bob-can-display-inline-images))) + (eudc-bob-display-jpeg data (display-graphic-p))) ;;;###autoload (defun eudc-display-jpeg-as-button (data) "Display a button for the JPEG DATA." (eudc-bob-display-jpeg data nil)) +(define-obsolete-function-alias 'eudc-bob-can-display-inline-images #'display-graphic-p "29.1") + ;;; eudc-bob.el ends here diff --git a/lisp/net/eudc-capf.el b/lisp/net/eudc-capf.el new file mode 100644 index 00000000000..68cbfd93ffe --- /dev/null +++ b/lisp/net/eudc-capf.el @@ -0,0 +1,133 @@ +;;; eudc-capf.el --- EUDC - completion-at-point bindings -*- lexical-binding:t -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. +;; +;; Author: Alexander Adolf +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This library provides functions to deliver email addresses from +;; EUDC search results to `completion-at-point'. +;; +;; Email address completion will likely be desirable only in +;; situations where designating email recipients plays a role, such +;; as when composing or replying to email messages, or when posting +;; to newsgroups, possibly with copies of the post being emailed. +;; Hence, modes relevant in such contexts, such as for example +;; `message-mode' and `mail-mode', often at least to some extent +;; provide infrastructure for different functions to be called when +;; completing in certain message header fields, or in the body of +;; the message. In other modes for editing email messages or +;; newsgroup posts, which do not provide such infrastructure, any +;; completion function providing email addresses will need to check +;; whether the completion attempt occurs in an appropriate context +;; (that is, in a relevant message header field) before providing +;; completion candidates. Two mechanisms are thus provided by this +;; library. +;; +;; The first mechanism is intended for use by the modes listed in +;; `eudc-capf-modes', and relies on these modes adding +;; `eudc-capf-complete' to `completion-at-point-functions', as +;; would be usually done for any general-purpose completion +;; function. In this mode of operation, and in order to offer +;; email addresses only in contexts where the user would expect +;; them, a check is performed whether point is on a line that is a +;; message header field suitable for email addresses, such as for +;; example "To:", "Cc:", etc. +;; +;; The second mechanism is intended for when the user modifies +;; `message-completion-alist' to replace `message-expand-name' with +;; the function `eudc-capf-message-expand-name'. As a result, +;; minibuffer completion (`completing-read') for email addresses +;; would no longer enabled in `message-mode', but +;; `completion-at-point' (in-buffer completion) only. + +;;; Usage: + +;; In a major mode, or context where you want email address +;; completion, you would do something along the lines of: +;; +;; (require 'eudc-capf) +;; (add-hook 'completion-at-point-functions #'eudc-capf-complete -1 t) +;; +;; The minus one argument puts it at the front of the list so it is +;; called first, and the t value for the LOCAL parameter causes the +;; setting to be buffer local, so as to avoid modifying any global +;; setting. +;; +;; The value of the variable `eudc-capf-modes' indicates which +;; major modes do such a setup as part of their initialisation +;; code. + +;;; Code: + +(require 'eudc) + +(defvar message-email-recipient-header-regexp) +(defvar mail-abbrev-mode-regexp) +(declare-function mail-abbrev-in-expansion-header-p "mailabbrev" ()) + +(defconst eudc-capf-modes '(message-mode) + "List of modes in which email address completion is to be attempted.") + +;; completion functions + +;;;###autoload +(defun eudc-capf-complete () + "Email address completion function for `completion-at-point-functions'. + +This function checks whether the current major mode is one of the +modes listed in `eudc-capf-modes', and whether point is on a line +with a message header listing email recipients, that is, a line +whose beginning matches `message-email-recipient-header-regexp', +and, if the check succeeds, searches for records matching the +words before point. + +The return value is either nil when no match is found, or a +completion table as required for functions listed in +`completion-at-point-functions'." + (if (and (seq-some #'derived-mode-p eudc-capf-modes) + (let ((mail-abbrev-mode-regexp message-email-recipient-header-regexp)) + (mail-abbrev-in-expansion-header-p))) + (eudc-capf-message-expand-name))) + +;;;###autoload +(defun eudc-capf-message-expand-name () + "Email address completion function for `message-completion-alist'. + +When this function is added to `message-completion-alist', +replacing any existing entry for `message-expand-name' there, +with an appropriate regular expression such as for example +`message-email-recipient-header-regexp', then EUDC will be +queried for email addresses, and the results delivered to +`completion-at-point'." + (if (or eudc-server eudc-server-hotlist) + (progn + (let* ((beg (save-excursion + (re-search-backward "\\([:,]\\|^\\)[ \t]*") + (match-end 0))) + (end (point)) + (prefix (save-excursion (buffer-substring-no-properties beg end)))) + (list beg end + (completion-table-with-cache + (lambda (_) + (eudc-query-with-words (split-string prefix "[ \t]+") t)) + t)))))) + +(provide 'eudc-capf) +;;; eudc-capf.el ends here diff --git a/lisp/net/eudc-vars.el b/lisp/net/eudc-vars.el index 3122b26cd81..90d89e87fba 100644 --- a/lisp/net/eudc-vars.el +++ b/lisp/net/eudc-vars.el @@ -42,7 +42,7 @@ A port number may be specified by appending a colon and a number to the name of the server. Use `localhost' if the directory server resides on your computer (BBDB backend). -To specify multiple servers, customize eudc-server-hotlist +To specify multiple servers, customize `eudc-server-hotlist' instead." :type '(choice (string :tag "Server") (const :tag "None" nil))) @@ -179,32 +179,63 @@ must be set in a protocol/server-local fashion, see `eudc-server-set' and (symbol :menu-tag "Other" :tag "Attribute name")))) :version "25.1") -;; Default to nil so that the most common use of eudc-expand-inline, -;; where replace is nil, does not affect the kill ring. -(defcustom eudc-expansion-overwrites-query nil - "If non-nil, expanding a query overwrites the query string." +(define-obsolete-variable-alias + 'eudc-expansion-overwrites-query + 'eudc-expansion-save-query-as-kill + "29.1") + +;; Default to nil so that the most common use of `eudc-expand-inline', +;; where `save-query-as-kill' is nil, does not affect the kill ring. +(defcustom eudc-expansion-save-query-as-kill nil + "If non-nil, expansion saves the query string to the kill ring." :type 'boolean :version "25.1") -(defcustom eudc-inline-expansion-format '("%s %s <%s>" firstname name email) - "A list specifying the format of the expansion of inline queries. -This variable controls what `eudc-expand-inline' actually inserts in -the buffer. First element is a string passed to `format'. Remaining -elements are symbols indicating attribute names; the corresponding values -are passed as additional arguments to `format'." - :type '(list - (string :tag "Format String") - (repeat :inline t - :tag "Attributes" - (choice - :tag "Attribute" - (const :menu-tag "First Name" :tag "First Name" firstname) - (const :menu-tag "Surname" :tag "Surname" name) - (const :menu-tag "Email Address" :tag "Email Address" email) - (const :menu-tag "Phone" :tag "Phone" phone) - (symbol :menu-tag "Other") - (symbol :tag "Attribute name")))) - :version "25.1") +(defcustom eudc-inline-expansion-format nil + "Specify the format of the expansion of inline queries. +This variable controls what `eudc-expand-inline' actually inserts +in the buffer. It is either a list, or a function. + +When set to a list, the expansion result will be formatted +according to the first element of the list, a string, which is +passed as the first argument to `format'. The remaining elements +of the list are symbols indicating attribute names; the +corresponding values are passed as additional arguments to +`format'. + +When set to nil, the expansion result will be formatted using +`eudc-rfc5322-make-address', and the PHRASE part will be +formatted according to \"firstname name\", quoting the result if +necessary. No COMMENT will be added in this case. + +When set to a function, the expansion result will be formatted +using `eudc-rfc5322-make-address', and the referenced function is +used to format the PHRASE, and COMMENT parts, respectively. It +receives a single argument, which is an alist of +protocol-specific attributes describing the recipient. To access +the alist elements using generic EUDC attribute names, such as +for example name, or email, use `eudc-translate-attribute-list'. +The function should return a list, which should contain two +elements. If the first element is a string, it will be used as +the PHRASE part, quoting it if necessary. If the second element +is a string, it will be used as the COMMENT part, unless it +contains characters not allowed in the COMMENT part by RFC 5322, +in which case the COMMENT part will be omitted." + :type '(choice (const :tag "RFC 5322 formatted \"first last <address>\"" nil) + (function :tag "RFC 5322 phrase/comment formatting function") + (list :tag "Format string (deprecated)" + (string :tag "Format String") + (repeat :inline t + :tag "Attributes" + (choice + :tag "Attribute" + (const :menu-tag "First Name" :tag "First Name" firstname) + (const :menu-tag "Surname" :tag "Surname" name) + (const :menu-tag "Email Address" :tag "Email Address" email) + (const :menu-tag "Phone" :tag "Phone" phone) + (symbol :menu-tag "Other") + (symbol :tag "Attribute name"))))) + :version "29.1") (defcustom eudc-inline-expansion-servers 'server-then-hotlist "Which servers to contact for the expansion of inline queries. @@ -394,6 +425,15 @@ BBDB fields. SPECs are sexps which are evaluated: (symbol :tag "BBDB Field") (sexp :tag "Conversion Spec")))) +(defcustom eudc-ldap-no-wildcard-attributes + '(objectclass objectcategory) + "LDAP attributes which are always searched for without wildcard character. +This is the list of special dictionary-valued attributes, where +wildcarded search may fail. For example, it fails with +objectclass in Active Directory servers." + :type '(repeat (symbol :tag "Directory attribute"))) + + ;;}}} ;;{{{ BBDB Custom Group diff --git a/lisp/net/eudc.el b/lisp/net/eudc.el index 5258947902d..808d2ca509c 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 @@ -169,6 +162,75 @@ Value is the new string." newtext))) (concat rtn-str (substring str start)))) + +(defconst eudc-rfc5322-atext-token "[:alpha:][:digit:]!#$%&'*+/=?^_`{|}~-" + "Printable US-ASCII characters not including specials. Used for atoms.") + +(defconst eudc-rfc5322-wsp-token " \t" + "Non-folding white space.") + +(defconst eudc-rfc5322-fwsp-token + (concat eudc-rfc5322-wsp-token "\n") + "Folding white space.") + +(defconst eudc-rfc5322-cctext-token "\u005D-\u007E\u002A-\u005B\u0021-\u0027" + "Printable US-ASCII characters not including \"(\", \")\", or \"\\\".") + +(defun eudc-rfc5322-quote-phrase (string) + "Quote STRING if it needs quoting as a phrase in a header." + (if (string-match + (concat "[^" eudc-rfc5322-wsp-token eudc-rfc5322-atext-token "]") + string) + (concat "\"" string "\"") + string)) + +(defun eudc-rfc5322-valid-comment-p (string) + "Check if STRING can be used as comment in a header." + (if (string-match + (concat "[^" eudc-rfc5322-cctext-token eudc-rfc5322-fwsp-token "]") + string) + nil + t)) + +(defun eudc-rfc5322-make-address (address &optional firstname name comment) + "Create a valid address specification according to RFC5322. +RFC5322 address specifications are used in message header fields +to indicate senders and recipients of messages. They generally +have one of the forms: + +ADDRESS +ADDRESS (COMMENT) +PHRASE <ADDRESS> +PHRASE <ADDRESS> (COMMENT) + +The arguments FIRSTNAME and NAME are combined to form PHRASE. +PHRASE is enclosed in double quotes if necessary. + +COMMENT is omitted if it contains any symbols outside the +permitted set `eudc-rfc5322-cctext-token'." + (if (and address + (not (string-blank-p address))) + (let ((result address) + (name-given (and name + (not (string-blank-p name)))) + (firstname-given (and firstname + (not (string-blank-p firstname)))) + (valid-comment-given (and comment + (not (string-blank-p comment)) + (eudc-rfc5322-valid-comment-p comment)))) + (if (or name-given firstname-given) + (let ((phrase (string-trim (concat firstname " " name)))) + (setq result + (concat + (eudc-rfc5322-quote-phrase phrase) + " <" result ">")))) + (if valid-comment-given + (setq result + (concat result " (" comment ")"))) + result) + ;; nil or empty address, nothing to return + nil)) + ;;}}} ;;{{{ Server and Protocol Variable Routines @@ -305,8 +367,8 @@ accordingly. Otherwise it is set to its EUDC default binding." ;;}}} -;; Add PROTOCOL to the list of supported protocols (defun eudc-register-protocol (protocol) + "Add PROTOCOL to the list of supported protocols." (unless (memq protocol eudc-supported-protocols) (setq eudc-supported-protocols (cons protocol eudc-supported-protocols)) @@ -748,9 +810,18 @@ If none try N - 1 and so forth." (setq n (1- n))) formats)) +;;;###autoload +(defun eudc-expand-try-all (&optional try-all-servers) + "Wrap `eudc-expand-inline' with a prefix argument. +If TRY-ALL-SERVERS -- the prefix argument when called +interactively -- is non-nil, collect results from all servers. +If TRY-ALL-SERVERS is nil, do not try subsequent servers after +one server returns any match." + (interactive "P") + (eudc-expand-inline (not eudc-expansion-save-query-as-kill) try-all-servers)) ;;;###autoload -(defun eudc-expand-inline (&optional replace) +(defun eudc-expand-inline (&optional save-query-as-kill try-all-servers) "Query the directory server, and expand the query string before point. The query string consists of the buffer substring from the point back to the preceding comma, colon or beginning of line. @@ -758,10 +829,12 @@ The variable `eudc-inline-query-format' controls how to associate the individual inline query words with directory attribute names. After querying the server for the given string, the expansion specified by `eudc-inline-expansion-format' is inserted in the buffer at point. -If REPLACE is non-nil, then this expansion replaces the name in the buffer. -`eudc-expansion-overwrites-query' being non-nil inverts the meaning of REPLACE. +If SAVE-QUERY-AS-KILL is non-nil, then save the pre-expansion +text to the kill ring. `eudc-expansion-save-query-as-kill' being +non-nil inverts the meaning of SAVE-QUERY-AS-KILL. Multiple servers can be tried with the same query until one finds a match, -see `eudc-inline-expansion-servers'." +see `eudc-inline-expansion-servers'. If TRY-ALL-SERVERS is +non-nil, collect results from all servers." (interactive) (let* ((end (point)) (beg (save-excursion @@ -771,13 +844,13 @@ see `eudc-inline-expansion-servers'." (point))) (query-words (split-string (buffer-substring-no-properties beg end) "[ \t]+")) - (response-strings (eudc-query-with-words query-words))) + (response-strings (eudc-query-with-words query-words try-all-servers))) (if (null response-strings) (error "No match") (if (or - (and replace (not eudc-expansion-overwrites-query)) - (and (not replace) eudc-expansion-overwrites-query)) + (and save-query-as-kill (not eudc-expansion-save-query-as-kill)) + (and (not save-query-as-kill) eudc-expansion-save-query-as-kill)) (kill-ring-save beg end)) (cond ((or (= (length response-strings) 1) @@ -794,15 +867,65 @@ see `eudc-inline-expansion-servers'." (error "There is more than one match for the query")))))) ;;;###autoload -(defun eudc-query-with-words (query-words) +(defun eudc-format-inline-expansion-result (res query-attrs) + "Format a query result according to `eudc-inline-expansion-format'." + (cond + ;; format string + ((consp eudc-inline-expansion-format) + (string-trim (apply #'format + (car eudc-inline-expansion-format) + (mapcar + (lambda (field) + (or (cdr (assq field res)) + "")) + (eudc-translate-attribute-list + (cdr eudc-inline-expansion-format)))))) + + ;; formatting function + ((functionp eudc-inline-expansion-format) + (let ((addr (cdr (assq (nth 2 query-attrs) res))) + (ucontent (funcall eudc-inline-expansion-format res))) + (if (and ucontent + (listp ucontent)) + (let* ((phrase (car ucontent)) + (comment (cadr ucontent)) + (phrase-given + (and phrase + (stringp phrase) + (not (string-blank-p phrase)))) + (valid-comment-given + (and comment + (stringp comment) + (not (string-blank-p comment)) + (eudc-rfc5322-valid-comment-p + comment)))) + (eudc-rfc5322-make-address + addr nil + (if phrase-given phrase nil) + (if valid-comment-given comment nil))) + (progn + (error "Error: the function referenced by \ +`eudc-inline-expansion-format' is expected to return a list.") + nil)))) + + ;; fallback behaviour (nil function, or non-matching type) + (t + (let ((fname (cdr (assq (nth 0 query-attrs) res))) + (lname (cdr (assq (nth 1 query-attrs) res))) + (addr (cdr (assq (nth 2 query-attrs) res)))) + (eudc-rfc5322-make-address addr fname lname))))) + +;;;###autoload +(defun eudc-query-with-words (query-words &optional try-all-servers) "Query the directory server, and return the matching responses. The variable `eudc-inline-query-format' controls how to associate the individual QUERY-WORDS with directory attribute names. After querying the server for the given string, the expansion specified by `eudc-inline-expansion-format' is applied to the -matches before returning them.inserted in the buffer at point. +matches before returning them. Multiple servers can be tried with the same query until one finds a match, -see `eudc-inline-expansion-servers'." +see `eudc-inline-expansion-servers'. When TRY-ALL-SERVERS is non-nil, +keep collecting results from subsequent servers after the first match." (cond ((eq eudc-inline-expansion-servers 'current-server) (or eudc-server @@ -819,6 +942,7 @@ see `eudc-inline-expansion-servers'." (error "Wrong value for `eudc-inline-expansion-servers': %S" eudc-inline-expansion-servers))) (let* (query-formats + response-strings (eudc-former-server eudc-server) (eudc-former-protocol eudc-protocol) ;; Prepare the list of servers to query @@ -830,7 +954,7 @@ see `eudc-inline-expansion-servers'." (if eudc-server (cons (cons eudc-server eudc-protocol) (delete (cons eudc-server eudc-protocol) - (copy-sequence eudc-server-hotlist))) + (copy-sequence eudc-server-hotlist))) eudc-server-hotlist)) ((eq eudc-inline-expansion-servers 'current-server) (list (cons eudc-server eudc-protocol)))))) @@ -840,46 +964,46 @@ see `eudc-inline-expansion-servers'." (setcdr (nthcdr (1- eudc-max-servers-to-query) servers) nil)) (unwind-protect - (let ((response - (catch 'found - ;; Loop on the servers - (dolist (server servers) - (eudc-set-server (car server) (cdr server) t) - - ;; Determine which formats apply in the query-format list - (setq query-formats - (or - (eudc-extract-n-word-formats eudc-inline-query-format - (length query-words)) - (if (null eudc-protocol-has-default-query-attributes) - '(name)))) - - ;; Loop on query-formats - (while query-formats - (let ((response - (eudc-query - (eudc-format-query query-words (car query-formats)) - (eudc-translate-attribute-list - (cdr eudc-inline-expansion-format))))) - (if response - (throw 'found response))) - (setq query-formats (cdr query-formats)))) - ;; No more servers to try... no match found - nil)) - (response-strings '())) - - ;; Process response through eudc-inline-expansion-format - (dolist (r response) - (let ((response-string - (apply #'format - (car eudc-inline-expansion-format) - (mapcar (lambda (field) - (or (cdr (assq field r)) - "")) - (eudc-translate-attribute-list - (cdr eudc-inline-expansion-format)))))) - (if (> (length response-string) 0) - (push response-string response-strings)))) + (cl-flet + ((run-query + (query-formats) + (let* ((query-attrs (eudc-translate-attribute-list + (if (consp eudc-inline-expansion-format) + (cdr eudc-inline-expansion-format) + '(firstname name email)))) + (response + (eudc-query + (eudc-format-query query-words (car query-formats)) + query-attrs))) + (when response + ;; Format response. + (dolist (r response) + (let ((response-string + (eudc-format-inline-expansion-result r query-attrs))) + (if response-string + (cl-pushnew response-string response-strings + :test #'equal)))) + (when (not try-all-servers) + (throw 'found nil)))))) + (catch 'found + ;; Loop on the servers. + (dolist (server servers) + (eudc-set-server (car server) (cdr server) t) + + ;; Determine which formats apply in the query-format list. + (setq query-formats + (or + (eudc-extract-n-word-formats eudc-inline-query-format + (length query-words)) + (if (null eudc-protocol-has-default-query-attributes) + '(name)))) + + ;; Loop on query-formats. + (while query-formats + (run-query query-formats) + (setq query-formats (cdr query-formats)))) + ;; No more servers to try... no match found. + nil) response-strings) (or (and (equal eudc-server eudc-former-server) (equal eudc-protocol eudc-former-protocol)) @@ -1059,6 +1183,8 @@ queries the server for the existing fields and displays a corresponding form." `(["---" nil nil] ["Query with Form" eudc-query-form :help "Display a form to query the directory server"] + ["Expand Inline Query Trying All Servers" eudc-expand-try-all + :help "Query all directory servers and expand the query string before point"] ["Expand Inline Query" eudc-expand-inline :help "Query the directory server, and expand the query string before point"] ["Insert Record into BBDB" eudc-insert-record-at-point-into-bbdb @@ -1093,6 +1219,7 @@ queries the server for the existing fields and displays a corresponding form." :help "Set the directory server to SERVER using PROTOCOL"])) (defun eudc-menu () + "Return easy menu for EUDC." (let (command) (append '("Directory Servers") (list @@ -1124,6 +1251,7 @@ queries the server for the existing fields and displays a corresponding form." eudc-tail-menu))) (defun eudc-install-menu () + "Install EUDC menu." (define-key global-map [menu-bar tools directory-search] diff --git a/lisp/net/eudcb-ldap.el b/lisp/net/eudcb-ldap.el index 365dace961a..1201c84f2d3 100644 --- a/lisp/net/eudcb-ldap.el +++ b/lisp/net/eudcb-ldap.el @@ -151,16 +151,20 @@ attribute names are returned. Default to `person'." (interactive) (or eudc-server (call-interactively 'eudc-set-server)) - (let ((ldap-host-parameters-alist - (list (cons eudc-server - '(scope subtree sizelimit 1))))) - (mapcar #'eudc-ldap-cleanup-record-filtering-addresses - (ldap-search - (eudc-ldap-format-query-as-rfc1558 - (list (cons "objectclass" - (or objectclass - "person")))) - eudc-server nil t)))) + (let ((plist (copy-sequence + (alist-get eudc-server ldap-host-parameters-alist + nil nil #'equal)))) + (plist-put plist 'scope 'subtree) + (plist-put plist 'sizelimit '1) + (let ((ldap-host-parameters-alist + (list (cons eudc-server plist)))) + (mapcar #'eudc-ldap-cleanup-record-filtering-addresses + (ldap-search + (eudc-ldap-format-query-as-rfc1558 + (list (cons 'objectclass + (or objectclass + "person")))) + eudc-server nil t))))) (defun eudc-ldap-escape-query-special-chars (string) "Value is STRING with characters forbidden in LDAP queries escaped." @@ -178,12 +182,17 @@ attribute names are returned. Default to `person'." (defun eudc-ldap-format-query-as-rfc1558 (query) "Format the EUDC QUERY list as a RFC1558 LDAP search filter." - (let ((formatter (lambda (item &optional wildcard) - (format "(%s=%s)" - (car item) - (concat - (eudc-ldap-escape-query-special-chars - (cdr item)) (if wildcard "*" "")))))) + (let ((formatter + (lambda (item &optional wildcard) + (format "(%s=%s)" + (car item) + (concat + (eudc-ldap-escape-query-special-chars + (cdr item)) + (if (and wildcard + (not (memq (car item) + eudc-ldap-no-wildcard-attributes))) + "*" "")))))) (format "(&%s)" (concat (mapconcat formatter (butlast query) "") diff --git a/lisp/net/eww.el b/lisp/net/eww.el index c39f6e3e1e1..8f02be12ff8 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -32,6 +32,7 @@ (require 'thingatpt) (require 'url) (require 'url-queue) +(require 'url-file) (require 'xdg) (eval-when-compile (require 'subr-x)) @@ -178,6 +179,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 +232,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 pgtk) (class color)) ; Like default mode line :box (:line-width 2 :style released-button) :background "#808080" :foreground "black")) "Face for eww buffer buttons." @@ -206,7 +248,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 pgtk) (class color)) ; Like default mode line :box (:line-width 2 :style released-button) :background "#808080" :foreground "black")) "Face for eww buffer buttons." @@ -214,7 +256,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 pgtk) (class color)) ; Like default mode line :box (:line-width 2 :style released-button) :background "lightgrey" :foreground "black")) "Face for eww buffer buttons." @@ -222,7 +264,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 pgtk) (class color)) ; Like default mode line :box (:line-width 2 :style released-button) :background "lightgrey" :foreground "black")) "Face for eww buffer buttons." @@ -269,17 +311,15 @@ See also `eww-form-checkbox-selected-symbol'." (defvar eww-accept-content-types "text/html, text/plain, text/sgml, text/css, application/xhtml+xml, */*;q=0.01" - "Value used for the HTTP 'Accept' header.") + "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 +353,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 +369,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 +393,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))) @@ -447,22 +488,21 @@ killed after rendering." (defun eww-open-file (file) "Render FILE using EWW." (interactive "fFile: ") - (eww (concat "file://" - (and (memq system-type '(windows-nt ms-dos)) - "/") - (expand-file-name file)) - nil - ;; The file name may be a non-local Tramp file. The URL - ;; library doesn't understand these file names, so use the - ;; normal Emacs machinery to load the file. - (with-current-buffer (generate-new-buffer " *eww file*") - (set-buffer-multibyte nil) - (insert "Content-type: " (or (mailcap-extension-to-mime - (url-file-extension file)) - "application/octet-stream") - "\n\n") - (insert-file-contents file) - (current-buffer)))) + (let ((url-allow-non-local-files t)) + (eww (concat "file://" + (and (memq system-type '(windows-nt ms-dos)) + "/") + (expand-file-name file))))) + +(defun eww--file-buffer (file) + (with-current-buffer (generate-new-buffer " *eww file*") + (set-buffer-multibyte nil) + (insert "Content-type: " (or (mailcap-extension-to-mime + (url-file-extension file)) + "application/octet-stream") + "\n\n") + (insert-file-contents file) + (current-buffer))) ;;;###autoload (defun eww-search-words () @@ -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,14 +702,15 @@ 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)) (shr-target-id (goto-char (point-min)) (let ((match (text-property-search-forward - 'shr-target-id shr-target-id t))) + 'shr-target-id shr-target-id #'member))) (when match (goto-char (prop-match-beginning match))))) (t @@ -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." @@ -1135,7 +1204,8 @@ instead of `browse-url-new-window-flag'." (format "*eww-%s*" (url-host (url-generic-parse-url (eww--dwim-expand-url url)))))) (eww-mode)) - (eww url)) + (let ((url-allow-non-local-files t)) + (eww url))) (defun eww-back-url () "Go to the previously displayed page." @@ -1166,7 +1236,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'. @@ -1222,62 +1292,58 @@ just re-display the HTML already fetched." (error "No current HTML data") (eww-display-html 'utf-8 url (plist-get eww-data :dom) (point) (current-buffer))) - (let ((url-mime-accept-string eww-accept-content-types)) - (eww-retrieve url #'eww-render - (list url (point) (current-buffer) encode)))))) + (let ((parsed (url-generic-parse-url url))) + (if (equal (url-type parsed) "file") + ;; Use Tramp instead of url.el for files (since url.el + ;; doesn't work well with Tramp files). + (let ((eww-buffer (current-buffer))) + (with-current-buffer (eww--file-buffer (url-filename parsed)) + (eww-render nil url nil eww-buffer))) + (let ((url-mime-accept-string eww-accept-content-types)) + (eww-retrieve url #'eww-render + (list url (point) (current-buffer) encode)))))))) ;; Form support. (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 +1850,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) + "Apply `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 +1871,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 +1891,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. @@ -1975,7 +2053,9 @@ If CHARSET is nil then use UTF-8." (defun eww-write-bookmarks () (with-temp-file (expand-file-name "eww-bookmarks" eww-bookmarks-directory) (insert ";; Auto-generated file; don't edit -*- mode: lisp-data -*-\n") - (pp eww-bookmarks (current-buffer)))) + (let ((print-length nil) + (print-level nil)) + (pp eww-bookmarks (current-buffer))))) (defun eww-read-bookmarks (&optional error-out) "Read bookmarks from `eww-bookmarks'. @@ -2100,23 +2180,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 +2256,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 +2375,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. @@ -2442,6 +2509,8 @@ Otherwise, the restored buffer will contain a prompt to do so by using "Default bookmark handler for EWW buffers." (eww (bookmark-prop-get bookmark 'location))) +(put 'eww-bookmark-jump 'bookmark-handler-type "EWW") + (provide 'eww) ;;; eww.el ends here diff --git a/lisp/net/hmac-def.el b/lisp/net/hmac-def.el index 13af2c123f8..0c8a29cc392 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/ldap.el b/lisp/net/ldap.el index ce6c270e0bc..da45457891b 100644 --- a/lisp/net/ldap.el +++ b/lisp/net/ldap.el @@ -148,7 +148,7 @@ Valid properties include: "The name of the ldapsearch command line program." :type '(string :tag "`ldapsearch' Program")) -(defcustom ldap-ldapsearch-args '("-LL" "-tt") +(defcustom ldap-ldapsearch-args '("-LLL" "-tt") "A list of additional arguments to pass to `ldapsearch'." :type '(repeat :tag "`ldapsearch' Arguments" (string :tag "Argument"))) @@ -663,7 +663,7 @@ an alist of attribute/value pairs." (while (not (memq (process-status proc) '(exit signal))) (sit-for 0.1)) (let ((status (process-exit-status proc))) - (when (not (eq status 0)) + (when (not (memql status '(0 4))) ; 4 = Size limit exceeded ;; Handle invalid credentials exit status specially ;; for ldap-password-read. (if (eq status 49) @@ -682,7 +682,7 @@ an alist of attribute/value pairs." (while (re-search-forward (concat "[\t\n\f]+ \\|" ldap-ldapsearch-password-prompt-regexp) nil t) - (replace-match "" nil nil)) + (replace-match "")) (goto-char (point-min)) (if (looking-at "usage") @@ -691,7 +691,6 @@ an alist of attribute/value pairs." ;; Skip error message when retrieving attribute list (if (looking-at "Size limit exceeded") (forward-line 1)) - (if (looking-at "version:") (forward-line 1)) ;bug#12724. (while (progn (skip-chars-forward " \t\n") (not (eobp))) @@ -699,7 +698,7 @@ an alist of attribute/value pairs." (forward-line 1) (while (looking-at "^\\([A-Za-z][-A-Za-z0-9]*\ \\|[0-9]+\\(?:\\.[0-9]+\\)*\\)\\(;[-A-Za-z0-9]+\\)*[=:\t ]+\ -\\(<[\t ]*file://\\)\\(.*\\)$") +\\(<[\t ]*file://\\)?\\(.*\\)$") (setq name (match-string 1) value (match-string 4)) ;; Need to handle file:///D:/... as generated by OpenLDAP @@ -724,7 +723,6 @@ an alist of attribute/value pairs." (record (push (nreverse record) result))) (setq record nil) - (skip-chars-forward " \t\n") (message "Parsing results... %d" numres) (setq numres (1+ numres))) (message "Parsing results... done") diff --git a/lisp/net/mailcap.el b/lisp/net/mailcap.el index a59220c1be8..8ba7f1bec3d 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 @@ -320,8 +319,9 @@ attribute name (viewer, test, etc). This looks like: Where VIEWERINFO specifies how the content-type is viewed. Can be a string, in which case it is run through a shell, with appropriate -parameters, or a symbol, in which case the symbol is `funcall'ed if -and only if it exists as a function, with the buffer as an argument. +parameters, or a symbol, in which case the symbol must name a function +of zero arguments which is called in a buffer holding the MIME part's +content. TESTINFO is a test for the viewer's applicability, or nil. If nil, it means the viewer is always valid. If it is a Lisp function, it is @@ -344,8 +344,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 +422,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 +438,27 @@ 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 (or (null mailcap--computed-mime-data) + (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 +636,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 +707,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 +837,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 +1065,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)) @@ -1089,11 +1098,12 @@ For instance, \"foo.png\" will result in \"image/png\"." (mailcap-parse-mimetypes) (let* ((all-mime-type ;; All unique MIME types from file extensions - (delete-dups - (mapcar (lambda (file) - (mailcap-extension-to-mime - (file-name-extension file t))) - files))) + (delq nil + (delete-dups + (mapcar (lambda (file) + (mailcap-extension-to-mime + (file-name-extension file t))) + files)))) (all-mime-info ;; All MIME info lists (delete-dups @@ -1167,34 +1177,45 @@ See \"~/.mailcap\", `mailcap-mime-data' and related files and variables." (mailcap-parse-mailcaps) (let ((command (mailcap-mime-info (mailcap-extension-to-mime (file-name-extension file))))) - (unless command - (error "No viewer for %s" (file-name-extension file))) - ;; Remove quotes around the file name - we'll use shell-quote-argument. - (while (string-match "['\"]%s['\"]" command) - (setq command (replace-match "%s" t t command))) - (setq command (replace-regexp-in-string - "%s" - (shell-quote-argument (convert-standard-filename file)) - command - nil t)) - ;; Handlers such as "gio open" and kde-open5 start viewer in background - ;; and exit immediately. Avoid `start-process' since it assumes - ;; :connection-type `pty' and kills children processes with SIGHUP - ;; when temporary terminal session is finished (Bug#44824). - ;; An alternative is `process-connection-type' let-bound to nil for - ;; `start-process-shell-command' call (with no chance to report failure). - (make-process - :name "mailcap-view-file" - :connection-type 'pipe - :buffer nil ; "*Messages*" may be suitable for debugging - :sentinel (lambda (proc event) - (when (and (memq (process-status proc) '(exit signal)) - (/= (process-exit-status proc) 0)) - (message - "Command %s: %s." - (mapconcat #'identity (process-command proc) " ") - (substring event 0 -1)))) - :command (list shell-file-name shell-command-switch command)))) + (if (functionp command) + ;; command is a viewer function (a mode) expecting the file + ;; contents to be in the current buffer. + (let ((buf (generate-new-buffer (file-name-nondirectory file)))) + (set-buffer buf) + (insert-file-contents file) + (setq buffer-file-name file) + (funcall command) + (set-buffer-modified-p nil) + (pop-to-buffer buf)) + ;; command is a program to run with file as an argument. + (unless command + (error "No viewer for %s" (file-name-extension file))) + ;; Remove quotes around the file name - we'll use shell-quote-argument. + (while (string-match "['\"]%s['\"]" command) + (setq command (replace-match "%s" t t command))) + (setq command (replace-regexp-in-string + "%s" + (shell-quote-argument (convert-standard-filename file)) + command + nil t)) + ;; Handlers such as "gio open" and kde-open5 start viewer in background + ;; and exit immediately. Avoid `start-process' since it assumes + ;; :connection-type `pty' and kills children processes with SIGHUP + ;; when temporary terminal session is finished (Bug#44824). + ;; An alternative is `process-connection-type' let-bound to nil for + ;; `start-process-shell-command' call (with no chance to report failure). + (make-process + :name "mailcap-view-file" + :connection-type 'pipe + :buffer nil ; "*Messages*" may be suitable for debugging + :sentinel (lambda (proc event) + (when (and (memq (process-status proc) '(exit signal)) + (/= (process-exit-status proc) 0)) + (message + "Command %s: %s." + (mapconcat #'identity (process-command proc) " ") + (substring event 0 -1)))) + :command (list shell-file-name shell-command-switch command))))) (provide 'mailcap) diff --git a/lisp/net/newst-backend.el b/lisp/net/newst-backend.el index 01cbbbbe011..7ae58884f97 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." @@ -1704,11 +1697,11 @@ Checks list of active processes against list of newsticker processes." ;; ====================================================================== (defun newsticker--images-dir () "Return directory where feed images are saved." - (concat newsticker-dir "/images/")) + (expand-file-name "images/" newsticker-dir)) (defun newsticker--icons-dir () "Return directory where feed icons are saved." - (concat newsticker-dir "/icons/")) + (expand-file-name "icons/" newsticker-dir)) (defun newsticker--image-get (feed-name filename directory url) "Get image for FEED-NAME by returning FILENAME from DIRECTORY. @@ -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!" @@ -2143,7 +2114,7 @@ FEED is a symbol!" (defun newsticker--cache-dir () "Return directory for saving cache data." - (concat newsticker-dir "/feeds")) + (expand-file-name "feeds/" newsticker-dir)) (defun newsticker--cache-save () "Save cache data for all feeds." @@ -2154,42 +2125,27 @@ FEED is a symbol!" (defun newsticker--cache-save-feed (feed) "Save cache data for FEED." - (let ((dir (concat (newsticker--cache-dir) "/" (symbol-name (car feed))))) + (let ((dir (file-name-as-directory + (expand-file-name (symbol-name (car feed)) + (newsticker--cache-dir))))) (unless (file-directory-p dir) (make-directory dir t)) (let ((coding-system-for-write 'utf-8)) - (with-temp-file (concat dir "/data") + (with-temp-file (expand-file-name "data" dir) (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))))))) + (prin1 (cdr feed) (current-buffer) t))))) (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." - (let ((file-name (concat (newsticker--cache-dir) "/" feed-name "/data")) + (let ((file-name (expand-file-name + "data" (expand-file-name + feed-name (newsticker--cache-dir)))) (coding-system-for-read 'utf-8)) (when (file-exists-p file-name) (with-temp-buffer @@ -2261,8 +2217,7 @@ Export subscriptions to a buffer in OPML Format." (newsticker--opml-insert-feed (car f) 4))) (insert " </body>\n</opml>\n"))) (pop-to-buffer "*OPML Export*") - (when (fboundp 'sgml-mode) - (sgml-mode))) + (sgml-mode)) (defun newsticker--opml-insert-elt (elt depth) "Insert an OPML ELT with indentation level DEPTH." @@ -2382,14 +2337,19 @@ This function just prints out the values of the FEEDNAME and title of the ITEM." "Download the first image. If FEEDNAME equals \"imagefeed\" download the first image URL found in the description=contents of ITEM to the directory -\"~/tmp/newsticker/FEEDNAME/TITLE\" where TITLE is the title of -the item." +`temporary-file-directory'/newsticker/FEEDNAME/TITLE where TITLE +is the title of the item." (when (string= feedname "imagefeed") (let ((title (newsticker--title item)) (desc (newsticker--desc item))) (when (string-match "<img src=\"\\(http://[^ \"]+\\)\"" desc) (let ((url (substring desc (match-beginning 1) (match-end 1))) - (temp-dir (concat "~/tmp/newsticker/" feedname "/" title)) + (temp-dir (file-name-as-directory + (expand-file-name + title (expand-file-name + feedname (expand-file-name + "newsticker" + temporary-file-directory))))) (org-dir default-directory)) (unless (file-directory-p temp-dir) (make-directory temp-dir t)) @@ -2403,7 +2363,8 @@ the item." (defun newsticker-download-enclosures (feedname item) "In all feeds download the enclosed object of the news ITEM. -The object is saved to the directory \"~/tmp/newsticker/FEEDNAME/TITLE\", which +The object is saved to the directory +`temporary-file-directory'/newsticker/FEEDNAME/TITLE, which is created if it does not exist. TITLE is the title of the news item. Argument FEEDNAME is ignored. This function is suited for adding it to `newsticker-new-item-functions'." @@ -2411,7 +2372,12 @@ This function is suited for adding it to `newsticker-new-item-functions'." (enclosure (newsticker--enclosure item))) (when enclosure (let ((url (cdr (assoc 'url enclosure))) - (temp-dir (concat "~/tmp/newsticker/" feedname "/" title)) + (temp-dir (file-name-as-directory + (expand-file-name + title (expand-file-name + feedname (expand-file-name + "newsticker" + temporary-file-directory))))) (org-dir default-directory)) (unless (file-directory-p temp-dir) (make-directory temp-dir t)) diff --git a/lisp/net/newst-plainview.el b/lisp/net/newst-plainview.el index f026948251d..df574dfa2f4 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/newst-treeview.el b/lisp/net/newst-treeview.el index 80d9fd1cef2..b429a33dec8 100644 --- a/lisp/net/newst-treeview.el +++ b/lisp/net/newst-treeview.el @@ -106,13 +106,13 @@ applies to newsticker only." (defcustom newsticker-treeview-use-feed-name-from-url-list-in-treeview t - "Use the feed names from 'newsticker-url-list' for display in treeview." + "Use the feed names from `newsticker-url-list' for display in treeview." :version "28.1" :type 'boolean) (defcustom newsticker-treeview-use-feed-name-from-url-list-in-itemview t - "Use feed names from 'newsticker-url-list' in itemview." + "Use feed names from `newsticker-url-list' in itemview." :version "28.1" :type 'boolean) @@ -1257,20 +1257,20 @@ Note: does not update the layout." "Save treeview group settings." (interactive) (let ((coding-system-for-write 'utf-8) - (buf (find-file-noselect (concat newsticker-dir "/groups")))) + (buf (find-file-noselect (expand-file-name "groups" newsticker-dir)))) (when buf (with-current-buffer buf (setq buffer-undo-list t) (erase-buffer) (insert ";; -*- coding: utf-8 -*-\n") - (insert (prin1-to-string newsticker-groups)) + (prin1 newsticker-groups (current-buffer) t) (save-buffer) (kill-buffer))))) (defun newsticker--treeview-load () "Load treeview settings." (let* ((coding-system-for-read 'utf-8) - (filename (concat newsticker-dir "/groups")) + (filename (expand-file-name "groups" newsticker-dir)) (buf (and (file-exists-p filename) (find-file-noselect filename)))) (when buf @@ -1283,7 +1283,6 @@ Note: does not update the layout." (setq newsticker-groups nil))) (kill-buffer buf)))) - (defun newsticker-treeview-scroll-item () "Scroll current item." (interactive) diff --git a/lisp/net/nsm.el b/lisp/net/nsm.el index d95593da3bc..3146189be63 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/ntlm.el b/lisp/net/ntlm.el index 1589770f203..b58f0abb56b 100644 --- a/lisp/net/ntlm.el +++ b/lisp/net/ntlm.el @@ -102,9 +102,7 @@ is not given." (let ((request-ident (concat "NTLMSSP" (make-string 1 0))) (request-msgType (concat (make-string 1 1) (make-string 3 0))) ;0x01 0x00 0x00 0x00 - (request-flags (concat (make-string 1 7) (make-string 1 130) - (make-string 1 8) (make-string 1 0))) - ;0x07 0x82 0x08 0x00 + (request-flags (unibyte-string #x07 #x82 #x08 #x00)) ) (when (and user (string-match "@" user)) (unless domain @@ -245,9 +243,7 @@ by PASSWORD-HASHES. PASSWORD-HASHES should be a return value of ;;(msgType (substring rchallenge 8 12)) ;msgType, 4 bytes (uDomain (substring rchallenge 12 20)) ;uDomain, 8 bytes ;; match default setting in `ntlm-build-auth-request' - (request-flags (concat (make-string 1 7) (make-string 1 130) - (make-string 1 8) (make-string 1 0))) - ;0x07 0x82 0x08 0x00 + (request-flags (unibyte-string #x07 #x82 #x08 #x00)) (flags (substring rchallenge 20 24)) ;flags, 4 bytes (challengeData (substring rchallenge 24 32)) ;challengeData, 8 bytes ;; Extract domain string from challenge string. diff --git a/lisp/net/puny.el b/lisp/net/puny.el index d22cc88b7bd..3a276791ab2 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 8feef6beebe..0d30b349229 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. @@ -428,6 +433,20 @@ will be killed." :version "28.1" :type 'boolean) +(defcustom rcirc-cycle-completion-flag nil + "Non-nil means to use cycling for completion in rcirc buffers. +See the Info node `(emacs) Completion Options' for background on +what cycling completion means." + :version "29.1" + :set (lambda (sym val) + (dolist (buf (match-buffers '(major-mode . rcirc-mode))) + (with-current-buffer buf + (if val + (setq-local completion-cycle-threshold t) + (kill-local-variable 'completion-cycle-threshold)))) + (set-default sym val)) + :type 'boolean) + (defvar-local rcirc-nick nil "The nickname used for the current connection.") @@ -547,13 +566,16 @@ 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 :user user-name :port port)) - (fn (plist-get (car auth) :secret))) - (setq password (funcall fn))) + (pwd (auth-info-password (car auth)))) + (setq password pwd)) (when server (let (connected) (dolist (p (rcirc-process-list)) @@ -563,7 +585,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 +668,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 +711,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 +730,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) @@ -754,18 +771,26 @@ SERVER-PLIST is the property list for the server." (yes-or-no-p "Encrypt connection?")) 'tls 'plain)) +(defvar rcirc-reconnect-delay) (defun rcirc-keepalive () "Send keep alive pings to active rcirc processes. Kill processes that have not received a server message since the last ping." (if (rcirc-process-list) (mapc (lambda (process) - (with-rcirc-process-buffer process - (when (not rcirc-connecting) - (rcirc-send-ctcp process - rcirc-nick - (format "KEEPALIVE %f" - (float-time)))))) + (with-rcirc-process-buffer process + (when (not rcirc-connecting) + (condition-case nil + (rcirc-send-ctcp process + rcirc-nick + (format "KEEPALIVE %f" + (float-time))) + (rcirc-closed-connection + (if (zerop rcirc-reconnect-delay) + (message "rcirc: Connection to %s closed" + (process-name process)) + (rcirc-reconnect process)) + (message "")))))) (rcirc-process-list)) ;; no processes, clean up timer (when (timerp rcirc-keepalive-timer) @@ -1057,17 +1082,18 @@ Note that the messages are stored in reverse order.") ;; expression and `rcirc-process-regexp'. (error "Malformed tag %S" tag)) (cons (match-string 1 tag) - (replace-regexp-in-string - (rx (* ?\\ ?\\) ?\\ (any ?: ?s ?\\ ?r ?n)) - (lambda (rep) - (concat (substring rep 0 -2) - (cl-case (aref rep (1- (length rep))) - (?: ";") - (?s " ") - (?\\ "\\\\") - (?r "\r") - (?n "\n")))) - (match-string 2 tag)))) + (when (match-string 2 tag) + (replace-regexp-in-string + (rx (* ?\\ ?\\) ?\\ (any ?: ?s ?\\ ?r ?n)) + (lambda (rep) + (concat (substring rep 0 -2) + (cl-case (aref rep (1- (length rep))) + (?: ";") + (?s " ") + (?\\ "\\\\") + (?r "\r") + (?n "\n")))) + (match-string 2 tag))))) (split-string tag-data ";")))) rcirc-message-tags)) (user (match-string 3 text)) @@ -1119,6 +1145,8 @@ used as the message body." "Check if PROCESS is open or running." (memq (process-status process) '(run open))) +(define-error 'rcirc-closed-connection "Network connection not open") + (defun rcirc-send-string (process &rest parts) "Send PROCESS a PARTS plus a newline. PARTS may contain a `:' symbol, to designate that the next string @@ -1136,8 +1164,7 @@ element in PARTS is a list, append it to PARTS." rcirc-encode-coding-system) "\n"))) (unless (rcirc--connection-open-p process) - (error "Network connection to %s is not open" - (process-name process))) + (signal 'rcirc-closed-connection process)) (rcirc-debug process string) (process-send-string process string))) @@ -1431,7 +1458,8 @@ PROCESS is the process object used for communication. (add-hook 'completion-at-point-functions 'rcirc-completion-at-point nil 'local) - (setq-local completion-cycle-threshold t) + (when rcirc-cycle-completion-flag + (setq-local completion-cycle-threshold t)) (run-mode-hooks 'rcirc-mode-hook)) @@ -2044,6 +2072,13 @@ connection." (run-hook-with-args 'rcirc-print-functions process sender response target text))))) +(defun rcirc-when () + "Show the time of reception of the message at point." + (interactive) + (if-let (time (get-text-property (point) 'rcirc-time)) + (message (format-time-string "%c" time)) + (message "No time information at point."))) + (defun rcirc-generate-log-filename (process target) "Return filename for log file based on PROCESS and TARGET." (if target @@ -2582,15 +2617,22 @@ that, an interactive form can specified." (defun ,fn-name (,argument &optional process target) ,(concat documentation "\n\nNote: If PROCESS or TARGET are nil, the values given" - "\nby `rcirc-buffer-process' and `rcirc-target' will be used.") - (interactive (list ,interactive-spec)) + "\nby `rcirc-buffer-process' and `rcirc-target' will be used.") + (interactive ,(if (stringp interactive-spec) + ;; HACK: Necessary to wrap the result of + ;; the interactive spec in a list. + `(list (call-interactively + (lambda (&rest args) + (interactive ,interactive-spec) + args))) + `(list ,interactive-spec))) (unless (if (listp ,argument) (<= ,required (length ,argument) ,total) (string-match ,regexp ,argument)) (user-error "Malformed input (%s): %S" ',command ,argument)) (push ,(upcase (symbol-name command)) rcirc-pending-requests) (let ((process (or process (rcirc-buffer-process))) - (target (or target rcirc-target))) + (target (or target rcirc-target))) (ignore target process) (let (,@(cl-loop for i from 0 for arg in (delq '&optional arguments) diff --git a/lisp/net/sasl-scram-rfc.el b/lisp/net/sasl-scram-rfc.el index b8d83627963..ee52ed6e071 100644 --- a/lisp/net/sasl-scram-rfc.el +++ b/lisp/net/sasl-scram-rfc.el @@ -90,6 +90,8 @@ (sasl-mechanism-name (sasl-client-mechanism client)) (sasl-client-name client)))) (salt (base64-decode-string salt-base64)) + (string-xor (lambda (a b) + (apply #'unibyte-string (cl-mapcar #'logxor a b)))) (salted-password ;; Hi(str, salt, i): (let ((digest (concat salt (string 0 0 0 1))) @@ -98,7 +100,7 @@ (setq digest (funcall hmac-fun digest password)) (setq xored (if (null xored) digest - (cl-map 'string 'logxor xored digest)))))) + (funcall string-xor xored digest)))))) (client-key (funcall hmac-fun "Client Key" salted-password)) (stored-key (decode-hex-string (funcall hash-fun client-key))) @@ -108,7 +110,7 @@ step-data "," client-final-message-without-proof)) (client-signature (funcall hmac-fun (encode-coding-string auth-message 'utf-8) stored-key)) - (client-proof (cl-map 'string 'logxor client-key client-signature)) + (client-proof (funcall string-xor client-key client-signature)) (client-final-message (concat client-final-message-without-proof "," "p=" (base64-encode-string client-proof)))) diff --git a/lisp/net/sasl.el b/lisp/net/sasl.el index c4ba99f47c8..e0def55ad9f 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/secrets.el b/lisp/net/secrets.el index faadcb94b11..d8341774e47 100644 --- a/lisp/net/secrets.el +++ b/lisp/net/secrets.el @@ -77,15 +77,17 @@ ;; (secrets-delete-collection "my collection") ;; (secrets-create-collection "my collection") -;; There exists a special collection called "session", which has the -;; lifetime of the corresponding client session (aka Emacs's -;; lifetime). It is created automatically when Emacs uses the Secret -;; Service interface, and it is deleted when Emacs is killed. +;; With GNOME Keyring, there exists a special collection called +;; "session", which has the lifetime of the user being logged in. Its +;; data are not stored on disk and go away when the user logs out. ;; Therefore, it can be used to store and retrieve secret items -;; temporarily. This shall be preferred over creation of a persistent -;; collection, when the information shall not live longer than Emacs. -;; The session collection can be addressed either by the string -;; "session", or by nil, whenever a collection parameter is needed. +;; temporarily. The "session" collection can be addressed either by +;; the string "session", or by nil, whenever a collection parameter is +;; needed. + +;; However, other Secret Service provider don't create this temporary +;; "session" collection. You shall check first that this collection +;; exists, before you use it. ;; As already said, a collection is a group of secret items. A secret ;; item has a label, the "secret" (which is a string), and a set of @@ -98,8 +100,7 @@ ;; => ("this item" "another item") ;; Secret items can be added or deleted to a collection. In the -;; following examples, we use the special collection "session", which -;; is bound to Emacs's lifetime. +;; following examples, we use the special collection "session". ;; ;; (secrets-delete-item "session" "my item") ;; (secrets-create-item "session" "my item" "geheim" @@ -137,7 +138,7 @@ ;; It has been tested with GNOME Keyring 2.29.92. An implementation ;; for KWallet will be available at ;; svn://anonsvn.kde.org/home/kde/trunk/playground/base/ksecretservice; -;; not tested yet. +;; not tested yet. This package has also been tested with KeePassXC 2.6.6. ;; Pacify byte-compiler. D-Bus support in the Emacs core can be ;; disabled with configuration option "--without-dbus". Declare used @@ -263,6 +264,7 @@ It returns t if not." ;; </signal> ;; </interface> +;; This exist only for GNOME Keyring. (defconst secrets-session-collection-path "/org/freedesktop/secrets/collection/session" "The D-Bus temporary session collection object path.") @@ -311,43 +313,8 @@ It returns t if not." (defconst secrets-interface-item-type-generic "org.freedesktop.Secret.Generic" "The default item type we are using.") -;; We cannot use introspection, because some servers, like -;; mate-keyring-daemon, don't provide relevant data. Once the dust -;; has settled, we shall assume the new interface, and get rid of the test. -(defconst secrets-struct-secret-content-type - (ignore-errors - (let ((content-type "text/plain") - (path (cadr - (dbus-call-method - :session secrets-service secrets-path - secrets-interface-service - "OpenSession" "plain" '(:variant "")))) - result) - ;; Create a dummy item. - (setq result - (dbus-call-method - :session secrets-service secrets-session-collection-path - secrets-interface-collection "CreateItem" - ;; Properties. - `(:array - (:dict-entry ,(concat secrets-interface-item ".Label") - (:variant " "))) - ;; Secret. - `(:struct :object-path ,path - (:array :signature "y") - ,(dbus-string-to-byte-array " ") - :string ,content-type) - ;; Don't replace. - nil)) - ;; Remove it. - (dbus-call-method - :session secrets-service (car result) - secrets-interface-item "Delete") - ;; Result. - `(,content-type))) - "The content_type of a secret struct. -It must be wrapped as list, because we add it via `append'. This -is an interface introduced in 2011.") +(defconst secrets-struct-secret-content-type "text/plain" + "The content_type of a secret struct.") (defconst secrets-interface-session "org.freedesktop.Secret.Session" "A session tracks state between the service and a client application.") @@ -696,13 +663,10 @@ The object path of the created item is returned." `((:dict-entry ,(concat secrets-interface-item ".Attributes") (:variant ,(append '(:array) props)))))) ;; Secret. - (append - `(:struct :object-path ,secrets-session-path - (:array :signature "y") ;; No parameters. - ,(dbus-string-to-byte-array password)) - ;; We add the content_type. In backward compatibility - ;; mode, nil is appended, which means nothing. - secrets-struct-secret-content-type) + `(:struct :object-path ,secrets-session-path + (:array :signature "y") ;; No parameters. + ,(dbus-string-to-byte-array password) + ,secrets-struct-secret-content-type) ;; Do not replace. Replace does not seem to work. nil)) (secrets-prompt (cadr result)) @@ -943,7 +907,7 @@ to their attributes." secrets-interface-service "CollectionDeleted" 'secrets-collection-handler) - ;; We shall inform, whether the secret service is enabled on this + ;; We shall inform, that the secret service is enabled on this ;; machine. (setq secrets-enabled t)) @@ -954,6 +918,7 @@ to their attributes." ;; * secrets-debug should be structured like auth-source-debug to ;; prevent leaking sensitive information. Right now I don't see ;; anything sensitive though. + ;; * Check, whether the dh-ietf1024-aes128-cbc-pkcs7 algorithm can be ;; used for the transfer of the secrets. Currently, we use the ;; plain algorithm. diff --git a/lisp/net/shr.el b/lisp/net/shr.el index e8b0fbc18c4..505a093392e 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -40,6 +40,8 @@ (require 'image) (require 'puny) (require 'url-cookie) +(require 'url-file) +(require 'pixel-fill) (require 'text-property-search) (defgroup shr nil @@ -56,8 +58,15 @@ fit these criteria." :version "24.1" :type 'float) +(defcustom shr-allowed-images nil + "If non-nil, only images that match this regexp are displayed. +If nil, all URLs are allowed. Also see `shr-blocked-images'." + :version "29.1" + :type '(choice (const nil) regexp)) + (defcustom shr-blocked-images nil - "Images that have URLs matching this regexp will be blocked." + "Images that have URLs matching this regexp will be blocked. +If nil, no images are blocked. Also see `shr-allowed-images'." :version "24.1" :type '(choice (const nil) regexp)) @@ -162,6 +171,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 +196,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." @@ -210,6 +228,10 @@ temporarily blinks with this face." "Face for <h6> elements." :version "28.1") +(defface shr-code '((t :inherit fixed-pitch)) + "Face used for rendering <code> blocks." + :version "29.1") + (defcustom shr-inhibit-images nil "If non-nil, inhibit loading images." :version "28.1" @@ -231,7 +253,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) @@ -246,24 +267,23 @@ 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 shr--link-targets nil) + +(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 +325,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,22 +358,9 @@ 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) + (shr--link-targets nil) ;; `bidi-display-reordering' is supposed to be only used for ;; debugging purposes, but Shr's naïve filling algorithm ;; cannot cope with the complexity of RTL text in an LTR @@ -365,9 +384,22 @@ DOM should be a parse tree as generated by (shr-descend dom) (shr-fill-lines start (point)) (shr--remove-blank-lines-at-the-end start (point)) + (shr--set-target-ids shr--link-targets) (when shr-warning (message "%s" shr-warning)))) +(defun shr--set-target-ids (ids) + ;; If the buffer is empty, there's no point in setting targets. + (unless (zerop (buffer-size)) + ;; We may have several targets in the same place (if you have + ;; several <span id='foo'> things after one another). So group + ;; them by position. + (dolist (group (seq-group-by #'cdr ids)) + (let ((point (min (1- (point-max)) (car group)))) + (put-text-property point (1+ point) + 'shr-target-id + (mapcar #'car (cdr group))))))) + (defun shr--remove-blank-lines-at-the-end (start end) (save-restriction (save-excursion @@ -547,6 +579,12 @@ size, and full-buffer size." (shr-insert sub) (shr-descend sub)))) +(defun shr-image-blocked-p (url) + (or (and shr-blocked-images + (string-match shr-blocked-images url)) + (and shr-allowed-images + (not (string-match shr-allowed-images url))))) + (defun shr-indirect-call (tag-name dom &rest args) (let ((function (intern (concat "shr-tag-" (symbol-name tag-name)) obarray)) ;; Allow other packages to override (or provide) rendering @@ -577,7 +615,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))) @@ -596,16 +634,8 @@ size, and full-buffer size." (funcall function dom)) (t (shr-generic dom))) - (when-let* ((id (dom-attr dom 'id))) - ;; If the element was empty, we don't have anything to put the - ;; anchor on. So just insert a dummy character. - (when (= start (point)) - (if (not (bolp)) - (insert ? ) - (insert ? ) - (shr-mark-fill start)) - (put-text-property (1- (point)) (point) 'display "")) - (put-text-property (1- (point)) (point) 'shr-target-id id)) + (when-let ((id (dom-attr dom 'id))) + (push (cons id (set-marker (make-marker) start)) shr--link-targets)) ;; If style is set, then this node has set the color. (when style (shr-colorize-region @@ -619,43 +649,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 +667,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 +710,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 +738,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 +787,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 +828,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) @@ -941,15 +862,13 @@ size, and full-buffer size." shr-base)) (when (zerop (length url)) (setq url nil)) - ;; Strip leading/trailing whitespace - (and url (string-match "\\`\\s-+" url) - (setq url (substring url (match-end 0)))) - (and url (string-match "\\s-+\\'" url) - (setq url (substring url 0 (match-beginning 0)))) + ;; Strip leading/trailing whitespace. + (when url + (setq url (string-trim url))) (cond ((zerop (length url)) (nth 3 base)) ((or (not base) - (string-match "\\`[a-z]*:" url)) + (string-match-p "\\`[a-z]*:" url)) ;; Absolute or empty URI url) ((eq (aref url 0) ?/) @@ -963,8 +882,10 @@ size, and full-buffer size." ;; A link to an anchor. (concat (nth 3 base) url)) (t - ;; Totally relative. - (url-expand-file-name url (concat (car base) (cadr base)))))) + ;; Totally relative. Allow Tramp file names if we're + ;; rendering a file:// URL. + (let ((url-allow-non-local-files (equal (nth 2 base) "file"))) + (url-expand-file-name url (concat (car base) (cadr base))))))) (defun shr-ensure-newline () (unless (bobp) @@ -986,22 +907,6 @@ size, and full-buffer size." (looking-at " *$"))) ;; We're already at a new paragraph; do nothing. ) - ((and (not (bolp)) - (save-excursion - (beginning-of-line) - (looking-at " *$")) - (save-excursion - (forward-line -1) - (looking-at " *$")) - ;; Check all chars on the current line and see whether - ;; they're all placeholders. - (cl-loop for pos from (line-beginning-position) upto (1- (point)) - unless (get-text-property pos 'shr-target-id) - return nil - finally return t)) - ;; We have some invisible markers from <div id="foo"></div>; - ;; do nothing. - ) ((and prefix (= prefix (- (point) (line-beginning-position)))) ;; Do nothing; we're at the start of a <li>. @@ -1089,8 +994,7 @@ the mouse click event." (let ((url (get-text-property (point) 'shr-url))) (if (not url) (message "No link under point") - (url-retrieve (shr-encode-url url) - #'shr-store-contents (list url directory))))) + (url-retrieve url #'shr-store-contents (list url directory))))) (defun shr-store-contents (status url directory) (unless (plist-get status :error) @@ -1134,14 +1038,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. @@ -1178,13 +1082,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 "")))) @@ -1248,7 +1153,7 @@ Return a string with image data." (with-temp-buffer (set-buffer-multibyte nil) (when (ignore-errors - (url-cache-extract (url-cache-create-filename (shr-encode-url url))) + (url-cache-extract (url-cache-create-filename url)) t) (when (re-search-forward "\r?\n\r?\n" nil t) (shr-parse-image-data))))) @@ -1270,7 +1175,7 @@ Return a string with image data." ;; SVG images may contain references to further images that we may ;; want to block. So special-case these by parsing the XML data ;; and remove anything that looks like a blocked bit. - (when (and shr-blocked-images + (when (and (or shr-allowed-images shr-blocked-images) (eq content-type 'image/svg+xml)) (setq data ;; Note that libxml2 doesn't parse everything perfectly, @@ -1346,6 +1251,7 @@ START, and END. Note that START and END should be markers." (defun shr-encode-url (url) "Encode URL." + (declare (obsolete nil "29.1")) (browse-url-url-encode-chars url "[)$ ]")) (autoload 'shr-color-visible "shr-color") @@ -1420,6 +1326,11 @@ ones, in case fg and bg are nil." (defun shr-tag-comment (_dom) ) +;; Introduced in HTML5. For text browsers, functionally similar to a +;; comment. +(defun shr-tag-template (_dom) + ) + (defun shr-dom-to-xml (dom &optional charset) (with-temp-buffer (shr-dom-print dom) @@ -1449,8 +1360,7 @@ ones, in case fg and bg are nil." ((or (not (eq (dom-tag elem) 'image)) ;; 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 (shr-image-blocked-p url))) (insert " ") (shr-dom-print elem))))) (insert (format "</%s>" (dom-tag dom)))) @@ -1467,12 +1377,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) @@ -1507,7 +1419,7 @@ ones, in case fg and bg are nil." (shr-fontize-dom dom 'underline)) (defun shr-tag-code (dom) - (let ((shr-current-font 'fixed-pitch)) + (let ((shr-current-font 'shr-code)) (shr-generic dom))) (defun shr-tag-tt (dom) @@ -1534,9 +1446,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 @@ -1565,15 +1475,22 @@ ones, in case fg and bg are nil." (start (point)) shr-start) (shr-generic dom) - (when-let* ((id (unless (dom-attr dom 'id) ; Handled by `shr-descend'. - (dom-attr dom 'name)))) ; Obsolete since HTML5. - ;; We have an empty element, so just insert... something. - (when (= start (point)) - (insert ?\s) - (put-text-property (1- (point)) (point) 'display "")) - (put-text-property start (1+ start) 'shr-target-id id)) + (when-let* ((id (and (not (dom-attr dom 'id)) ; Handled by `shr-descend'. + (dom-attr dom 'name)))) ; Obsolete since HTML5. + (push (cons id (set-marker (make-marker) start)) shr--link-targets)) (when url - (shr-urlify (or shr-start start) (shr-expand-url url) title)))) + (shr-urlify (or shr-start start) (shr-expand-url url) title) + ;; Check whether the URL is suspicious. + (when-let ((warning (or (textsec-suspicious-p + (shr-expand-url url) 'url) + (textsec-suspicious-p + (cons (shr-expand-url url) + (buffer-substring (or shr-start start) + (point))) + 'link)))) + (add-text-properties (or shr-start start) (point) + (list 'face '(shr-link textsec-suspicious))) + (insert (propertize "⚠️" 'help-echo warning)))))) (defun shr-tag-abbr (dom) (let ((title (dom-attr dom 'title)) @@ -1594,7 +1511,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)) @@ -1630,6 +1547,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'." @@ -1666,16 +1591,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)) @@ -1725,18 +1673,17 @@ The preference is a float determined from `shr-prefer-media-type'." (funcall shr-put-image-function image alt (list :width width :height height))))) ((or shr-inhibit-images - (and shr-blocked-images - (string-match shr-blocked-images url))) + (shr-image-blocked-p url)) (setq shr-start (point)) (shr-insert alt)) ((and (not shr-ignore-cache) - (url-is-cached (shr-encode-url url))) + (url-is-cached url)) (funcall shr-put-image-function (shr-get-image-data url) alt (list :width width :height height))) (t (when (and shr-ignore-cache - (url-is-cached (shr-encode-url url))) - (let ((file (url-cache-create-filename (shr-encode-url url)))) + (url-is-cached url)) + (let ((file (url-cache-create-filename url))) (when (file-exists-p file) (delete-file file)))) (when (image-type-available-p 'svg) @@ -1745,7 +1692,7 @@ The preference is a float determined from `shr-prefer-media-type'." (or alt ""))) (insert " ") (url-queue-retrieve - (shr-encode-url url) #'shr-image-fetched + url #'shr-image-fetched (list (current-buffer) start (set-marker (make-marker) (point)) (list :width width :height height)) t @@ -2038,7 +1985,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,9 +2480,10 @@ flags that control whether to collect or render objects." (style (dom-attr dom 'style)) (shr-stylesheet shr-stylesheet) (max-width 0) + (shr--link-targets nil) 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)) @@ -2573,6 +2522,7 @@ flags that control whether to collect or render objects." (end-of-line) (point))) (goto-char (point-min)) + (shr--set-target-ids shr--link-targets) (list max-width natural-width (count-lines (point-min) (point-max)) diff --git a/lisp/net/sieve-manage.el b/lisp/net/sieve-manage.el index 468bc90a9d7..50342b9105a 100644 --- a/lisp/net/sieve-manage.el +++ b/lisp/net/sieve-manage.el @@ -79,6 +79,7 @@ (require 'sasl) (autoload 'sasl-find-mechanism "sasl") (autoload 'auth-source-search "auth-source") +(autoload 'auth-info-password "auth-source") ;; User customizable variables: @@ -230,10 +231,7 @@ Return the buffer associated with the connection." :max 1 :create t)) (user-name (or (plist-get (nth 0 auth-info) :user) "")) - (user-password (or (plist-get (nth 0 auth-info) :secret) "")) - (user-password (if (functionp user-password) - (funcall user-password) - user-password)) + (user-password (or (auth-info-password (nth 0 auth-info)) "")) (client (sasl-make-client (sasl-find-mechanism (list mech)) user-name "sieve" sieve-manage-server)) (sasl-read-passphrase diff --git a/lisp/net/soap-client.el b/lisp/net/soap-client.el index 27acc8a4f32..5e7bdbe6c6a 100644 --- a/lisp/net/soap-client.el +++ b/lisp/net/soap-client.el @@ -5,12 +5,11 @@ ;; Author: Alexandru Harsanyi <AlexHarsanyi@gmail.com> ;; Author: Thomas Fitzsimmons <fitzsim@fitzsim.org> ;; Created: December, 2009 -;; Version: 3.2.0 +;; Version: 3.2.1 ;; Keywords: soap, web-services, comm, hypermedia ;; Package: soap-client ;; URL: https://github.com/alex-hhh/emacs-soap-client -;; Package-Requires: ((cl-lib "0.6.1")) -;;FIXME: Put in `Package-Requires:' the Emacs version we expect. +;; Package-Requires: ((emacs "24.1") (cl-lib "0.6.1")) ;; This file is part of GNU Emacs. @@ -659,7 +658,7 @@ representing leap seconds." (if second (if second-fraction (let* ((second-fraction-significand - (string-replace "." "" second-fraction)) + (replace-regexp-in-string "\\." "" second-fraction)) (hertz (expt 10 (length second-fraction-significand))) (ticks (+ (* hertz (string-to-number second)) @@ -718,10 +717,9 @@ representing leap seconds." second) minute hour day month year second-fraction datatype time-zone) (let ((time - (apply - #'encode-time (list - (if new-decode-time new-decode-time-second second) - minute hour day month year nil nil time-zone)))) + (encode-time (list + (if new-decode-time new-decode-time-second second) + minute hour day month year nil nil time-zone)))) (if new-decode-time (with-no-warnings (decode-time time nil t)) (decode-time time)))))) @@ -1938,7 +1936,7 @@ This is a specialization of `soap-decode-type' for (e-name (soap-xs-element-name element)) ;; Heuristic: guess if we need to decode using local ;; namespaces. - (use-fq-names (string-search ":" (symbol-name (car node)))) + (use-fq-names (string-match ":" (symbol-name (car node)))) (children (if e-name (if use-fq-names ;; Find relevant children diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 1fe10a560b1..8268b2d1676 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) @@ -158,6 +159,7 @@ It is used for TCP/IP devices." ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) + (list-system-processes . tramp-handle-list-system-processes) (load . tramp-handle-load) (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) @@ -167,6 +169,7 @@ It is used for TCP/IP devices." (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . tramp-adb-handle-make-process) (make-symbolic-link . tramp-handle-make-symbolic-link) + (process-attributes . tramp-handle-process-attributes) (process-file . tramp-adb-handle-process-file) (rename-file . tramp-adb-handle-rename-file) (set-file-acl . ignore) @@ -178,6 +181,7 @@ It is used for TCP/IP devices." (start-file-process . tramp-handle-start-file-process) (substitute-in-file-name . tramp-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-get-home-directory . ignore) (tramp-get-remote-gid . ignore) (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) @@ -191,11 +195,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 +309,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 @@ -415,6 +418,8 @@ Emacs dired can't find files." (defun tramp-adb-ls-output-time-less-p (a b) "Sort \"ls\" output by time, descending." (let (time-a time-b) + ;; Once we can assume Emacs 27 or later, the two calls + ;; (apply #'encode-time X) can be replaced by (encode-time X). (string-match tramp-adb-ls-date-regexp a) (setq time-a (apply #'encode-time (parse-time-string (match-string 0 a)))) (string-match tramp-adb-ls-date-regexp b) @@ -499,7 +504,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) @@ -543,28 +548,8 @@ Emacs dired can't find files." (defun tramp-adb-handle-write-region (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." - (setq filename (expand-file-name filename) - lockname (file-truename (or lockname filename))) - (with-parsed-tramp-file-name filename nil - (when (and mustbenew (file-exists-p filename) - (or (eq mustbenew 'excl) - (not - (y-or-n-p - (format "File %s exists; overwrite anyway?" filename))))) - (tramp-error v 'file-already-exists filename)) - - (let ((file-locked (eq (file-locked-p lockname) t)) - (curbuf (current-buffer)) - (tmpfile (tramp-compat-make-temp-file filename))) - - ;; Lock file. - (when (and (not (auto-save-file-name-p (file-name-nondirectory filename))) - (file-remote-p lockname) - (not file-locked)) - (setq file-locked t) - ;; `lock-file' exists since Emacs 28.1. - (tramp-compat-funcall 'lock-file lockname)) - + (tramp-skeleton-write-region start end filename append visit lockname mustbenew + (let ((tmpfile (tramp-compat-make-temp-file filename))) (when (and append (file-exists-p filename)) (copy-file filename tmpfile 'ok) (set-file-modes tmpfile (logior (or (file-modes tmpfile) 0) #o0600))) @@ -577,34 +562,7 @@ Emacs dired can't find files." (unless (tramp-adb-execute-adb-command v "push" tmpfile (tramp-compat-file-name-unquote localname)) (tramp-error v 'file-error "Cannot write: `%s'" filename)) - (delete-file tmpfile))) - - ;; We must also flush the cache of the directory, because - ;; `file-attributes' reads the values from there. - (tramp-flush-file-properties v localname) - - (unless (equal curbuf (current-buffer)) - (tramp-error - v 'file-error - "Buffer has changed from `%s' to `%s'" curbuf (current-buffer))) - - ;; 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)) - (current-time)))) - - ;; Unlock file. - (when file-locked - ;; `unlock-file' exists since Emacs 28.1. - (tramp-compat-funcall 'unlock-file lockname)) - - ;; The end. - (when (and (null noninteractive) - (or (eq visit t) (string-or-null-p visit))) - (tramp-message v 0 "Wrote %s" filename)) - (run-hooks 'tramp-handle-write-region-hook)))) + (delete-file tmpfile)))))) (defun tramp-adb-handle-set-file-modes (filename mode &optional flag) "Like `set-file-modes' for Tramp files." @@ -660,7 +618,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 +678,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 +699,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) @@ -776,7 +733,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (defun tramp-adb-get-signal-strings (vec) "Strings to return by `process-file' in case of signals." (with-tramp-connection-property vec "signal-strings" - (let ((default-directory (tramp-make-tramp-file-name vec 'localname)) + (let ((default-directory (tramp-make-tramp-file-name vec 'noloc)) ;; `shell-file-name' and `shell-command-switch' are needed ;; for Emacs < 27.1, which doesn't support connection-local ;; variables in `shell-command'. @@ -972,6 +929,7 @@ implementation will be used." (tramp-make-tramp-temp-file v)))) (remote-tmpstderr (and tmpstderr (tramp-make-tramp-file-name v tmpstderr))) + (orig-command command) (program (car command)) (args (cdr command)) (command @@ -1029,6 +987,9 @@ implementation will be used." (set-process-sentinel p sentinel)) (when filter (set-process-filter p filter)) + (process-put p 'remote-command orig-command) + (tramp-set-connection-property + p "remote-command" orig-command) ;; Set query flag and process marker for ;; this process. We ignore errors, because ;; the process could have finished already. @@ -1353,24 +1314,39 @@ 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) +(defconst tramp-adb-connection-local-default-ps-variables + '((tramp-process-attributes-ps-args) + (tramp-process-attributes-ps-format + . ((user . string) + (pid . number) + (ppid . number) + (vsize . number) + (rss . number) + (wchan . string) ; ?? + (pc . string) ; ?? + (state . string) + (args . nil)))) + "Default connection-local ps variables for remote adb connections.") + +(connection-local-set-profile-variables + 'tramp-adb-connection-local-default-ps-profile + tramp-adb-connection-local-default-ps-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)) + 'tramp-adb-connection-local-default-shell-profile + 'tramp-adb-connection-local-default-ps-profile)) ;; `shell-mode' tries to open remote files like "/adb::~/.history". ;; This fails, because the tilde cannot be expanded. Tell diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index 4b649edaabd..f30aa021b64 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -54,8 +54,10 @@ ;; * ".ar" - UNIX archiver formats ;; * ".cab", ".CAB" - Microsoft Windows cabinets ;; * ".cpio" - CPIO archives +;; * ".crate" - Cargo (Rust) packages ;; * ".deb" - Debian packages ;; * ".depot" - HP-UX SD depots +;; * ".epub" - Electronic publications ;; * ".exe" - Self extracting Microsoft Windows EXE files ;; * ".iso" - ISO 9660 images ;; * ".jar" - Java archives @@ -141,8 +143,10 @@ "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. + "epub" ;; Electronic publications. Not in libarchive testsuite. "exe" ;; Self extracting Microsoft Windows EXE files. "iso" ;; ISO 9660 images. "jar" ;; Java archives. Not in libarchive testsuite. @@ -213,7 +217,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. @@ -264,6 +269,7 @@ It must be supported by libarchive(3).") ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-archive-handle-insert-directory) (insert-file-contents . tramp-archive-handle-insert-file-contents) + (list-system-processes . ignore) (load . tramp-archive-handle-load) (lock-file . ignore) (make-auto-save-file-name . ignore) @@ -273,6 +279,7 @@ It must be supported by libarchive(3).") (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-archive-handle-not-implemented) + (process-attributes . ignore) (process-file . ignore) (rename-file . tramp-archive-handle-not-implemented) (set-file-acl . ignore) @@ -284,6 +291,7 @@ It must be supported by libarchive(3).") (start-file-process . tramp-archive-handle-not-implemented) ;; `substitute-in-file-name' performed by default handler. (temporary-file-directory . tramp-archive-handle-temporary-file-directory) + (tramp-get-home-directory . ignore) (tramp-get-remote-gid . ignore) (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) @@ -461,7 +469,7 @@ name is kept in slot `hop'" ((tramp-archive-file-name-p archive) (let ((archive (tramp-make-tramp-file-name - (tramp-archive-dissect-file-name archive) nil 'noarchive))) + (tramp-archive-dissect-file-name archive)))) (setf (tramp-file-name-host vec) (tramp-archive-gvfs-host archive))) (puthash archive (list vec) tramp-archive-hash)) @@ -564,8 +572,7 @@ offered." (defun tramp-archive-gvfs-file-name (name) "Return NAME in GVFS syntax." - (tramp-make-tramp-file-name - (tramp-archive-dissect-file-name name) nil 'nohop)) + (tramp-make-tramp-file-name (tramp-archive-dissect-file-name name))) ;; File name primitives. @@ -579,9 +586,8 @@ offered." preserve-uid-gid preserve-extended-attributes) "Like `copy-file' for file archives." (when (tramp-archive-file-name-p newname) - (tramp-error - (tramp-archive-dissect-file-name newname) 'file-error - "Permission denied: %s" newname)) + (tramp-compat-permission-denied + (tramp-archive-dissect-file-name newname) newname)) (copy-file (tramp-archive-gvfs-file-name filename) newname ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes)) @@ -625,7 +631,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." @@ -665,7 +671,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 347da916edf..dc1e3d28b58 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -99,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) @@ -125,7 +124,7 @@ If KEY is `tramp-cache-undefined', don't create anything, and return nil." (dolist (elt tramp-connection-properties) (when (string-match-p (or (nth 0 elt) "") - (tramp-make-tramp-file-name key 'noloc 'nohop)) + (tramp-make-tramp-file-name key 'noloc)) (tramp-set-connection-property key (nth 1 elt) (nth 2 elt))))) hash)))) @@ -223,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 8e359c382bf..006683bdcc8 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -69,7 +69,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 @@ -595,9 +595,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 aead1dedd24..bd6d53afcb8 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,7 @@ (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-file-name-handler "tramp") (declare-function tramp-tramp-file-p "tramp") (defvar tramp-temp-name-prefix) @@ -83,133 +77,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 +97,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)))) @@ -257,8 +134,8 @@ NAME is unquoted." #'exec-path (lambda () "List of directories to search programs to run in remote subprocesses." - (if-let ((handler (find-file-name-handler default-directory 'exec-path))) - (funcall handler 'exec-path) + (if (tramp-tramp-file-p default-directory) + (tramp-file-name-handler 'exec-path) exec-path)))) ;; `time-equal-p' has appeared in Emacs 27.1. @@ -288,8 +165,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 +182,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 +202,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)))) @@ -398,6 +273,27 @@ CONDITION can also be a list of error conditions." (car components)) (cdr components))))))) +;; `permission-denied' is introduced in Emacs 29.1. +(defconst tramp-permission-denied + (if (get 'permission-denied 'error-conditions) 'permission-denied 'file-error) + "The error symbol for the `permission-denied' error.") + +(defsubst tramp-compat-permission-denied (vec file) + "Emit the `permission-denied' error." + (if (get 'permission-denied 'error-conditions) + (tramp-error vec tramp-permission-denied file) + (tramp-error vec tramp-permission-denied "Permission denied: %s" file))) + +;; Function `auth-info-password' is new in Emacs 29.1. +(defalias 'tramp-compat-auth-info-password + (if (fboundp 'auth-info-password) + #'auth-info-password + (lambda (auth-info) + (let ((secret (plist-get auth-info :secret))) + (while (functionp secret) + (setq secret (funcall secret))) + secret)))) + (dolist (elt (all-completions "tramp-compat-" obarray 'functionp)) (put (intern elt) 'tramp-suppress-trace t)) @@ -410,8 +306,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 5028e489328..ca7bcf35ce4 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) @@ -208,6 +209,7 @@ If NAME doesn't belong to a crypted remote directory, retun nil." ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-crypt-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) + (list-system-processes . ignore) (load . tramp-handle-load) (lock-file . tramp-crypt-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) @@ -217,6 +219,7 @@ If NAME doesn't belong to a crypted remote directory, retun nil." (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-handle-make-symbolic-link) + (process-attributes . ignore) (process-file . ignore) (rename-file . tramp-crypt-handle-rename-file) (set-file-acl . ignore) @@ -228,6 +231,7 @@ If NAME doesn't belong to a crypted remote directory, retun nil." (start-file-process . ignore) ;; `substitute-in-file-name' performed by default handler. (temporary-file-directory . tramp-handle-temporary-file-directory) + ;; `tramp-get-home-directory' performed by default-handler. ;; `tramp-get-remote-gid' performed by default handler. ;; `tramp-get-remote-uid' performed by default handler. (tramp-set-file-uid-gid . tramp-crypt-handle-set-file-uid-gid) @@ -294,8 +298,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. @@ -322,7 +326,7 @@ connection if a previous connection has died for some reason." tramp-crypt-encfs-config (tramp-crypt-get-remote-dir vec))) (local-config (tramp-crypt-config-file-name vec))) ;; There is no local encfs6 config file. - (when (not (file-exists-p local-config)) + (unless (file-exists-p local-config) (if (and tramp-crypt-save-encfs-config-remote (file-exists-p remote-config)) ;; Copy remote encfs6 config file if possible. @@ -485,6 +489,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 +601,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 +703,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 650e839f823..ff8caa570ca 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 7344c3c730a..20be74a79b7 100644 --- a/lisp/net/tramp-fuse.el +++ b/lisp/net/tramp-fuse.el @@ -59,7 +59,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 @@ -120,12 +120,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 3a5041c4918..fca3988b8d8 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) @@ -800,6 +796,7 @@ It has been changed in GVFS 1.14.") ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) + (list-system-processes . ignore) (load . tramp-handle-load) (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) @@ -809,6 +806,7 @@ It has been changed in GVFS 1.14.") (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-handle-make-symbolic-link) + (process-attributes . ignore) (process-file . ignore) (rename-file . tramp-gvfs-handle-rename-file) (set-file-acl . ignore) @@ -820,6 +818,7 @@ It has been changed in GVFS 1.14.") (start-file-process . ignore) (substitute-in-file-name . tramp-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-get-home-directory . tramp-gvfs-handle-get-home-directory) (tramp-get-remote-gid . tramp-gvfs-handle-get-remote-gid) (tramp-get-remote-uid . tramp-gvfs-handle-get-remote-uid) (tramp-set-file-uid-gid . tramp-gvfs-handle-set-file-uid-gid) @@ -834,12 +833,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) @@ -921,8 +919,6 @@ or `dbus-call-method-asynchronously'." ;; when loading. (dbus-ignore-errors (tramp-dbus-function ,vec func args)))) -(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-dbus-call-method\\>")) - (defmacro with-tramp-dbus-get-all-properties (vec bus service path interface) "Return all properties of INTERFACE. @@ -937,8 +933,6 @@ The call will be traced by Tramp with trace level 6." (tramp-dbus-function ,vec #'dbus-get-all-properties (list ,bus ,service ,path ,interface)))) -(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-dbus-get-all-properties\\>")) - (defvar tramp-gvfs-dbus-event-vector nil "Current Tramp file name to be used, as vector. It is needed when D-Bus signals or errors arrive, because there @@ -1002,7 +996,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 +1096,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 @@ -1149,16 +1142,14 @@ file names." ;; Dissect NAME. (with-parsed-tramp-file-name name nil ;; If there is a default location, expand tilde. - (when (string-match "\\`\\(~\\)\\(/\\|\\'\\)" localname) - (save-match-data - (tramp-gvfs-maybe-open-connection - (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))) + (when (string-match "\\`~\\([^/]*\\)\\(.*\\)\\'" localname) + (let ((uname (match-string 1 localname)) + (fname (match-string 2 localname)) + hname) + (when (zerop (length uname)) + (setq uname user)) + (when (setq hname (tramp-get-home-directory v uname)) + (setq localname (concat hname fname))))) ;; Tilde expansion is not possible. (when (and (not tramp-tolerate-tilde) (string-match-p "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname)) @@ -1177,8 +1168,8 @@ 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 (if (string-match-p "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) localname @@ -1465,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)) @@ -1530,11 +1521,13 @@ 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)) + ;; "mtp" connections do not return "filesystem::used". + (or (and size used + (- (string-to-number size) (string-to-number used))) + (and free (string-to-number free)))))))) (defun tramp-gvfs-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." @@ -1604,9 +1597,30 @@ 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-home-directory (vec &optional _user) + "The remote home directory for connection VEC as local file name. +If USER is a string, return its home directory instead of the +user identified by VEC. If there is no user specified in either +VEC or USER, or if there is no home directory, return nil." + (let ((localname + (tramp-get-connection-property vec "default-location" nil)) + result) + (cond + ((zerop (length localname)) + (tramp-get-connection-property (tramp-get-process vec) "share" nil)) + ;; Google-drive. + ((not (string-prefix-p "/" localname)) + (dolist (item + (tramp-gvfs-get-directory-attributes + (tramp-make-tramp-file-name vec "/")) + result) + (when (string-equal (cdr (assoc "name" item)) localname) + (setq result (concat "/" (car item)))))) + (t localname)))) + (defun tramp-gvfs-handle-get-remote-uid (vec id-format) "The uid of the remote connection VEC, in ID-FORMAT. ID-FORMAT valid values are `string' and `integer'." @@ -1615,7 +1629,7 @@ ID-FORMAT valid values are `string' and `integer'." (when-let ((localname (tramp-get-connection-property (tramp-get-process vec) "share" nil))) - (tramp-compat-file-attribute-user-id + (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) @@ -1624,7 +1638,7 @@ ID-FORMAT valid values are `string' and `integer'." (when-let ((localname (tramp-get-connection-property (tramp-get-process vec) "share" nil))) - (tramp-compat-file-attribute-group-id + (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) @@ -1867,9 +1881,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)) diff --git a/lisp/net/tramp-integration.el b/lisp/net/tramp-integration.el index b5df9804ab4..5e51074c494 100644 --- a/lisp/net/tramp-integration.el +++ b/lisp/net/tramp-integration.el @@ -39,6 +39,7 @@ (declare-function info-lookup->topic-value "info-look") (declare-function info-lookup-maybe-add-help "info-look") (declare-function recentf-cleanup "recentf") +(declare-function shortdoc-add-function "shortdoc") (declare-function tramp-dissect-file-name "tramp") (declare-function tramp-file-name-equal-p "tramp") (declare-function tramp-tramp-file-p "tramp") @@ -49,6 +50,7 @@ (defvar info-lookup-alist) (defvar ivy-completing-read-handlers-alist) (defvar recentf-exclude) +(defvar shortdoc--groups) (defvar tramp-current-connection) (defvar tramp-postfix-host-format) (defvar tramp-use-ssh-controlmaster-options) @@ -85,13 +87,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 @@ -264,6 +259,33 @@ NAME must be equal to `tramp-current-connection'." (delete (info-lookup->mode-cache 'symbol ',mode) (info-lookup->topic-cache 'symbol)))))))) +;;; Integration of shortdoc.el: + +(with-eval-after-load 'shortdoc + (dolist (elem '((file-remote-p + :eval (file-remote-p "/ssh:user@host:/tmp/foo") + :eval (file-remote-p "/ssh:user@host:/tmp/foo" 'method)) + (file-local-name + :eval (file-local-name "/ssh:user@host:/tmp/foo")) + (file-local-copy + :no-eval (file-local-copy "/ssh:user@host:/tmp/foo") + :eg-result "/tmp/tramp.8ihLbO" + :eval (file-local-copy "/tmp/foo")))) + (unless (assoc (car elem) + (member "Remote Files" (assq 'file shortdoc--groups))) + (shortdoc-add-function 'file "Remote Files" elem))) + + (add-hook + 'tramp-integration-unload-hook + (lambda () + (let ((glist (assq 'file shortdoc--groups))) + (while (and (consp glist) + (not (and (stringp (cadr glist)) + (string-equal (cadr glist) "Remote Files")))) + (setq glist (cdr glist))) + (when (consp glist) + (setcdr glist nil)))))) + ;;; Integration of compile.el: ;; Compilation processes use `accept-process-output' such a way that @@ -278,25 +300,21 @@ NAME must be equal to `tramp-current-connection'." #'tramp-compile-disable-ssh-controlmaster-options) (add-hook 'tramp-integration-unload-hook (lambda () - (remove-hook 'compilation-start-hook + (remove-hook 'compilation-mode-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,17 +323,229 @@ 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)) +;; Tested with FreeBSD 12.2. +(defconst tramp-bsd-process-attributes-ps-args + `("-acxww" + "-o" + ,(mapconcat + #'identity + '("pid" + "euid" + "user" + "egid" + "egroup" + "comm=abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ") + ",") + "-o" + ,(mapconcat + #'identity + '("state" + "ppid" + "pgid" + "sid" + "tty" + "tpgid" + "minflt" + "majflt" + "time" + "pri" + "nice" + "vsz" + "rss" + "etimes" + "pcpu" + "pmem" + "args") + ",")) + "List of arguments for \"ps\". +See `tramp-process-attributes-ps-args'.") + +(defconst tramp-bsd-process-attributes-ps-format + '((pid . number) + (euid . number) + (user . string) + (egid . number) + (group . string) + (comm . 52) + (state . string) + (ppid . number) + (pgrp . number) + (sess . number) + (ttname . string) + (tpgid . number) + (minflt . number) + (majflt . number) + (time . tramp-ps-time) + (pri . number) + (nice . number) + (vsize . number) + (rss . number) + (etime . number) + (pcpu . number) + (pmem . number) + (args . nil)) + "Alist of formats for \"ps\". +See `tramp-process-attributes-ps-format'.") + +(defconst tramp-connection-local-bsd-ps-variables + `((tramp-process-attributes-ps-args + . ,tramp-bsd-process-attributes-ps-args) + (tramp-process-attributes-ps-format + . ,tramp-bsd-process-attributes-ps-format)) + "Default connection-local ps variables for remote BSD connections.") + +(connection-local-set-profile-variables + 'tramp-connection-local-bsd-ps-profile + tramp-connection-local-bsd-ps-variables) + +;; Tested with BusyBox v1.24.1. +(defconst tramp-busybox-process-attributes-ps-args + `("-o" + ,(mapconcat + #'identity + '("pid" + "user" + "group" + "comm=abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ") + ",") + "-o" "stat=abcde" + "-o" + ,(mapconcat + #'identity + '("ppid" + "pgid" + "tty" + "time" + "nice" + "etime" + "args") + ",")) + "List of arguments for \"ps\". +See `tramp-process-attributes-ps-args'.") + +(defconst tramp-busybox-process-attributes-ps-format + '((pid . number) + (user . string) + (group . string) + (comm . 52) + (state . 5) + (ppid . number) + (pgrp . number) + (ttname . string) + (time . tramp-ps-time) + (nice . number) + (etime . tramp-ps-time) + (args . nil)) + "Alist of formats for \"ps\". +See `tramp-process-attributes-ps-format'.") + +(defconst tramp-connection-local-busybox-ps-variables + `((tramp-process-attributes-ps-args + . ,tramp-busybox-process-attributes-ps-args) + (tramp-process-attributes-ps-format + . ,tramp-busybox-process-attributes-ps-format)) + "Default connection-local ps variables for remote Busybox connections.") + +(connection-local-set-profile-variables + 'tramp-connection-local-busybox-ps-profile + tramp-connection-local-busybox-ps-variables) + +;; Darwin (macOS). +(defconst tramp-darwin-process-attributes-ps-args + `("-acxww" + "-o" + ,(mapconcat + #'identity + '("pid" + "uid" + "user" + "gid" + "comm=abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ") + ",") + "-o" "state=abcde" + "-o" + ,(mapconcat + #'identity + '("ppid" + "pgid" + "sess" + "tty" + "tpgid" + "minflt" + "majflt" + "time" + "pri" + "nice" + "vsz" + "rss" + "etime" + "pcpu" + "pmem" + "args") + ",")) + "List of arguments for \"ps\". +See `tramp-process-attributes-ps-args'.") + +(defconst tramp-darwin-process-attributes-ps-format + '((pid . number) + (euid . number) + (user . string) + (egid . number) + (comm . 52) + (state . 5) + (ppid . number) + (pgrp . number) + (sess . number) + (ttname . string) + (tpgid . number) + (minflt . number) + (majflt . number) + (time . tramp-ps-time) + (pri . number) + (nice . number) + (vsize . number) + (rss . number) + (etime . tramp-ps-time) + (pcpu . number) + (pmem . number) + (args . nil)) + "Alist of formats for \"ps\". +See `tramp-process-attributes-ps-format'.") + +(defconst tramp-connection-local-darwin-ps-variables + `((tramp-process-attributes-ps-args + . ,tramp-darwin-process-attributes-ps-args) + (tramp-process-attributes-ps-format + . ,tramp-darwin-process-attributes-ps-format)) + "Default connection-local ps variables for remote Darwin connections.") + +(connection-local-set-profile-variables + 'tramp-connection-local-darwin-ps-profile + tramp-connection-local-darwin-ps-variables) + +;; Preset default "ps" profile for local hosts, based on system type. + +(when-let ((local-profile + (cond ((eq system-type 'darwin) + 'tramp-connection-local-darwin-ps-profile) + ;; ... Add other system types here. + ))) + (connection-local-set-profiles + `(:application tramp :machine ,(system-name)) + local-profile) + (connection-local-set-profiles + '(:application tramp :machine "localhost") + local-profile)) + (add-hook 'tramp-unload-hook (lambda () (unload-feature 'tramp-integration 'force))) diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index 318df2de615..bbc76851318 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 . tramp-handle-file-notify-rm-watch) (file-notify-valid-p . tramp-handle-file-notify-valid-p) (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) @@ -122,6 +123,7 @@ ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) + (list-system-processes . ignore) (load . tramp-handle-load) (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) @@ -131,6 +133,7 @@ (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-handle-make-symbolic-link) + (process-attributes . ignore) (process-file . ignore) (rename-file . tramp-rclone-handle-rename-file) (set-file-acl . ignore) @@ -142,6 +145,7 @@ (start-file-process . ignore) (substitute-in-file-name . tramp-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-get-home-directory . ignore) (tramp-get-remote-gid . ignore) (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) @@ -156,11 +160,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 +226,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 +283,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 diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index b0e98a31e11..8f8b81186b3 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -34,8 +34,11 @@ (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) +;; Added in Emacs 28.1. (defvar process-file-return-signal-string) (defvar vc-handled-backends) (defvar vc-bzr-program) @@ -143,6 +146,12 @@ be auto-detected by Tramp. The string is used in `tramp-methods'.") +(defcustom tramp-use-scp-direct-remote-copying nil + "Whether to use direct copying between two remote hosts." + :group 'tramp + :version "29.1" + :type 'boolean) + ;; Initialize `tramp-methods' with the supported methods. ;;;###tramp-autoload (tramp--with-startup @@ -179,7 +188,8 @@ The string is used in `tramp-methods'.") (tramp-remote-shell-args ("-c")) (tramp-copy-program "scp") (tramp-copy-args (("-P" "%p") ("-p" "%k") - ("%x") ("%y") ("-q") ("-r") ("%c"))) + ("%x") ("%y") ("%z") + ("-q") ("-r") ("%c"))) (tramp-copy-keep-date t) (tramp-copy-recursive t))) (add-to-list 'tramp-methods @@ -195,7 +205,8 @@ The string is used in `tramp-methods'.") (tramp-remote-shell-args ("-c")) (tramp-copy-program "scp") (tramp-copy-args (("-P" "%p") ("-p" "%k") - ("%x") ("%y") ("-q") ("-r") ("%c"))) + ("%x") ("%y") ("%z") + ("-q") ("-r") ("%c"))) (tramp-copy-keep-date t) (tramp-copy-recursive t))) (add-to-list 'tramp-methods @@ -301,7 +312,8 @@ The string is used in `tramp-methods'.") (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-c")) (tramp-connection-timeout 10) - (tramp-session-timeout 300))) + (tramp-session-timeout 300) + (tramp-password-previous-hop t))) (add-to-list 'tramp-methods `("doas" (tramp-login-program "doas") @@ -309,7 +321,8 @@ The string is used in `tramp-methods'.") (tramp-remote-shell ,tramp-default-remote-shell) (tramp-remote-shell-args ("-c")) (tramp-connection-timeout 10) - (tramp-session-timeout 300))) + (tramp-session-timeout 300) + (tramp-password-previous-hop t))) (add-to-list 'tramp-methods `("ksu" (tramp-login-program "ksu") @@ -949,7 +962,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) @@ -961,6 +975,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) @@ -1000,6 +1016,7 @@ Format specifiers \"%s\" are replaced before the script is used.") ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-sh-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) + (list-system-processes . tramp-handle-list-system-processes) (load . tramp-handle-load) (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) @@ -1009,6 +1026,7 @@ Format specifiers \"%s\" are replaced before the script is used.") (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . tramp-sh-handle-make-process) (make-symbolic-link . tramp-sh-handle-make-symbolic-link) + (process-attributes . tramp-handle-process-attributes) (process-file . tramp-sh-handle-process-file) (rename-file . tramp-sh-handle-rename-file) (set-file-acl . tramp-sh-handle-set-file-acl) @@ -1020,6 +1038,7 @@ Format specifiers \"%s\" are replaced before the script is used.") (start-file-process . tramp-handle-start-file-process) (substitute-in-file-name . tramp-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-get-home-directory . tramp-sh-handle-get-home-directory) (tramp-get-remote-gid . tramp-sh-handle-get-remote-gid) (tramp-get-remote-uid . tramp-sh-handle-get-remote-uid) (tramp-set-file-uid-gid . tramp-sh-handle-set-file-uid-gid) @@ -1153,8 +1172,7 @@ component is used as the target of the symlink." (when (file-remote-p result) (setq result (tramp-compat-file-name-quote result 'top))) (tramp-message v 4 "True name of `%s' is `%s'" localname result) - result)) - 'nohop))))) + result))))))) ;; Basic functions. @@ -1349,7 +1367,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)) @@ -1387,7 +1405,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 @@ -1439,7 +1457,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 @@ -1451,6 +1469,20 @@ of." (if (eq flag 'nofollow) "-h" "") (tramp-shell-quote-argument localname))))))) +(defun tramp-sh-handle-get-home-directory (vec &optional user) + "The remote home directory for connection VEC as local file name. +If USER is a string, return its home directory instead of the +user identified by VEC. If there is no user specified in either +VEC or USER, or if there is no home directory, return nil." + (when (tramp-send-command-and-check + vec (format + "echo %s" + (tramp-shell-quote-argument + (concat "~" (or user (tramp-file-name-user vec)))))) + (with-current-buffer (tramp-get-buffer vec) + (goto-char (point-min)) + (buffer-substring (point) (point-at-eol))))) + (defun tramp-sh-handle-get-remote-uid (vec id-format) "The uid of the remote connection VEC, in ID-FORMAT. ID-FORMAT valid values are `string' and `integer'." @@ -1636,14 +1668,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. @@ -1653,8 +1685,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 @@ -1874,7 +1905,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) @@ -1968,7 +1999,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))) @@ -1976,7 +2007,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) @@ -2068,7 +2099,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 @@ -2090,8 +2121,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)) @@ -2110,7 +2140,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 @@ -2254,202 +2284,211 @@ the uid and gid from FILENAME." (op filename newname ok-if-already-exists keep-date) "Invoke `scp' program to copy. The method used must be an out-of-band method." - (let* ((t1 (tramp-tramp-file-p filename)) - (t2 (tramp-tramp-file-p newname)) - (orig-vec (tramp-dissect-file-name (if t1 filename newname))) + (let* ((v1 (and (tramp-tramp-file-p filename) + (tramp-dissect-file-name filename))) + (v2 (and (tramp-tramp-file-p newname) + (tramp-dissect-file-name newname))) + (v (or v1 v2)) copy-program copy-args copy-env copy-keep-date listener spec options source target remote-copy-program remote-copy-args p) - (with-parsed-tramp-file-name (if t1 filename newname) nil - (if (and t1 t2) - - ;; Both are Tramp files. We shall optimize it when the - ;; methods for FILENAME and NEWNAME are the same. - (let* ((dir-flag (file-directory-p filename)) - (tmpfile (tramp-compat-make-temp-file localname dir-flag))) - (if dir-flag - (setq tmpfile - (expand-file-name - (file-name-nondirectory newname) tmpfile))) - (unwind-protect - (progn - (tramp-do-copy-or-rename-file-out-of-band - op filename tmpfile ok-if-already-exists keep-date) - (tramp-do-copy-or-rename-file-out-of-band - 'rename tmpfile newname ok-if-already-exists keep-date)) - ;; Save exit. - (ignore-errors - (if dir-flag - (delete-directory - (expand-file-name ".." tmpfile) 'recursive) - (delete-file tmpfile))))) - - ;; Check which ones of source and target are Tramp files. - (setq source (funcall - (if (and (string-equal method "rsync") - (file-directory-p filename) - (not (file-exists-p newname))) - #'file-name-as-directory - #'identity) - (if t1 - (tramp-make-copy-program-file-name v) - (tramp-compat-file-name-unquote filename))) - target (if t2 - (tramp-make-copy-program-file-name v) - (tramp-compat-file-name-unquote newname))) - - ;; Check for user. There might be an interactive setting. - (setq user (or (tramp-file-name-user v) - (tramp-get-connection-property v "login-as" nil))) - - ;; Check for listener port. - (when (tramp-get-method-parameter v 'tramp-remote-copy-args) - (setq listener (number-to-string (+ 50000 (random 10000)))) - (while - (zerop (tramp-call-process v "nc" nil nil nil "-z" host listener)) - (setq listener (number-to-string (+ 50000 (random 10000)))))) - - ;; Compose copy command. - (setq options - (format-spec - (tramp-ssh-controlmaster-options v) - (format-spec-make - ?t (tramp-get-connection-property - (tramp-get-connection-process v) "temp-file" ""))) - spec (list - ?h (or host "") ?u (or user "") ?p (or port "") - ?r listener ?c options ?k (if keep-date " " "") - ?n (concat "2>" (tramp-get-remote-null-device v)) - ?x (tramp-scp-strict-file-name-checking v) - ?y (tramp-scp-force-scp-protocol v)) - copy-program (tramp-get-method-parameter v 'tramp-copy-program) - copy-keep-date (tramp-get-method-parameter - v 'tramp-copy-keep-date) - copy-args - ;; " " has either been a replacement of "%k" (when - ;; keep-date argument is non-nil), or a replacement for - ;; the whole keep-date sublist. - (delete " " (apply #'tramp-expand-args v 'tramp-copy-args spec)) - ;; `tramp-ssh-controlmaster-options' is a string instead - ;; of a list. Unflatten it. - copy-args - (tramp-compat-flatten-tree - (mapcar - (lambda (x) (if (tramp-compat-string-search " " x) - (split-string x) x)) - copy-args)) - copy-env (apply #'tramp-expand-args v 'tramp-copy-env spec) - remote-copy-program - (tramp-get-method-parameter v 'tramp-remote-copy-program) - remote-copy-args - (apply #'tramp-expand-args v 'tramp-remote-copy-args spec)) - - ;; Check for local copy program. - (unless (executable-find copy-program) - (tramp-error - v 'file-error "Cannot find local copy program: %s" copy-program)) - - ;; Install listener on the remote side. The prompt must be - ;; consumed later on, when the process does not listen anymore. - (when remote-copy-program - (unless (with-tramp-connection-property - v (concat "remote-copy-program-" remote-copy-program) - (tramp-find-executable - v remote-copy-program (tramp-get-remote-path v))) - (tramp-error - v 'file-error - "Cannot find remote listener: %s" remote-copy-program)) - (setq remote-copy-program - (mapconcat - #'identity - (append - (list remote-copy-program) remote-copy-args - (list (if t1 (concat "<" source) (concat ">" target)) "&")) - " ")) - (tramp-send-command v remote-copy-program) - (with-timeout - (60 (tramp-error - v 'file-error - "Listener process not running on remote host: `%s'" - remote-copy-program)) - (tramp-send-command v (format "netstat -l | grep -q :%s" listener)) - (while (not (tramp-send-command-and-check v nil)) - (tramp-send-command - v (format "netstat -l | grep -q :%s" listener))))) + (if (and v1 v2 (zerop (length (tramp-scp-direct-remote-copying v1 v2)))) - (with-temp-buffer + ;; Both are Tramp files. We cannot use direct remote copying. + (let* ((dir-flag (file-directory-p filename)) + (tmpfile (tramp-compat-make-temp-file + (tramp-file-name-localname v1) dir-flag))) + (if dir-flag + (setq tmpfile + (expand-file-name + (file-name-nondirectory newname) tmpfile))) (unwind-protect - ;; The default directory must be remote. - (let ((default-directory - (file-name-directory (if t1 filename newname))) - (process-environment (copy-sequence process-environment))) - ;; Set the transfer process properties. - (tramp-set-connection-property - v "process-name" (buffer-name (current-buffer))) - (tramp-set-connection-property - v "process-buffer" (current-buffer)) - (when copy-env - (tramp-message - orig-vec 6 "%s=\"%s\"" - (car copy-env) (string-join (cdr copy-env) " ")) - (setenv (car copy-env) (string-join (cdr copy-env) " "))) - (setq - copy-args - (append - copy-args - (if remote-copy-program - (list (if t1 (concat ">" target) (concat "<" source))) - (list source target))) - ;; Use an asynchronous process. By this, password - ;; can be handled. We don't set a timeout, because - ;; the copying of large files can last longer than 60 - ;; secs. - p (let ((default-directory tramp-compat-temporary-file-directory)) - (apply - #'start-process - (tramp-get-connection-name v) - (tramp-get-connection-buffer v) - copy-program copy-args))) - (tramp-message orig-vec 6 "%s" (string-join (process-command p) " ")) - (process-put p 'vector orig-vec) - (process-put p 'adjust-window-size-function #'ignore) - (set-process-query-on-exit-flag p nil) + (progn + (tramp-do-copy-or-rename-file-out-of-band + op filename tmpfile ok-if-already-exists keep-date) + (tramp-do-copy-or-rename-file-out-of-band + 'rename tmpfile newname ok-if-already-exists keep-date)) + ;; Save exit. + (ignore-errors + (if dir-flag + (delete-directory + (expand-file-name ".." tmpfile) 'recursive) + (delete-file tmpfile))))) + + ;; Check which ones of source and target are Tramp files. + (setq source (funcall + (if (and (string-equal (tramp-file-name-method v) "rsync") + (file-directory-p filename) + (not (file-exists-p newname))) + #'file-name-as-directory + #'identity) + (if v1 + (tramp-make-copy-program-file-name v1) + (tramp-compat-file-name-unquote filename))) + target (if v2 + (tramp-make-copy-program-file-name v2) + (tramp-compat-file-name-unquote newname))) + + ;; Check for listener port. + (when (tramp-get-method-parameter v 'tramp-remote-copy-args) + (setq listener (number-to-string (+ 50000 (random 10000)))) + (while + (zerop (tramp-call-process + v "nc" nil nil nil "-z" (tramp-file-name-host v) listener)) + (setq listener (number-to-string (+ 50000 (random 10000)))))) + + ;; Compose copy command. + (setq options + (format-spec + (tramp-ssh-controlmaster-options v) + (format-spec-make + ?t (tramp-get-connection-property + (tramp-get-connection-process v) "temp-file" ""))) + spec (list + ;; "%h" and "%u" do not happen in `tramp-copy-args' + ;; of `scp', so it is save to use `v'. + ?h (or (tramp-file-name-host v) "") + ?u (or (tramp-file-name-user v) + ;; There might be an interactive setting. + (tramp-get-connection-property v "login-as" nil) + "") + ;; For direct remote copying, the port must be the + ;; same for source and target. + ?p (or (tramp-file-name-port v) "") + ?r listener ?c options ?k (if keep-date " " "") + ?n (concat "2>" (tramp-get-remote-null-device v)) + ?x (tramp-scp-strict-file-name-checking v) + ?y (tramp-scp-force-scp-protocol v) + ?z (tramp-scp-direct-remote-copying v1 v2)) + copy-program (tramp-get-method-parameter v 'tramp-copy-program) + copy-keep-date (tramp-get-method-parameter + v 'tramp-copy-keep-date) + copy-args + ;; " " has either been a replacement of "%k" (when + ;; keep-date argument is non-nil), or a replacement for + ;; the whole keep-date sublist. + (delete " " (apply #'tramp-expand-args v 'tramp-copy-args spec)) + ;; `tramp-ssh-controlmaster-options' is a string instead + ;; of a list. Unflatten it. + copy-args + (tramp-compat-flatten-tree + (mapcar + (lambda (x) (if (tramp-compat-string-search " " x) + (split-string x) x)) + copy-args)) + copy-env (apply #'tramp-expand-args v 'tramp-copy-env spec) + remote-copy-program + (tramp-get-method-parameter v 'tramp-remote-copy-program) + remote-copy-args + (apply #'tramp-expand-args v 'tramp-remote-copy-args spec)) + + ;; Check for local copy program. + (unless (executable-find copy-program) + (tramp-error + v 'file-error "Cannot find local copy program: %s" copy-program)) + + ;; Install listener on the remote side. The prompt must be + ;; consumed later on, when the process does not listen anymore. + (when remote-copy-program + (unless (with-tramp-connection-property + v (concat "remote-copy-program-" remote-copy-program) + (tramp-find-executable + v remote-copy-program (tramp-get-remote-path v))) + (tramp-error + v 'file-error + "Cannot find remote listener: %s" remote-copy-program)) + (setq remote-copy-program + (mapconcat + #'identity + (append + (list remote-copy-program) remote-copy-args + (list (if v1 (concat "<" source) (concat ">" target)) "&")) + " ")) + (tramp-send-command v remote-copy-program) + (with-timeout + (60 (tramp-error + v 'file-error + "Listener process not running on remote host: `%s'" + remote-copy-program)) + (tramp-send-command v (format "netstat -l | grep -q :%s" listener)) + (while (not (tramp-send-command-and-check v nil)) + (tramp-send-command + v (format "netstat -l | grep -q :%s" listener))))) + + (with-temp-buffer + (unwind-protect + ;; The default directory must be remote. + (let ((default-directory + (file-name-directory (if v1 filename newname))) + (process-environment (copy-sequence process-environment))) + ;; Set the transfer process properties. + (tramp-set-connection-property + v "process-name" (buffer-name (current-buffer))) + (tramp-set-connection-property + v "process-buffer" (current-buffer)) + (when copy-env + (tramp-message + v 6 "%s=\"%s\"" + (car copy-env) (string-join (cdr copy-env) " ")) + (setenv (car copy-env) (string-join (cdr copy-env) " "))) + (setq + copy-args + (append + copy-args + (if remote-copy-program + (list (if v1 (concat ">" target) (concat "<" source))) + (list source target))) + ;; Use an asynchronous process. By this, password can + ;; be handled. We don't set a timeout, because the + ;; copying of large files can last longer than 60 secs. + p (let ((default-directory + tramp-compat-temporary-file-directory)) + (apply + #'start-process + (tramp-get-connection-name v) + (tramp-get-connection-buffer v) + copy-program copy-args))) + (tramp-message v 6 "%s" (string-join (process-command p) " ")) + (process-put p 'vector v) + (process-put p 'adjust-window-size-function #'ignore) + (set-process-query-on-exit-flag p nil) + + ;; We must adapt `tramp-local-end-of-line' for sending + ;; the password. Also, we indicate that perhaps several + ;; password prompts might appear. + (let ((tramp-local-end-of-line tramp-rsh-end-of-line) + (tramp-password-prompt-not-unique (and v1 v2))) + (tramp-process-actions + p v nil tramp-actions-copy-out-of-band))) + + ;; Reset the transfer process properties. + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer") + ;; Clear the remote prompt. + (when (and remote-copy-program + (not (tramp-send-command-and-check v nil))) + ;; Houston, we have a problem! Likely, the listener is + ;; still running, so let's clear everything (but the + ;; cached password). + (tramp-cleanup-connection v 'keep-debug 'keep-password)))) + + ;; Handle KEEP-DATE argument. + (when (and keep-date (not copy-keep-date)) + (tramp-compat-set-file-times + newname + (file-attribute-modification-time (file-attributes filename)) + (unless ok-if-already-exists 'nofollow))) + + ;; Set the mode. + (unless (and keep-date copy-keep-date) + (ignore-errors + (set-file-modes newname (tramp-default-file-modes filename))))) - ;; We must adapt `tramp-local-end-of-line' for - ;; sending the password. - (let ((tramp-local-end-of-line tramp-rsh-end-of-line)) - (tramp-process-actions - p v nil tramp-actions-copy-out-of-band))) - - ;; Reset the transfer process properties. - (tramp-flush-connection-property v "process-name") - (tramp-flush-connection-property v "process-buffer") - ;; Clear the remote prompt. - (when (and remote-copy-program - (not (tramp-send-command-and-check v nil))) - ;; Houston, we have a problem! Likely, the listener is - ;; still running, so let's clear everything (but the - ;; cached password). - (tramp-cleanup-connection v 'keep-debug 'keep-password)))) - - ;; Handle KEEP-DATE argument. - (when (and keep-date (not copy-keep-date)) - (tramp-compat-set-file-times - newname - (tramp-compat-file-attribute-modification-time - (file-attributes filename)) - (unless ok-if-already-exists 'nofollow))) - - ;; Set the mode. - (unless (and keep-date copy-keep-date) - (ignore-errors - (set-file-modes newname (tramp-default-file-modes filename))))) - - ;; If the operation was `rename', delete the original file. - (unless (eq op 'copy) - (if (file-regular-p filename) - (delete-file filename) - (delete-directory filename 'recursive)))))) + ;; If the operation was `rename', delete the original file. + (unless (eq op 'copy) + (if (file-regular-p filename) + (delete-file filename) + (delete-directory filename 'recursive))))) (defun tramp-sh-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." @@ -2493,42 +2532,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) @@ -2600,7 +2655,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. @@ -2712,38 +2767,32 @@ 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 ;; groks tilde expansion! The function `tramp-find-shell' is ;; supposed to find such a shell on the remote host. Please ;; tell me about it when this doesn't work on your system. - (when (string-match "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) + (when (string-match "\\`~\\([^/]*\\)\\(.*\\)\\'" localname) (let ((uname (match-string 1 localname)) - (fname (match-string 2 localname))) + (fname (match-string 2 localname)) + hname) ;; We cannot simply apply "~/", because under sudo "~/" is ;; expanded to the local user home directory but to the ;; root home directory. On the other hand, using always ;; the default user name for tilde expansion is not ;; appropriate either, because ssh and companions might ;; use a user name from the config file. - (when (and (string-equal uname "~") + (when (and (zerop (length uname)) (string-match-p "\\`su\\(do\\)?\\'" method)) - (setq uname (concat uname user))) - (setq uname - (with-tramp-connection-property v uname - (tramp-send-command - v - (format "cd %s && pwd" (tramp-shell-quote-argument uname))) - (with-current-buffer (tramp-get-buffer v) - (goto-char (point-min)) - (buffer-substring (point) (point-at-eol))))) - (setq localname (concat uname fname)))) + (setq uname user)) + (when (setq hname (tramp-get-home-directory v uname)) + (setq localname (concat hname fname))))) ;; There might be a double slash, for example when "~/" ;; expands to "/". Remove this. (while (string-match "//" localname) @@ -2751,15 +2800,17 @@ the result will be a local, non-Tramp, file name." ;; 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. ;; `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)))))))))) ;;; Remote commands: @@ -2825,6 +2876,7 @@ implementation will be used." stderr (tramp-make-tramp-temp-name v))))) (remote-tmpstderr (and tmpstderr (tramp-make-tramp-file-name v tmpstderr))) + (orig-command command) (program (car command)) (args (cdr command)) ;; When PROGRAM matches "*sh", and the first arg is @@ -2855,7 +2907,7 @@ implementation will be used." ;; `shell'. We discard hops, if existing, that's why ;; we cannot use `file-remote-p'. (prompt (format "PS1=%s %s" - (tramp-make-tramp-file-name v nil 'nohop) + (tramp-make-tramp-file-name v) tramp-initial-end-of-output)) ;; We use as environment the difference to toplevel ;; `process-environment'. @@ -2981,6 +3033,9 @@ implementation will be used." (set-process-sentinel p sentinel)) (when filter (set-process-filter p filter)) + (process-put p 'remote-command orig-command) + (tramp-set-connection-property + p "remote-command" orig-command) ;; Set query flag and process marker for this ;; process. We ignore errors, because the ;; process could have finished already. @@ -3016,7 +3071,7 @@ implementation will be used." vec (concat "signal-strings-" (tramp-get-method-parameter vec 'tramp-remote-shell)) - (let ((default-directory (tramp-make-tramp-file-name vec 'localname)) + (let ((default-directory (tramp-make-tramp-file-name vec 'noloc)) process-file-return-signal-string signals res result) (setq signals (append @@ -3107,7 +3162,7 @@ implementation will be used." (setq input (tramp-unquote-file-local-name infile)) ;; INFILE must be copied to remote host. (setq input (tramp-make-tramp-temp-file v) - tmpinput (tramp-make-tramp-file-name v input 'nohop)) + tmpinput (tramp-make-tramp-file-name v input)) (copy-file infile tmpinput t))) (when input (setq command (format "%s <%s" command input))) @@ -3139,7 +3194,7 @@ implementation will be used." ;; stderr must be copied to remote host. The temporary ;; file must be deleted after execution. (setq stderr (tramp-make-tramp-temp-file v) - tmpstderr (tramp-make-tramp-file-name v stderr 'nohop)))) + tmpstderr (tramp-make-tramp-file-name v stderr)))) ;; stderr to be discarded. ((null (cadr destination)) (setq stderr (tramp-get-remote-null-device v))))) @@ -3164,8 +3219,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. @@ -3208,9 +3262,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)) @@ -3286,255 +3340,197 @@ implementation will be used." (defun tramp-sh-handle-write-region (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." - (setq filename (expand-file-name filename) - lockname (file-truename (or lockname filename))) - (with-parsed-tramp-file-name filename nil - (when (and mustbenew (file-exists-p filename) - (or (eq mustbenew 'excl) - (not - (y-or-n-p - (format "File %s exists; overwrite anyway?" filename))))) - (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)) - (tramp-get-remote-uid v 'integer))) - (gid (or (tramp-compat-file-attribute-group-id - (file-attributes filename 'integer)) - (tramp-get-remote-gid v 'integer)))) - - ;; Lock file. - (when (and (not (auto-save-file-name-p (file-name-nondirectory filename))) - (file-remote-p lockname) - (not file-locked)) - (setq file-locked t) - ;; `lock-file' exists since Emacs 28.1. - (tramp-compat-funcall 'lock-file lockname)) - - (if (and (tramp-local-host-p v) - ;; `file-writable-p' calls `file-expand-file-name'. We - ;; cannot use `tramp-run-real-handler' therefore. - (file-writable-p (file-name-directory localname)) - (or (file-directory-p localname) - (file-writable-p localname))) - ;; Short track: if we are on the local host, we can run directly. - (let ((create-lockfiles (not file-locked))) - (write-region start end localname append 'no-message lockname)) - - (let* ((modes (tramp-default-file-modes - filename (and (eq mustbenew 'excl) 'nofollow))) - ;; We use this to save the value of - ;; `last-coding-system-used' after writing the tmp - ;; file. At the end of the function, we set - ;; `last-coding-system-used' to this saved value. This - ;; way, any intermediary coding systems used while - ;; talking to the remote shell or suchlike won't hose - ;; this variable. This approach was snarfed from - ;; ange-ftp.el. - coding-system-used - ;; Write region into a tmp file. This isn't really - ;; needed if we use an encoding function, but currently - ;; we use it always because this makes the logic - ;; simpler. We must also set `temporary-file-directory', - ;; because it could point to a remote directory. - (temporary-file-directory tramp-compat-temporary-file-directory) - (tmpfile (or tramp-temp-buffer-file-name - (tramp-compat-make-temp-file filename)))) - - ;; If `append' is non-nil, we copy the file locally, and let - ;; the native `write-region' implementation do the job. - (when (and append (file-exists-p filename)) - (copy-file filename tmpfile 'ok)) - - ;; We say `no-message' here because we don't want the - ;; visited file modtime data to be clobbered from the temp - ;; file. We call `set-visited-file-modtime' ourselves later - ;; on. We must ensure that `file-coding-system-alist' - ;; matches `tmpfile'. - (let ((file-coding-system-alist - (tramp-find-file-name-coding-system-alist filename tmpfile)) - create-lockfiles) - (condition-case err - (write-region start end tmpfile append 'no-message) - ((error quit) - (setq tramp-temp-buffer-file-name nil) - (delete-file tmpfile) - (signal (car err) (cdr err)))) - - ;; Now, `last-coding-system-used' has the right value. Remember it. - (setq coding-system-used last-coding-system-used)) - - ;; The permissions of the temporary file should be set. If - ;; FILENAME does not exist (eq modes nil) it has been - ;; renamed to the backup file. This case `save-buffer' - ;; handles permissions. - ;; Ensure that it is still readable. - (when modes - (set-file-modes tmpfile (logior (or modes 0) #o0400))) - - ;; This is a bit lengthy due to the different methods - ;; possible for file transfer. First, we check whether the - ;; method uses an scp program. If so, we call it. - ;; Otherwise, both encoding and decoding command must be - ;; 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))) - (rem-dec (tramp-get-inline-coding v "remote-decoding" size)) - (loc-enc (tramp-get-inline-coding v "local-encoding" size))) - (cond - ;; `copy-file' handles direct copy and out-of-band methods. - ((or (tramp-local-host-p v) - (tramp-method-out-of-band-p v size)) - (if (and (not (stringp start)) - (= (or end (point-max)) (point-max)) - (= (or start (point-min)) (point-min)) - (tramp-get-method-parameter v 'tramp-copy-keep-tmpfile)) - (progn - (setq tramp-temp-buffer-file-name tmpfile) - (condition-case err - ;; We keep the local file for performance - ;; reasons, useful for "rsync". - (copy-file tmpfile filename t) - ((error quit) - (setq tramp-temp-buffer-file-name nil) - (delete-file tmpfile) - (signal (car err) (cdr err))))) - (setq tramp-temp-buffer-file-name nil) - ;; Don't rename, in order to keep context in SELinux. - (unwind-protect - (copy-file tmpfile filename t) - (delete-file tmpfile)))) - - ;; Use inline file transfer. - (rem-dec - ;; Encode tmpfile. + (tramp-skeleton-write-region start end filename append visit lockname mustbenew + (if (and (tramp-local-host-p v) + ;; `file-writable-p' calls `file-expand-file-name'. We + ;; cannot use `tramp-run-real-handler' therefore. + (file-writable-p (file-name-directory localname)) + (or (file-directory-p localname) + (file-writable-p localname))) + ;; Short track: if we are on the local host, we can run directly. + (let ((create-lockfiles (not file-locked))) + (write-region start end localname append 'no-message lockname)) + + (let* ((modes (tramp-default-file-modes + filename (and (eq mustbenew 'excl) 'nofollow))) + ;; We use this to save the value of + ;; `last-coding-system-used' after writing the tmp file. + ;; At the end of the function, we set + ;; `last-coding-system-used' to this saved value. This + ;; way, any intermediary coding systems used while + ;; talking to the remote shell or suchlike won't hose + ;; this variable. This approach was snarfed from + ;; ange-ftp.el. + coding-system-used + ;; Write region into a tmp file. This isn't really + ;; needed if we use an encoding function, but currently + ;; we use it always because this makes the logic simpler. + ;; We must also set `temporary-file-directory', because + ;; it could point to a remote directory. + (temporary-file-directory + tramp-compat-temporary-file-directory) + (tmpfile (or tramp-temp-buffer-file-name + (tramp-compat-make-temp-file filename)))) + + ;; If `append' is non-nil, we copy the file locally, and let + ;; the native `write-region' implementation do the job. + (when (and append (file-exists-p filename)) + (copy-file filename tmpfile 'ok)) + + ;; We say `no-message' here because we don't want the visited + ;; file modtime data to be clobbered from the temp file. We + ;; call `set-visited-file-modtime' ourselves later on. We + ;; must ensure that `file-coding-system-alist' matches + ;; `tmpfile'. + (let ((file-coding-system-alist + (tramp-find-file-name-coding-system-alist filename tmpfile)) + create-lockfiles) + (condition-case err + (write-region start end tmpfile append 'no-message) + ((error quit) + (setq tramp-temp-buffer-file-name nil) + (delete-file tmpfile) + (signal (car err) (cdr err)))) + + ;; Now, `last-coding-system-used' has the right value. + ;; Remember it. + (setq coding-system-used last-coding-system-used)) + + ;; The permissions of the temporary file should be set. If + ;; FILENAME does not exist (eq modes nil) it has been renamed + ;; to the backup file. This case `save-buffer' handles + ;; permissions. Ensure that it is still readable. + (when modes + (set-file-modes tmpfile (logior (or modes 0) #o0400))) + + ;; This is a bit lengthy due to the different methods possible + ;; for file transfer. First, we check whether the method uses + ;; an scp program. If so, we call it. Otherwise, both + ;; encoding and decoding command must be specified. However, + ;; if the method _also_ specifies an encoding function, then + ;; that is used for encoding the contents of the tmp file. + (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 + ;; `copy-file' handles direct copy and out-of-band methods. + ((or (tramp-local-host-p v) + (tramp-method-out-of-band-p v size)) + (if (and (not (stringp start)) + (= (or end (point-max)) (point-max)) + (= (or start (point-min)) (point-min)) + (tramp-get-method-parameter + v 'tramp-copy-keep-tmpfile)) + (progn + (setq tramp-temp-buffer-file-name tmpfile) + (condition-case err + ;; We keep the local file for performance + ;; reasons, useful for "rsync". + (copy-file tmpfile filename t) + ((error quit) + (setq tramp-temp-buffer-file-name nil) + (delete-file tmpfile) + (signal (car err) (cdr err))))) + (setq tramp-temp-buffer-file-name nil) + ;; Don't rename, in order to keep context in SELinux. (unwind-protect - (with-temp-buffer - (set-buffer-multibyte nil) - ;; Use encoding function or command. - (with-tramp-progress-reporter - v 3 (format-message - "Encoding local file `%s' using `%s'" - tmpfile loc-enc) - (if (functionp loc-enc) - ;; The following `let' is a workaround for - ;; the base64.el that comes with pgnus-0.84. - ;; If both of the following conditions are - ;; satisfied, it tries to write to a local - ;; file in default-directory, but at this - ;; point, default-directory is remote. - ;; (`call-process-region' can't write to - ;; remote files, it seems.) The file in - ;; question is a tmp file anyway. - (let ((coding-system-for-read 'binary) - (default-directory - tramp-compat-temporary-file-directory)) - (insert-file-contents-literally tmpfile) - (funcall loc-enc (point-min) (point-max))) - - (unless (zerop (tramp-call-local-coding-command - loc-enc tmpfile t)) - (tramp-error - v 'file-error - (concat "Cannot write to `%s', " - "local encoding command `%s' failed") - filename loc-enc)))) - - ;; Send buffer into remote decoding command which - ;; writes to remote file. Because this happens on - ;; the remote host, we cannot use the function. - (with-tramp-progress-reporter - v 3 (format-message - "Decoding remote file `%s' using `%s'" - filename rem-dec) - (goto-char (point-max)) - (unless (bolp) (newline)) - (tramp-send-command - v - (format - (concat rem-dec " <<'%s'\n%s%s") - (tramp-shell-quote-argument localname) - tramp-end-of-heredoc - (buffer-string) - tramp-end-of-heredoc)) - (tramp-barf-unless-okay - v nil - "Couldn't write region to `%s', decode using `%s' failed" - filename rem-dec) - ;; When `file-precious-flag' is set, the region is - ;; written to a temporary file. Check that the - ;; checksum is equal to that from the local tmpfile. - (when file-precious-flag - (erase-buffer) - (and - ;; cksum runs locally, if possible. - (zerop (tramp-call-process v "cksum" tmpfile t)) - ;; cksum runs remotely. - (tramp-send-command-and-check - v - (format - "cksum <%s" (tramp-shell-quote-argument localname))) - ;; ... they are different. - (not - (string-equal - (buffer-string) - (with-current-buffer (tramp-get-buffer v) - (buffer-string)))) - (tramp-error - v 'file-error - (concat "Couldn't write region to `%s'," - " decode using `%s' failed") - filename rem-dec))))) - - ;; Save exit. - (delete-file tmpfile))) + (copy-file tmpfile filename t) + (delete-file tmpfile)))) - ;; That's not expected. - (t - (tramp-error - v 'file-error - (concat "Method `%s' should specify both encoding and " - "decoding command or an scp program") - method)))) + ;; Use inline file transfer. + (rem-dec + ;; Encode tmpfile. + (unwind-protect + (with-temp-buffer + (set-buffer-multibyte nil) + ;; Use encoding function or command. + (with-tramp-progress-reporter + v 3 (format-message + "Encoding local file `%s' using `%s'" + tmpfile loc-enc) + (if (functionp loc-enc) + ;; The following `let' is a workaround for the + ;; base64.el that comes with pgnus-0.84. If + ;; both of the following conditions are + ;; satisfied, it tries to write to a local + ;; file in default-directory, but at this + ;; point, default-directory is remote. + ;; (`call-process-region' can't write to + ;; remote files, it seems.) The file in + ;; question is a tmp file anyway. + (let ((coding-system-for-read 'binary) + (default-directory + tramp-compat-temporary-file-directory)) + (insert-file-contents-literally tmpfile) + (funcall loc-enc (point-min) (point-max))) + + (unless (zerop (tramp-call-local-coding-command + loc-enc tmpfile t)) + (tramp-error + v 'file-error + (concat "Cannot write to `%s', " + "local encoding command `%s' failed") + filename loc-enc)))) + + ;; Send buffer into remote decoding command which + ;; writes to remote file. Because this happens on + ;; the remote host, we cannot use the function. + (with-tramp-progress-reporter + v 3 (format-message + "Decoding remote file `%s' using `%s'" + filename rem-dec) + (goto-char (point-max)) + (unless (bolp) (newline)) + (tramp-send-command + v + (format + (concat rem-dec " <<'%s'\n%s%s") + (tramp-shell-quote-argument localname) + tramp-end-of-heredoc + (buffer-string) + tramp-end-of-heredoc)) + (tramp-barf-unless-okay + v nil + "Couldn't write region to `%s', decode using `%s' failed" + filename rem-dec) + ;; When `file-precious-flag' is set, the region is + ;; written to a temporary file. Check that the + ;; checksum is equal to that from the local tmpfile. + (when file-precious-flag + (erase-buffer) + (and + ;; cksum runs locally, if possible. + (zerop (tramp-call-process v "cksum" tmpfile t)) + ;; cksum runs remotely. + (tramp-send-command-and-check + v + (format + "cksum <%s" + (tramp-shell-quote-argument localname))) + ;; ... they are different. + (not + (string-equal + (buffer-string) + (tramp-get-buffer-string (tramp-get-buffer v)))) + (tramp-error + v 'file-error + "Couldn't write region to `%s', decode using `%s' failed" + filename rem-dec))))) - ;; Make `last-coding-system-used' have the right value. - (when coding-system-used - (setq last-coding-system-used coding-system-used)))) + ;; Save exit. + (delete-file tmpfile))) - (tramp-flush-file-properties v localname) + ;; That's not expected. + (t + (tramp-error + v 'file-error + (concat "Method `%s' should specify both encoding and " + "decoding command or an scp program") + method)))) - ;; We must protect `last-coding-system-used', now we have set it - ;; to its correct value. - (let (last-coding-system-used (need-chown t)) - ;; Set file modification time. - (when (or (eq visit t) (stringp visit)) - (let ((file-attr (file-attributes filename 'integer))) - (set-visited-file-modtime - ;; 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) - (current-time))) - (when (and (= (tramp-compat-file-attribute-user-id file-attr) uid) - (= (tramp-compat-file-attribute-group-id file-attr) gid)) - (setq need-chown nil)))) - - ;; Set the ownership. - (when need-chown - (tramp-set-file-uid-gid filename uid gid)) - - ;; Unlock file. - (when file-locked - ;; `unlock-file' exists since Emacs 28.1. - (tramp-compat-funcall 'unlock-file lockname)) - - (when (and (null noninteractive) - (or (eq visit t) (string-or-null-p visit))) - (tramp-message v 0 "Wrote %s" filename)) - (run-hooks 'tramp-handle-write-region-hook))))) + ;; Make `last-coding-system-used' have the right value. + (when coding-system-used + (setq last-coding-system-used coding-system-used)))))) (defvar tramp-vc-registered-file-names nil "List used to collect file names, which are checked during `vc-registered'.") @@ -3658,8 +3654,7 @@ Fall back to normal file name handler if no Tramp handler exists." (defun tramp-sh-file-name-handler-p (vec) "Whether VEC uses a method from `tramp-sh-file-name-handler'." (and (assoc (tramp-file-name-method vec) tramp-methods) - (eq (tramp-find-foreign-file-name-handler - (tramp-make-tramp-file-name vec nil 'nohop)) + (eq (tramp-find-foreign-file-name-handler vec) 'tramp-sh-file-name-handler))) ;; This must be the last entry, because `identity' always matches. @@ -3776,8 +3771,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 @@ -4812,7 +4806,7 @@ Goes through the list `tramp-inline-compress-commands'." ((stringp tramp-scp-strict-file-name-checking) tramp-scp-strict-file-name-checking) - ;; Determine the options. + ;; Determine the option. (t (setq tramp-scp-strict-file-name-checking "") (let ((case-fold-search t)) (ignore-errors @@ -4855,6 +4849,79 @@ Goes through the list `tramp-inline-compress-commands'." (setq tramp-scp-force-scp-protocol "-O"))))))) tramp-scp-force-scp-protocol))) +(defun tramp-scp-direct-remote-copying (vec1 vec2) + "Return the direct remote copying argument of the local scp." + (cond + ((or (not tramp-use-scp-direct-remote-copying) (null vec1) (null vec2) + (not (tramp-get-process vec1)) + (not (equal (tramp-file-name-port vec1) (tramp-file-name-port vec2))) + (null (assoc "%z" (tramp-get-method-parameter vec1 'tramp-copy-args))) + (null (assoc "%z" (tramp-get-method-parameter vec2 'tramp-copy-args)))) + "") + + ((let ((case-fold-search t)) + (and + ;; Check, whether "scp" supports "-R" option. + (with-tramp-connection-property nil "scp-R" + (when (executable-find "scp") + (with-temp-buffer + (tramp-call-process vec1 "scp" nil t nil "-R") + (goto-char (point-min)) + (not (search-forward-regexp + "\\(illegal\\|unknown\\) option -- R" nil 'noerror))))) + + ;; Check, that RemoteCommand is not used. + (with-tramp-connection-property + (tramp-get-process vec1) "ssh-remote-command" + (let ((command `("ssh" "-G" ,(tramp-file-name-host vec1)))) + (with-temp-buffer + (tramp-call-process + vec1 tramp-encoding-shell nil t nil + tramp-encoding-command-switch + (mapconcat #'identity command " ")) + (goto-char (point-min)) + (not (search-forward "remotecommand" nil 'noerror))))) + + ;; Check hostkeys. + (with-tramp-connection-property + (tramp-get-process vec1) + (concat "direct-remote-copying-" + (tramp-make-tramp-file-name vec2 'noloc)) + (let ((command + (append + `("ssh" "-G" ,(tramp-file-name-host vec2) "|" + "grep" "-i" "^hostname" "|" "cut" "-d\" \"" "-f2" "|" + "ssh-keyscan" "-f" "-") + (when (tramp-file-name-port vec2) + `("-p" ,(tramp-file-name-port vec2))))) + found string) + (with-temp-buffer + ;; Check hostkey of VEC2, seen from VEC1. + (tramp-send-command vec1 (mapconcat #'identity command " ")) + ;; Check hostkey of VEC2, seen locally. + (tramp-call-process + vec1 tramp-encoding-shell nil t nil tramp-encoding-command-switch + (mapconcat #'identity command " ")) + (goto-char (point-min)) + (while (and (not found) (not (eobp))) + (setq string + (buffer-substring + (line-beginning-position) (line-end-position)) + string + (and + (string-match "^[^# ]+ \\S-+ \\(\\S-+\\)$" string) + (match-string 1 string)) + found + (and string + (with-current-buffer (tramp-get-buffer vec1) + (goto-char (point-min)) + (search-forward string nil 'noerror)))) + (forward-line)) + found))))) + "-R") + + (t "-3"))) + (defun tramp-timeout-session (vec) "Close the connection VEC after a session timeout. If there is just some editing, retry it after 5 seconds." @@ -4949,8 +5016,7 @@ connection if a previous connection has died for some reason." (tramp-error vec 'file-error "`tramp-encoding-shell' not set")) (let* ((current-host tramp-system-name) (target-alist (tramp-compute-multi-hops vec)) - ;; Needed for `tramp-get-remote-null-device'. - (previous-hop nil) + (previous-hop tramp-null-hop) ;; We will apply `tramp-ssh-controlmaster-options' ;; only for the first hop. (options (tramp-ssh-controlmaster-options vec)) @@ -5035,9 +5101,14 @@ connection if a previous connection has died for some reason." ;; Set password prompt vector. (tramp-set-connection-property p "password-vector" - (make-tramp-file-name - :method l-method :user l-user :domain l-domain - :host l-host :port l-port)) + (if (tramp-get-method-parameter + hop 'tramp-password-previous-hop) + (let ((pv (copy-tramp-file-name previous-hop))) + (setf (tramp-file-name-method pv) l-method) + pv) + (make-tramp-file-name + :method l-method :user l-user :domain l-domain + :host l-host :port l-port))) ;; Set session timeout. (when (tramp-get-method-parameter @@ -5473,7 +5544,7 @@ Nonexistent directories are removed from spec." (lambda (x) (and (stringp x) - (file-directory-p (tramp-make-tramp-file-name vec x 'nohop)) + (file-directory-p (tramp-make-tramp-file-name vec x)) x)) remote-path)))))) @@ -6015,9 +6086,6 @@ function cell is returned to be applied on a buffer." ;; ;; * Use lsh instead of ssh. (Alfred M. Szmidt) ;; -;; * Optimize out-of-band copying when both methods are scp-like (not -;; rsync). -;; ;; * Keep a second connection open for out-of-band methods like scp or ;; rsync. ;; @@ -6061,5 +6129,9 @@ 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 2aaa6e8ab3f..8037c89829f 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) @@ -273,6 +274,7 @@ See `tramp-actions-before-shell' for more info.") ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-smb-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) + (list-system-processes . ignore) (load . tramp-handle-load) (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) @@ -282,6 +284,7 @@ See `tramp-actions-before-shell' for more info.") (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-smb-handle-make-symbolic-link) + (process-attributes . ignore) (process-file . tramp-smb-handle-process-file) (rename-file . tramp-smb-handle-rename-file) (set-file-acl . tramp-smb-handle-set-file-acl) @@ -293,6 +296,7 @@ See `tramp-actions-before-shell' for more info.") (start-file-process . tramp-smb-handle-start-file-process) (substitute-in-file-name . tramp-smb-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-get-home-directory . tramp-smb-handle-get-home-directory) (tramp-get-remote-gid . ignore) (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) @@ -330,11 +334,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 +422,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 +445,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 +570,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,12 +604,16 @@ 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))) + ;; `file-local-copy' returns a file name also for a local file + ;; with `jka-compr-handler', so we cannot trust its result as + ;; indication for a remote file name. + (if-let ((tmpfile + (and (file-remote-p filename) (file-local-copy filename)))) ;; Remote filename. (condition-case err (rename-file tmpfile newname ok-if-already-exists) @@ -645,8 +651,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 +711,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. @@ -747,25 +752,30 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (tramp-run-real-handler #'expand-file-name (list name nil)) ;; Dissect NAME. (with-parsed-tramp-file-name name nil - ;; Tilde expansion if necessary. We use the user name as share, - ;; which is often the case in domains. - (when (string-match "\\`/?~\\([^/]*\\)" localname) - (setq localname - (replace-match - (if (zerop (length (match-string 1 localname))) - user - (match-string 1 localname)) - nil nil localname))) - ;; Make the file name absolute. + ;; Tilde expansion if necessary. + (when (string-match "\\`~\\([^/]*\\)\\(.*\\)\\'" localname) + (let ((uname (match-string 1 localname)) + (fname (match-string 2 localname)) + hname) + (when (zerop (length uname)) + (setq uname user)) + (when (setq hname (tramp-get-home-directory v uname)) + (setq localname (concat hname fname))))) + ;; Tilde expansion is not possible. + (when (and (not tramp-tolerate-tilde) + (string-match-p "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname)) + (tramp-error v 'file-error "Cannot expand tilde in file `%s'" name)) (unless (tramp-run-real-handler #'file-name-absolute-p (list localname)) (setq localname (concat "/" localname))) ;; 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-smb-action-get-acl (proc vec) "Read ACL data from connection buffer." @@ -976,7 +986,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 +1051,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))))) @@ -1147,11 +1156,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. @@ -1173,8 +1182,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))) @@ -1395,7 +1404,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) @@ -1440,9 +1449,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." @@ -1541,7 +1550,8 @@ component is used as the target of the symlink." (command (string-join (cons program args) " ")) (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer))) (name1 name) - (i 0)) + (i 0) + p) (unwind-protect (save-excursion (save-restriction @@ -1564,8 +1574,13 @@ component is used as the target of the symlink." host (file-name-directory localname)))) (tramp-message v 6 "(%s); exit" command) (tramp-send-string v command))) + (setq p (tramp-get-connection-process v)) + (when program + (process-put p 'remote-command (cons program args)) + (tramp-set-connection-property + p "remote-command" (cons program args))) ;; Return value. - (tramp-get-connection-process v))) + p)) ;; Save exit. (with-current-buffer (tramp-get-connection-buffer v) @@ -1594,31 +1609,20 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." (tramp-run-real-handler #'substitute-in-file-name (list filename)) (error filename)))) +(defun tramp-smb-handle-get-home-directory (vec &optional user) + "The remote home directory for connection VEC as local file name. +If USER is a string, return its home directory instead of the +user identified by VEC. If there is no user specified in either +VEC or USER, or if there is no home directory, return nil." + (let ((user (or user (tramp-file-name-user vec)))) + (unless (zerop (length user)) + (concat "/" user)))) + (defun tramp-smb-handle-write-region (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." - (setq filename (expand-file-name filename) - lockname (file-truename (or lockname filename))) - (with-parsed-tramp-file-name filename nil - (when (and mustbenew (file-exists-p filename) - (or (eq mustbenew 'excl) - (not - (y-or-n-p - (format "File %s exists; overwrite anyway?" filename))))) - (tramp-error v 'file-already-exists filename)) - - (let ((file-locked (eq (file-locked-p lockname) t)) - (curbuf (current-buffer)) - (tmpfile (tramp-compat-make-temp-file filename))) - - ;; Lock file. - (when (and (not (auto-save-file-name-p (file-name-nondirectory filename))) - (file-remote-p lockname) - (not file-locked)) - (setq file-locked t) - ;; `lock-file' exists since Emacs 28.1. - (tramp-compat-funcall 'lock-file lockname)) - + (tramp-skeleton-write-region start end filename append visit lockname mustbenew + (let ((tmpfile (tramp-compat-make-temp-file filename))) (when (and append (file-exists-p filename)) (copy-file filename tmpfile 'ok)) ;; We say `no-message' here because we don't want the visited file @@ -1634,34 +1638,7 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." v (format "put %s \"%s\"" tmpfile (tramp-smb-get-localname v))) (tramp-error v 'file-error "Cannot write `%s'" filename)) - (delete-file tmpfile))) - - ;; We must also flush the cache of the directory, because - ;; `file-attributes' reads the values from there. - (tramp-flush-file-properties v localname) - - (unless (equal curbuf (current-buffer)) - (tramp-error - v 'file-error - "Buffer has changed from `%s' to `%s'" curbuf (current-buffer))) - - ;; 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)) - (current-time)))) - - ;; Unlock file. - (when file-locked - ;; `unlock-file' exists since Emacs 28.1. - (tramp-compat-funcall 'unlock-file lockname)) - - ;; The end. - (when (and (null noninteractive) - (or (eq visit t) (string-or-null-p visit))) - (tramp-message v 0 "Wrote %s" filename)) - (run-hooks 'tramp-handle-write-region-hook)))) + (delete-file tmpfile)))))) ;; Internal file name functions. diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el index b229f589248..61bf165f308 100644 --- a/lisp/net/tramp-sshfs.el +++ b/lisp/net/tramp-sshfs.el @@ -74,7 +74,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) @@ -125,6 +126,7 @@ ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-handle-insert-directory) (insert-file-contents . tramp-sshfs-handle-insert-file-contents) + (list-system-processes . tramp-handle-list-system-processes) (load . tramp-handle-load) (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) @@ -134,6 +136,7 @@ (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . tramp-handle-make-process) (make-symbolic-link . tramp-handle-make-symbolic-link) + (process-attributes . tramp-handle-process-attributes) (process-file . tramp-sshfs-handle-process-file) (rename-file . tramp-sshfs-handle-rename-file) (set-file-acl . ignore) @@ -145,6 +148,7 @@ (start-file-process . tramp-handle-start-file-process) (substitute-in-file-name . tramp-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-get-home-directory . ignore) (tramp-get-remote-gid . ignore) (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) @@ -159,11 +163,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) @@ -263,7 +266,7 @@ arguments to pass to the OPERATION." (setq input (tramp-unquote-file-local-name infile)) ;; INFILE must be copied to remote host. (setq input (tramp-make-tramp-temp-file v) - tmpinput (tramp-make-tramp-file-name v input 'nohop)) + tmpinput (tramp-make-tramp-file-name v input)) (copy-file infile tmpinput t))) (when input (setq command (format "%s <%s" command input))) @@ -370,48 +373,10 @@ arguments to pass to the OPERATION." (defun tramp-sshfs-handle-write-region (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." - (setq filename (expand-file-name filename) - lockname (file-truename (or lockname filename))) - (with-parsed-tramp-file-name filename nil - (when (and mustbenew (file-exists-p filename) - (or (eq mustbenew 'excl) - (not - (y-or-n-p - (format "File %s exists; overwrite anyway?" filename))))) - (tramp-error v 'file-already-exists filename)) - - (let ((file-locked (eq (file-locked-p lockname) t))) - - ;; Lock file. - (when (and (not (auto-save-file-name-p (file-name-nondirectory filename))) - (file-remote-p lockname) - (not file-locked)) - (setq file-locked t) - ;; `lock-file' exists since Emacs 28.1. - (tramp-compat-funcall 'lock-file lockname)) - - (let (create-lockfiles) - (write-region - start end (tramp-fuse-local-file-name filename) append 'nomessage) - (tramp-flush-file-properties v localname)) - - ;; 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)) - (current-time)))) - - ;; Unlock file. - (when file-locked - ;; `unlock-file' exists since Emacs 28.1. - (tramp-compat-funcall 'unlock-file lockname)) - - ;; The end. - (when (and (null noninteractive) - (or (eq visit t) (string-or-null-p visit))) - (tramp-message v 0 "Wrote %s" filename)) - (run-hooks 'tramp-handle-write-region-hook)))) + (tramp-skeleton-write-region start end filename append visit lockname mustbenew + (let (create-lockfiles) + (write-region + start end (tramp-fuse-local-file-name filename) append 'nomessage)))) ;; File name conversions. diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index 06100fbde0d..420a593644f 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -45,7 +45,8 @@ (add-to-list 'tramp-methods `(,tramp-sudoedit-method (tramp-sudo-login (("sudo") ("-u" "%u") ("-S") ("-H") - ("-p" "Password:") ("--"))))) + ("-p" "Password:") ("--"))) + (tramp-password-previous-hop t))) (add-to-list 'tramp-default-user-alist '("\\`sudoedit\\'" nil "root")) @@ -63,7 +64,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) @@ -115,6 +117,7 @@ See `tramp-actions-before-shell' for more info.") ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) + (list-system-processes . ignore) (load . tramp-handle-load) (lock-file . tramp-handle-lock-file) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) @@ -124,6 +127,7 @@ See `tramp-actions-before-shell' for more info.") (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) (make-process . ignore) (make-symbolic-link . tramp-sudoedit-handle-make-symbolic-link) + (process-attributes . ignore) (process-file . ignore) (rename-file . tramp-sudoedit-handle-rename-file) (set-file-acl . tramp-sudoedit-handle-set-file-acl) @@ -135,6 +139,7 @@ See `tramp-actions-before-shell' for more info.") (start-file-process . ignore) (substitute-in-file-name . tramp-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-get-home-directory . tramp-sudoedit-handle-get-home-directory) (tramp-get-remote-gid . tramp-sudoedit-handle-get-remote-gid) (tramp-get-remote-uid . tramp-sudoedit-handle-get-remote-uid) (tramp-set-file-uid-gid . tramp-sudoedit-handle-set-file-uid-gid) @@ -142,17 +147,16 @@ See `tramp-actions-before-shell' for more info.") (unlock-file . tramp-handle-unlock-file) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) - (write-region . tramp-sudoedit-handle-write-region)) + (write-region . tramp-handle-write-region)) "Alist of handler functions for Tramp SUDOEDIT method.") ;; 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) @@ -168,6 +172,12 @@ arguments to pass to the OPERATION." (tramp-register-foreign-file-name-handler #'tramp-sudoedit-file-name-p #'tramp-sudoedit-file-name-handler)) +;; Needed for `tramp-read-passwd'. +(defconst tramp-sudoedit-null-hop + (make-tramp-file-name + :method tramp-sudoedit-method :user (user-login-name) :host tramp-system-name) +"Connection hop which identifies the virtual hop before the first one.") + ;; File name primitives. @@ -233,7 +243,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 +257,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) @@ -362,17 +372,23 @@ the result will be a local, non-Tramp, file name." (setq localname "~")) (unless (file-name-absolute-p localname) (setq localname (format "~%s/%s" user localname))) - (when (string-match "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) + (when (string-match "\\`~\\([^/]*\\)\\(.*\\)\\'" localname) (let ((uname (match-string 1 localname)) - (fname (match-string 2 localname))) - (when (string-equal uname "~") - (setq uname (concat uname user))) - (setq localname (concat uname fname)))) - ;; Do not keep "/..". - (when (string-match-p "^/\\.\\.?$" localname) - (setq localname "/")) + (fname (match-string 2 localname)) + hname) + (when (zerop (length uname)) + (setq uname user)) + (when (setq hname (tramp-get-home-directory v uname)) + (setq localname (concat hname fname))))) + ;; Do not keep "/..". + (when (string-match-p "^/\\.\\.?$" localname) + (setq localname "/")) ;; Do normal `expand-file-name' (this does "~user/", "/./" and "/../"). - (tramp-make-tramp-file-name v (expand-file-name localname)))) + (tramp-make-tramp-file-name + v (if (string-match-p "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) + localname + (tramp-run-real-handler + #'expand-file-name (list localname)))))) (defun tramp-sudoedit-remote-acl-p (vec) "Check, whether ACL is enabled on the remote host." @@ -453,12 +469,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 +551,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" @@ -571,8 +588,7 @@ the result will be a local, non-Tramp, file name." (when (file-remote-p result) (setq result (tramp-compat-file-name-quote result 'top))) (tramp-message v 4 "True name of `%s' is `%s'" localname result) - result)) - 'nohop))))) + result))))))) (defun tramp-sudoedit-handle-file-writable-p (filename) "Like `file-writable-p' for Tramp files." @@ -692,6 +708,13 @@ component is used as the target of the symlink." (tramp-flush-file-property v localname "file-selinux-context")) t))))) +(defun tramp-sudoedit-handle-get-home-directory (vec &optional user) + "The remote home directory for connection VEC as local file name. +If USER is a string, return its home directory instead of the +user identified by VEC. If there is no user specified in either +VEC or USER, or if there is no home directory, return nil." + (expand-file-name (concat "~" (or user (tramp-file-name-user vec))))) + (defun tramp-sudoedit-handle-get-remote-uid (vec id-format) "The uid of the remote connection VEC, in ID-FORMAT. ID-FORMAT valid values are `string' and `integer'." @@ -716,40 +739,6 @@ ID-FORMAT valid values are `string' and `integer'." (or gid (tramp-get-remote-gid v 'integer))) (tramp-unquote-file-local-name filename)))) -(defun tramp-sudoedit-handle-write-region - (start end filename &optional append visit lockname mustbenew) - "Like `write-region' for Tramp files." - (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)) - (tramp-get-remote-uid v 'integer))) - (gid (or (tramp-compat-file-attribute-group-id - (file-attributes filename 'integer)) - (tramp-get-remote-gid v 'integer))) - (flag (and (eq mustbenew 'excl) 'nofollow)) - (modes (tramp-default-file-modes filename flag)) - (attributes (file-extended-attributes filename))) - (prog1 - (tramp-handle-write-region - start end filename append visit lockname mustbenew) - - ;; Set the ownership, modes and extended attributes. This is - ;; not performed in `tramp-handle-write-region'. - (unless (and (= (tramp-compat-file-attribute-user-id - (file-attributes filename 'integer)) - uid) - (= (tramp-compat-file-attribute-group-id - (file-attributes filename 'integer)) - gid)) - (tramp-set-file-uid-gid filename uid gid)) - (tramp-compat-set-file-modes filename modes flag) - ;; We ignore possible errors, because ACL strings could be - ;; incompatible. - (when attributes - (ignore-errors - (set-file-extended-attributes filename attributes))))))) - ;; Internal functions. @@ -827,6 +816,7 @@ in case of error, t otherwise." (process-put p 'vector vec) (process-put p 'adjust-window-size-function #'ignore) (set-process-query-on-exit-flag p nil) + (tramp-set-connection-property p "password-vector" tramp-sudoedit-null-hop) (tramp-process-actions p vec nil tramp-sudoedit-sudo-actions) (tramp-message vec 6 "%s\n%s" (process-exit-status p) (buffer-string)) (prog1 diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 3ee11691395..27c6dfde334 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -238,7 +238,7 @@ pair of the form (KEY VALUE). The following KEYs are defined: unchanged after expansion (i.e. no host, no user or no port were specified), that sublist is not used. For e.g. - '((\"-a\" \"-b\") (\"-l\" \"%u\")) + \\='((\"-a\" \"-b\") (\"-l\" \"%u\")) that means that (\"-l\" \"%u\") is used only if the user was specified, and it is thus effectively optional. @@ -257,6 +257,8 @@ pair of the form (KEY VALUE). The following KEYs are defined: argument if it is supported. - \"%y\" is replaced by the `tramp-scp-force-scp-protocol' argument if it is supported. + - \"%z\" is replaced by the `tramp-scp-direct-remote-copying' + argument if it is supported. The existence of `tramp-login-args', combined with the absence of `tramp-copy-args', is an indication that the @@ -315,14 +317,20 @@ pair of the form (KEY VALUE). The following KEYs are defined: * `tramp-connection-timeout' This is the maximum time to be spent for establishing a connection. In general, the global default value shall be used, but for - some methods, like \"su\" or \"sudo\", a shorter timeout - might be desirable. + some methods, like \"doas\", \"su\" or \"sudo\", a shorter + timeout might be desirable. * `tramp-session-timeout' How long a Tramp connection keeps open before being disconnected. - This is useful for methods like \"su\" or \"sudo\", which + This is useful for methods like \"doas\" or \"sudo\", which shouldn't run an open connection in the background forever. + * `tramp-password-previous-hop' + The password for this connection is the same like the + password for the previous hop. If there is no previous hop, + the password of the local user is applied. This is needed + for methods like \"doas\", \"sudo\" or \"sudoedit\". + * `tramp-case-insensitive' Whether the remote file system handles file names case insensitive. Only a non-nil value counts, the default value nil means to @@ -754,11 +762,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. @@ -825,11 +833,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." @@ -839,9 +846,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 @@ -1391,6 +1398,11 @@ Will be called once the password has been verified by successful authentication.") (put 'tramp-password-save-function 'tramp-suppress-trace t) +(defvar tramp-password-prompt-not-unique nil + "Whether several passwords might be requested. +This shouldn't be set explicitly. It is let-bound, for example +during direct remote copying with scp.") + (defconst tramp-completion-file-name-handler-alist '((file-name-all-completions . tramp-completion-handle-file-name-all-completions) @@ -1412,8 +1424,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. We must autoload it in +;; The basic structure for remote file names. We must autoload it in ;; tramp-loaddefs.el, because some functions, which need it, wouldn't ;; work otherwise when unloading / reloading Tramp. (Bug#50869) ;;;###tramp-autoload @@ -1428,6 +1439,11 @@ calling HANDLER.") (put #'tramp-file-name-localname 'tramp-suppress-trace t) (put #'tramp-file-name-hop 'tramp-suppress-trace t) +;; Needed for `tramp-read-passwd' and `tramp-get-remote-null-device'. +(defconst tramp-null-hop + (make-tramp-file-name :user (user-login-name) :host tramp-system-name) +"Connection hop which identifies the virtual hop before the first one.") + (defun tramp-file-name-user-domain (vec) "Return user and domain components of VEC." (when (or (tramp-file-name-user vec) (tramp-file-name-domain vec)) @@ -1528,7 +1544,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) @@ -1675,6 +1691,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." @@ -1709,13 +1737,10 @@ See `tramp-dissect-file-name' for details." "Construct a Tramp file name from ARGS. ARGS could have two different signatures. The first one is of -type (VEC &optional LOCALNAME HOP). +type (VEC &optional LOCALNAME). If LOCALNAME is nil, the value in VEC is used. If it is a symbol, a null localname will be used. Otherwise, LOCALNAME is expected to be a string, which will be used. -If HOP is nil, the value in VEC is used. If it is a symbol, a -null hop will be used. Otherwise, HOP is expected to be a -string, which will be used. The other signature exists for backward compatibility. It has the form (METHOD USER DOMAIN HOST PORT LOCALNAME &optional HOP)." @@ -1731,8 +1756,13 @@ the form (METHOD USER DOMAIN HOST PORT LOCALNAME &optional HOP)." hop (tramp-file-name-hop (car args))) (when (cadr args) (setq localname (and (stringp (cadr args)) (cadr args)))) - (when (cl-caddr args) - (setq hop (and (stringp (cl-caddr args)) (cl-caddr args))))) + (when hop + (setq hop nil) + ;; Assure that the hops are in `tramp-default-proxies-alist'. + ;; In tramp-archive.el, the slot `hop' is used for the archive + ;; file name. + (unless (string-equal method "archive") + (tramp-add-hops (car args))))) (t (setq method (nth 0 args) user (nth 1 args) @@ -1765,15 +1795,17 @@ the form (METHOD USER DOMAIN HOST PORT LOCALNAME &optional HOP)." localname))) (set-advertised-calling-convention - #'tramp-make-tramp-file-name '(vec &optional localname hop) "27.1") + #'tramp-make-tramp-file-name '(vec &optional localname) "29.1") (defun tramp-make-tramp-hop-name (vec) "Construct a Tramp hop name from VEC." - (replace-regexp-in-string - tramp-prefix-regexp "" + (concat + (tramp-file-name-hop vec) (replace-regexp-in-string - (concat tramp-postfix-host-regexp "$") tramp-postfix-hop-format - (tramp-make-tramp-file-name vec 'noloc)))) + tramp-prefix-regexp "" + (replace-regexp-in-string + (concat tramp-postfix-host-regexp "$") tramp-postfix-hop-format + (tramp-make-tramp-file-name vec 'noloc))))) (defun tramp-completion-make-tramp-file-name (method user host localname) "Construct a Tramp file name from METHOD, USER, HOST and LOCALNAME. @@ -1807,7 +1839,7 @@ Unless DONT-CREATE, the buffer is created when it doesn't exist yet." (tramp-get-connection-property vec "process-buffer" nil)) (setq buffer-undo-list t default-directory - (tramp-make-tramp-file-name vec 'noloc 'nohop)) + (tramp-make-tramp-file-name vec 'noloc)) (current-buffer))))) (defun tramp-get-connection-buffer (vec &optional dont-create) @@ -1845,9 +1877,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) @@ -1858,14 +1888,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)) @@ -1904,29 +1947,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 (min 10 (point-max))) ";; 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) @@ -1988,9 +2057,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) @@ -2060,12 +2127,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)))) @@ -2116,6 +2186,11 @@ FMT-STRING and ARGUMENTS." (put #'tramp-error 'tramp-suppress-trace t) +(defvar tramp-error-show-message-timeout 30 + "Time to show the Tramp buffer in case of an error. +If it is bound to nil, the buffer is not shown. This is used in +tramp-tests.el.") + (defsubst tramp-error-with-buffer (buf vec-or-proc signal fmt-string &rest arguments) "Emit an error, and show BUF. @@ -2127,12 +2202,13 @@ 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. (when (and buf + (natnump tramp-error-show-message-timeout) (not (zerop tramp-verbose)) ;; Do not show when flagged from outside. (not non-essential) @@ -2146,7 +2222,7 @@ an input event arrives. The other arguments are passed to `tramp-error'." ;; Show buffer. (pop-to-buffer buf) (discard-input) - (sit-for 30))) + (sit-for tramp-error-show-message-timeout))) ;; Reset timestamp. It would be wrong after waiting for a while. (when (tramp-file-name-equal-p vec (car tramp-current-connection)) (setcdr tramp-current-connection (current-time))))))) @@ -2159,7 +2235,8 @@ an input event arrives. The other arguments are passed to `tramp-error'." (unwind-protect (apply #'tramp-error vec-or-proc 'user-error fmt-string arguments) ;; Save exit. - (when (and (not (zerop tramp-verbose)) + (when (and (natnump tramp-error-show-message-timeout) + (not (zerop tramp-verbose)) ;; Do not show when flagged from outside. (not non-essential) ;; Show only when Emacs has started already. @@ -2169,7 +2246,7 @@ an input event arrives. The other arguments are passed to `tramp-error'." ;; `tramp-error' does not show messages. So we must do it ourselves. (apply #'message fmt-string arguments) (discard-input) - (sit-for 30) + (sit-for tramp-error-show-message-timeout) ;; Reset timestamp. It would be wrong after waiting for a while. (when (tramp-file-name-equal-p vec-or-proc (car tramp-current-connection)) @@ -2249,8 +2326,6 @@ If VAR is nil, then we bind `v' to the structure and `method', `user', (ignore ,@(mapcar #'car bindings)) ,@body))) -(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-parsed-tramp-file-name\\>")) - (defun tramp-progress-reporter-update (reporter &optional value suffix) "Report progress of an operation for Tramp." (let* ((parameters (cdr reporter)) @@ -2287,9 +2362,6 @@ without a visible progress reporter." (if tm (cancel-timer tm)) (tramp-message ,vec ,level "%s...%s" ,message cookie))))) -(font-lock-add-keywords - 'emacs-lisp-mode '("\\<with-tramp-progress-reporter\\>")) - (defmacro with-tramp-file-property (vec file property &rest body) "Check in Tramp cache for PROPERTY, otherwise execute BODY and set cache. FILE must be a local file name on a connection identified via VEC." @@ -2306,8 +2378,6 @@ FILE must be a local file name on a connection identified via VEC." value) ,@body)) -(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-file-property\\>")) - (defmacro with-tramp-connection-property (key property &rest body) "Check in Tramp for property PROPERTY, otherwise execute BODY and set." (declare (indent 2) (debug t)) @@ -2321,9 +2391,6 @@ FILE must be a local file name on a connection identified via VEC." (tramp-set-connection-property ,key ,property value)) value)) -(font-lock-add-keywords - 'emacs-lisp-mode '("\\<with-tramp-connection-property\\>")) - (defun tramp-drop-volume-letter (name) "Cut off unnecessary drive letter from file NAME. The functions `tramp-*-handle-expand-file-name' call `expand-file-name' @@ -2417,7 +2484,7 @@ For definition of that list see `tramp-set-completion-function'." (defun tramp-default-file-modes (filename &optional flag) "Return file modes of FILENAME as integer. -If optional FLAG is ‘nofollow’, do not follow FILENAME if it is a +If optional FLAG is `nofollow', do not follow FILENAME if it is a symbolic link. If the file modes of FILENAME cannot be determined, return the value of `default-file-modes', without execute permissions." @@ -2486,19 +2553,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. @@ -2511,8 +2576,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 @@ -2543,32 +2606,43 @@ 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)) + exec-path make-process + ;; Emacs 29+ only. + list-system-processes process-attributes)) 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)) + ((member operation + '(tramp-get-home-directory + tramp-get-remote-gid tramp-get-remote-uid)) (tramp-make-tramp-file-name (nth 0 args))) ;; Unknown file primitive. (t (error "Unknown file I/O primitive: %s" operation)))) -(defun tramp-find-foreign-file-name-handler (filename &optional _operation) +(defun tramp-find-foreign-file-name-handler (vec &optional _operation) "Return foreign file name handler if exists." - (when (tramp-tramp-file-p filename) + (when (tramp-file-name-p vec) (let ((handler tramp-foreign-file-name-handler-alist) - elt res) + 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))) @@ -2587,7 +2661,7 @@ Fall back to normal file name handler if no Tramp file name handler exists." (with-parsed-tramp-file-name filename nil (let ((current-connection tramp-current-connection) (foreign - (tramp-find-foreign-file-name-handler filename operation)) + (tramp-find-foreign-file-name-handler v operation)) (signal-hook-function #'tramp-signal-hook-function) result) ;; Set `tramp-current-connection'. @@ -2771,8 +2845,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. @@ -2824,18 +2899,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. @@ -3285,6 +3356,129 @@ User is always nil." (forward-line 1) result)) +;;; Skeleton macros for file name handler functions. + +(defmacro tramp-skeleton-delete-directory (directory recursive trash &rest body) + "Skeleton for `tramp-*-handle-delete-directory'. +BODY is the backend specific code." + (declare (indent 3) (debug t)) + `(with-parsed-tramp-file-name (expand-file-name ,directory) nil + (if (and delete-by-moving-to-trash ,trash) + ;; Move non-empty dir to trash only if recursive deletion was + ;; requested. + (if (not (or ,recursive (tramp-compat-directory-empty-p ,directory))) + (tramp-error + v 'file-error "Directory is not empty, not moving to trash") + (move-file-to-trash ,directory)) + ,@body) + (tramp-flush-directory-properties v localname))) + +(put #'tramp-skeleton-delete-directory 'tramp-suppress-trace t) + +(defmacro tramp-skeleton-write-region + (start end filename append visit lockname mustbenew &rest body) + "Skeleton for `tramp-*-handle-write-region'. +BODY is the backend specific code." + (declare (indent 7) (debug t)) + ;; Sometimes, there is another file name handler responsible for + ;; VISIT, for example `jka-compr-handler'. We must respect this. + ;; See Bug#55166. + `(let* ((filename (expand-file-name ,filename)) + (lockname (file-truename (or ,lockname filename))) + (handler (and (stringp ,visit) + (let ((inhibit-file-name-handlers + `(tramp-file-name-handler + tramp-crypt-file-name-handler + . inhibit-file-name-handlers)) + (inhibit-file-name-operation 'write-region)) + (find-file-name-handler ,visit 'write-region))))) + (with-parsed-tramp-file-name filename nil + (if handler + (progn + (tramp-message + v 5 "Calling handler `%s' for visiting `%s'" handler ,visit) + (funcall + handler 'write-region + ,start ,end filename ,append ,visit lockname ,mustbenew)) + + (when (and ,mustbenew (file-exists-p filename) + (or (eq ,mustbenew 'excl) + (not + (y-or-n-p + (format + "File %s exists; overwrite anyway?" filename))))) + (tramp-error v 'file-already-exists filename)) + + (let ((file-locked (eq (file-locked-p lockname) t)) + (uid (or (file-attribute-user-id + (file-attributes filename 'integer)) + (tramp-get-remote-uid v 'integer))) + (gid (or (file-attribute-group-id + (file-attributes filename 'integer)) + (tramp-get-remote-gid v 'integer))) + (attributes (file-extended-attributes filename)) + (curbuf (current-buffer))) + + ;; Lock file. + (when (and (not (auto-save-file-name-p + (file-name-nondirectory filename))) + (file-remote-p lockname) + (not file-locked)) + (setq file-locked t) + ;; `lock-file' exists since Emacs 28.1. + (tramp-compat-funcall 'lock-file lockname)) + + ;; The body. + ,@body + + ;; We must also flush the cache of the directory, because + ;; `file-attributes' reads the values from there. + (tramp-flush-file-properties v localname) + + ;; We must protect `last-coding-system-used', now we have + ;; set it to its correct value. + (let (last-coding-system-used (need-chown t)) + ;; Set file modification time. + (when (or (eq ,visit t) (stringp ,visit)) + (when-let ((file-attr (file-attributes filename 'integer))) + (set-visited-file-modtime + ;; We must pass modtime explicitly, because FILENAME + ;; can be different from (buffer-file-name), f.e. if + ;; `file-precious-flag' is set. + (or (file-attribute-modification-time file-attr) + (current-time))) + (unless (and (= (file-attribute-user-id file-attr) uid) + (= (file-attribute-group-id file-attr) gid)) + (setq need-chown nil)))) + + ;; Set the ownership. + (when need-chown + (tramp-set-file-uid-gid filename uid gid))) + + ;; Set extended attributes. We ignore possible errors, + ;; because ACL strings could be incompatible. + (when attributes + (ignore-errors + (set-file-extended-attributes filename attributes))) + + ;; Unlock file. + (when file-locked + ;; `unlock-file' exists since Emacs 28.1. + (tramp-compat-funcall 'unlock-file lockname)) + + ;; Sanity check. + (unless (equal curbuf (current-buffer)) + (tramp-error + v 'file-error + "Buffer has changed from `%s' to `%s'" curbuf (current-buffer))) + + (when (and (null noninteractive) + (or (eq ,visit t) (string-or-null-p ,visit))) + (tramp-message v 0 "Wrote %s" filename)) + (run-hooks 'tramp-handle-write-region-hook)))))) + +(put #'tramp-skeleton-write-region 'tramp-suppress-trace t) + ;;; Common file name handler functions for different backends: (defvar tramp-handle-file-local-copy-hook nil @@ -3293,6 +3487,42 @@ User is always nil." (defvar tramp-handle-write-region-hook nil "Normal hook to be run at the end of `tramp-*-handle-write-region'.") +(defvar tramp-tolerate-tilde nil + "Indicator, that not expandable tilde shall be tolerated. +Let-bind it when necessary.") + +;; `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)) + (tramp-tolerate-tilde t) + (home-dir + (if (let ((non-essential t)) (tramp-connectable-p vec)) + ;; If a connection has already been established, get the + ;; home directory. + (tramp-get-home-directory vec) + ;; Otherwise, just use the cached value. + (tramp-get-connection-property vec "~" nil)))) + (when home-dir + (setq home-dir + (tramp-compat-funcall + 'directory-abbrev-apply + (tramp-make-tramp-file-name vec home-dir)))) + ;; 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 (and home-dir + (string-match + (tramp-compat-funcall 'directory-abbrev-make-regexp home-dir) + filename)) + (tramp-make-tramp-file-name + vec (concat "~" (substring filename (match-beginning 1)))) + (tramp-make-tramp-file-name (tramp-dissect-file-name filename))))) + (defun tramp-handle-access-file (filename string) "Like `access-file' for Tramp files." (setq filename (file-truename filename)) @@ -3303,10 +3533,11 @@ User is always nil." (if (file-directory-p filename) #'file-accessible-directory-p #'file-readable-p) 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-compat-permission-denied + v (format "%s: Permission denied, %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) @@ -3340,7 +3571,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 @@ -3361,7 +3592,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))) @@ -3393,10 +3624,6 @@ User is always nil." (if (file-directory-p dir) dir (file-name-directory dir)) nil (tramp-flush-directory-properties v localname))) -(defvar tramp-tolerate-tilde nil - "Indicator, that not expandable tilde shall be tolerated. -Let-bind it when necessary.") - (defun tramp-handle-expand-file-name (name &optional dir) "Like `expand-file-name' for Tramp files." ;; If DIR is not given, use DEFAULT-DIRECTORY or "/". @@ -3413,6 +3640,17 @@ Let-bind it when necessary.") (with-parsed-tramp-file-name name nil (unless (tramp-run-real-handler #'file-name-absolute-p (list localname)) (setq localname (concat "/" localname))) + ;; Expand tilde. Usually, the methods applying this handler do + ;; not support tilde expansion. But users could declare a + ;; respective connection property. (Bug#53847) + (when (string-match "\\`~\\([^/]*\\)\\(.*\\)\\'" localname) + (let ((uname (match-string 1 localname)) + (fname (match-string 2 localname)) + hname) + (when (zerop (length uname)) + (setq uname user)) + (when (setq hname (tramp-get-home-directory v uname)) + (setq localname (concat hname fname))))) ;; Tilde expansion is not possible. (when (and (not tramp-tolerate-tilde) (string-match-p "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname)) @@ -3437,9 +3675,7 @@ Let-bind it when necessary.") (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." @@ -3471,7 +3707,7 @@ Let-bind it when necessary.") "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))) @@ -3479,7 +3715,7 @@ Let-bind it when necessary.") (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)))) @@ -3511,7 +3747,7 @@ Let-bind it when necessary.") (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" @@ -3532,16 +3768,13 @@ Let-bind it when necessary.") (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. @@ -3602,9 +3835,8 @@ Let-bind it when necessary.") ((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." @@ -3623,15 +3855,15 @@ Let-bind it when necessary.") ;; 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." ;; We do not want traces in the debug buffer. (let ((tramp-verbose (min tramp-verbose 3))) (when (tramp-tramp-file-p filename) - (let* ((v (tramp-dissect-file-name filename)) - (p (tramp-get-connection-process v)) + (let* ((o (tramp-dissect-file-name filename)) + (p (tramp-get-connection-process o)) (c (and (process-live-p p) (tramp-get-connection-property p "connected" nil)))) ;; We expand the file name only, if there is already a connection. @@ -3645,7 +3877,8 @@ Let-bind it when necessary.") ((eq identification 'user) (tramp-file-name-user-domain v)) ((eq identification 'host) (tramp-file-name-host-port v)) ((eq identification 'localname) localname) - ((eq identification 'hop) hop) + ;; Hop exists only in original dissected file name. + ((eq identification 'hop) (tramp-file-name-hop o)) (t (tramp-make-tramp-file-name v 'noloc))))))))) (defun tramp-handle-file-selinux-context (_filename) @@ -3655,7 +3888,7 @@ Let-bind it when necessary.") (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) @@ -3696,8 +3929,7 @@ Let-bind it when necessary.") (expand-file-name symlink-target (file-name-directory v2-localname)))) - v2-localname) - 'nohop))) + v2-localname)))) (when (>= numchase numchase-limit) (tramp-error v1 'file-error @@ -3744,7 +3976,7 @@ Let-bind it when necessary.") (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 @@ -3801,7 +4033,7 @@ Let-bind it when necessary.") (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) @@ -3856,8 +4088,7 @@ Let-bind it when necessary.") (cond ((stringp remote-copy) (file-local-copy - (tramp-make-tramp-file-name - v remote-copy 'nohop))) + (tramp-make-tramp-file-name v remote-copy))) ((stringp tramp-temp-buffer-file-name) (copy-file filename tramp-temp-buffer-file-name 'ok) @@ -3900,11 +4131,162 @@ Let-bind it when necessary.") (or remote-copy (null tramp-temp-buffer-file-name))) (delete-file local-copy)) (when (stringp remote-copy) - (delete-file (tramp-make-tramp-file-name v remote-copy 'nohop)))) + (delete-file (tramp-make-tramp-file-name v remote-copy)))) ;; Result. (cons filename (cdr result))))) +(defun tramp-ps-time () + "Read printed time oif \"ps\" in format \"[[DD-]hh:]mm:ss\". +Return it as number of seconds. Used in `tramp-process-attributes-ps-format'." + (search-forward-regexp "\\s-+") + (search-forward-regexp + (concat + "\\(?:" "\\(?:" "\\([0-9]+\\)-" "\\)?" + "\\([0-9]+\\):" "\\)?" + "\\([0-9]+\\):" + ;; Seconds can also be a floating point number. + "\\([0-9.]+\\)") + (line-end-position) 'noerror) + (+ (* 24 60 60 (string-to-number (or (match-string 1) "0"))) + (* 60 60 (string-to-number (or (match-string 2) "0"))) + (* 60 (string-to-number (or (match-string 3) "0"))) + (string-to-number (or (match-string 4) "0")))) + +(defconst tramp-process-attributes-ps-args + `("-eww" + "-o" + ,(mapconcat + #'identity + '("pid" + "euid" + "euser" + "egid" + "egroup" + "comm:80" + "state" + "ppid" + "pgrp" + "sess" + "tname" + "tpgid" + "min_flt" + "maj_flt" + "times" + "pri" + "nice" + "thcount" + "vsize" + "rss" + "etimes" + "pcpu" + "pmem" + "args") + ",")) + "List of arguments for calling \"ps\". +See `tramp-get-process-attributes'. + +This list is the default value on remote GNU/Linux systems.") + +(defconst tramp-process-attributes-ps-format + '((pid . number) + (euid . number) + (user . string) + (egid . number) + (group . string) + (comm . 80) + (state . string) + (ppid . number) + (pgrp . number) + (sess . number) + (ttname . string) + (tpgid . number) + (minflt . number) + (majflt . number) + (time . number) + (pri . number) + (nice . number) + (thcount . number) + (vsize . number) + (rss . number) + (etime . number) + (pcpu . number) + (pmem . number) + (args . nil)) + "Alist where each element is a cons cell of the form `\(KEY . TYPE)'. +KEY is a key (symbol) used in `process-attributes'. TYPE is the +printed result for KEY of the \"ps\" command, it can be `number', +`string', a number (string of that length), a symbol (a function +to be applied), or nil (for the last column of the \"ps\" output. + +This alist is used to parse the output of calling \"ps\" in +`tramp-get-process-attributes'. + +This alist is the default value on remote GNU/Linux systems.") + +(defun tramp-get-process-attributes (vec) + "Return all process attributes for connection VEC. +Parsing the remote \"ps\" output is controlled by +`tramp-process-attributes-ps-args' and +`tramp-process-attributes-ps-format'. + +It is not guaranteed, that all process attributes as described in +`process-attributes' are returned. The additional attribute +`pid' shall be returned always." + ;; Since Emacs 27.1. + (when (fboundp 'connection-local-criteria-for-default-directory) + (with-tramp-file-property vec "/" "process-attributes" + (ignore-errors + (with-temp-buffer + (hack-connection-local-variables-apply + (connection-local-criteria-for-default-directory)) + ;; (pop-to-buffer (current-buffer)) + (when (zerop + (apply + #'process-file + "ps" nil t nil tramp-process-attributes-ps-args)) + (let (result res) + (goto-char (point-min)) + (while (not (eobp)) + ;; (tramp-test-message + ;; "%s" (buffer-substring (point) (line-end-position))) + (when (save-excursion + (search-forward-regexp + "[[:digit:]]" (line-end-position) 'noerror)) + (setq res nil) + (dolist (elt tramp-process-attributes-ps-format) + (push + (cons + (car elt) + (cond + ((eq (cdr elt) 'number) (read (current-buffer))) + ((eq (cdr elt) 'string) + (search-forward-regexp "\\S-+") + (match-string 0)) + ((numberp (cdr elt)) + (search-forward-regexp "\\s-+") + (search-forward-regexp ".+" (+ (point) (cdr elt))) + (string-trim (match-string 0))) + ((fboundp (cdr elt)) + (funcall (cdr elt))) + ((null (cdr elt)) + (search-forward-regexp "\\s-+") + (buffer-substring (point) (line-end-position))) + (t nil))) + res)) + ;; `nice' could be `-'. + (setq res (rassq-delete-all '- res)) + (push (append res) result)) + (forward-line)) + ;; Return result. + result))))))) + +(defun tramp-handle-list-system-processes () + "Like `list-system-processes' for Tramp files." + (let ((v (tramp-dissect-file-name default-directory))) + (tramp-flush-file-property v "/" "process-attributes") + (mapcar (lambda (x) (cdr (assq 'pid x))) (tramp-get-process-attributes v)))) + (defun tramp-get-lock-file (file) "Read lockfile info of FILE. Return nil when there is no lockfile." @@ -3979,7 +4361,7 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.") (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 @@ -3997,7 +4379,7 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.") (make-symbolic-link info lockname 'ok-if-already-exists) (error (with-file-modes #o0644 - (write-region info nil lockname))))))))) + (write-region info nil lockname nil 'no-message))))))))) (defun tramp-handle-make-lock-file-name (file) "Like `make-lock-file-name' for Tramp files." @@ -4031,7 +4413,7 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.") 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)) @@ -4048,15 +4430,10 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.") (and (tramp-sh-file-name-handler-p vec) (not (tramp-get-method-parameter vec 'tramp-copy-program)))) -(defun tramp-compute-multi-hops (vec) - "Expands VEC according to `tramp-default-proxies-alist'." - (let ((saved-tdpa tramp-default-proxies-alist) - (target-alist `(,vec)) - (hops (or (tramp-file-name-hop vec) "")) - (item vec) - choices proxy) - - ;; Ad-hoc proxy definitions. +(defun tramp-add-hops (vec) + "Add ad-hoc proxy definitions to `tramp-default-proxies-alist'." + (when-let ((hops (tramp-file-name-hop vec)) + (item vec)) (dolist (proxy (reverse (split-string hops tramp-postfix-hop-regexp 'omit))) (let* ((host-port (tramp-file-name-host-port item)) (user-domain (tramp-file-name-user-domain item)) @@ -4073,9 +4450,19 @@ Do not set it manually, it is used buffer-local in `tramp-get-lock-pid'.") (add-to-list 'tramp-default-proxies-alist entry) (setq item (tramp-dissect-file-name proxy)))) ;; Save the new value. - (when (and hops tramp-save-ad-hoc-proxies) + (when tramp-save-ad-hoc-proxies (customize-save-variable - 'tramp-default-proxies-alist tramp-default-proxies-alist)) + 'tramp-default-proxies-alist tramp-default-proxies-alist)))) + +(defun tramp-compute-multi-hops (vec) + "Expands VEC according to `tramp-default-proxies-alist'." + (let ((saved-tdpa tramp-default-proxies-alist) + (target-alist `(,vec)) + (item vec) + choices proxy) + + ;; Ad-hoc proxy definitions. + (tramp-add-hops vec) ;; Look for proxy hosts to be passed. (setq choices tramp-default-proxies-alist) @@ -4215,6 +4602,7 @@ substitution. SPEC-LIST is a list of char/value pairs used for (get-buffer-create buffer) ;; BUFFER can be nil. We use a temporary buffer. (generate-new-buffer tramp-temp-buffer-name))) + (orig-command command) (env (mapcar (lambda (elt) (when (tramp-compat-string-search "=" elt) elt)) @@ -4290,23 +4678,28 @@ substitution. SPEC-LIST is a list of char/value pairs used for ;; t. See Bug#51177. (when filter (set-process-filter p filter)) + (process-put p 'remote-command orig-command) + (tramp-set-connection-property p "remote-command" orig-command) (tramp-message v 6 "%s" (string-join (process-command p) " ")) 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-process-attributes (pid) + "Like `process-attributes' for Tramp files." + (catch 'result + (dolist (elt (tramp-get-process-attributes + (tramp-dissect-file-name default-directory))) + (when (= (cdr (assq 'pid elt)) pid) + (throw 'result elt))))) (defun tramp-handle-shell-command (command &optional output-buffer error-buffer) "Like `shell-command' for Tramp files." @@ -4521,7 +4914,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) @@ -4545,7 +4938,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 @@ -4562,35 +4955,10 @@ of." (defun tramp-handle-write-region (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." - (setq filename (expand-file-name filename) - lockname (file-truename (or lockname filename))) - (with-parsed-tramp-file-name filename nil - (when (and mustbenew (file-exists-p filename) - (or (eq mustbenew 'excl) - (not - (y-or-n-p - (format "File %s exists; overwrite anyway?" filename))))) - (tramp-error v 'file-already-exists filename)) - - (let ((file-locked (eq (file-locked-p lockname) t)) - (tmpfile (tramp-compat-make-temp-file filename)) + (tramp-skeleton-write-region start end filename append visit lockname mustbenew + (let ((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)) - (tramp-get-remote-uid v 'integer))) - (gid (or (tramp-compat-file-attribute-group-id - (file-attributes filename 'integer)) - (tramp-get-remote-gid v 'integer)))) - - ;; Lock file. - (when (and (not (auto-save-file-name-p (file-name-nondirectory filename))) - (file-remote-p lockname) - (not file-locked)) - (setq file-locked t) - ;; `lock-file' exists since Emacs 28.1. - (tramp-compat-funcall 'lock-file lockname)) - + filename (and (eq mustbenew 'excl) 'nofollow)))) (when (and append (file-exists-p filename)) (copy-file filename tmpfile 'ok)) ;; The permissions of the temporary file should be set. If @@ -4609,30 +4977,7 @@ of." (error (delete-file tmpfile) (tramp-error - v 'file-error "Couldn't write region to `%s'" filename))) - - (tramp-flush-file-properties v localname) - - ;; 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)) - (current-time)))) - - ;; Set the ownership. - (tramp-set-file-uid-gid filename uid gid) - - ;; Unlock file. - (when file-locked - ;; `unlock-file' exists since Emacs 28.1. - (tramp-compat-funcall 'unlock-file lockname)) - - ;; The end. - (when (and (null noninteractive) - (or (eq visit t) (string-or-null-p visit))) - (tramp-message v 0 "Wrote %s" filename)) - (run-hooks 'tramp-handle-write-region-hook)))) + v 'file-error "Couldn't write region to `%s'" filename)))))) ;; This is used in tramp-sh.el and tramp-sudoedit.el. (defconst tramp-stat-marker "/////" @@ -4698,8 +5043,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) @@ -4711,7 +5056,9 @@ of." ;; Let's check whether a wrong password has been sent already. ;; Sometimes, the process returns a new password request ;; immediately after rejecting the previous (wrong) one. - (unless (tramp-get-connection-property vec "first-password-request" nil) + (unless (or tramp-password-prompt-not-unique + (tramp-get-connection-property + vec "first-password-request" nil)) (tramp-clear-passwd vec)) (goto-char (point-min)) (tramp-check-for-regexp proc tramp-process-action-regexp) @@ -4719,7 +5066,13 @@ of." ;; We don't call `tramp-send-string' in order to hide the ;; password from the debug buffer and the traces. (process-send-string - proc (concat (tramp-read-passwd proc) tramp-local-end-of-line)) + proc + (concat + (funcall + (if tramp-password-prompt-not-unique + #'tramp-read-passwd-without-cache #'tramp-read-passwd) + proc) + tramp-local-end-of-line)) ;; Hide password prompt. (narrow-to-region (point-max) (point-max)))) t) @@ -4742,8 +5095,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) @@ -4756,8 +5109,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) @@ -4765,15 +5118,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) @@ -4961,9 +5314,6 @@ Mostly useful to protect BODY from being interrupted by timers." ,@body) (tramp-flush-connection-property ,proc "locked")))) -(font-lock-add-keywords - 'emacs-lisp-mode '("\\<with-tramp-locked-connection\\>")) - (defun tramp-accept-process-output (proc &optional timeout) "Like `accept-process-output' for Tramp processes. This is needed in order to hide `last-coding-system-used', which is set @@ -5062,8 +5412,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 @@ -5285,10 +5635,12 @@ 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) + (if (tramp-tramp-file-p filename) + (funcall (if (tramp-crypt-file-name-p filename) + #'tramp-crypt-file-name-handler #'tramp-file-name-handler) + #'tramp-set-file-uid-gid filename uid gid) ;; On W32 systems, "chown" does not work. (unless (memq system-type '(ms-dos windows-nt)) (let ((uid (or (and (natnump uid) uid) (tramp-get-local-uid 'integer))) @@ -5314,8 +5666,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. @@ -5371,43 +5722,38 @@ 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)) + (eq access (aref (file-attribute-modes file-attr) offset)) (or (equal remote-uid unknown-id) - (equal remote-uid - (tramp-compat-file-attribute-user-id file-attr)) - (equal unknown-id - (tramp-compat-file-attribute-user-id file-attr)))) + (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))) + (aref (file-attribute-modes file-attr) (+ offset 3))) (or (equal remote-gid unknown-id) - (equal remote-gid - (tramp-compat-file-attribute-group-id file-attr)) - (equal unknown-id - (tramp-compat-file-attribute-group-id - file-attr)))))))))))) + (equal remote-gid (file-attribute-group-id file-attr)) + (equal unknown-id (file-attribute-group-id file-attr)))))))))))) + +(defun tramp-get-home-directory (vec &optional user) + "The remote home directory for connection VEC as local file name. +If USER is a string, return its home directory instead of the +user identified by VEC. If there is no user specified in either +VEC or USER, or if there is no home directory, return nil." + (with-tramp-connection-property vec (concat "~" user) + (tramp-file-name-handler #'tramp-get-home-directory vec user))) (defun tramp-get-remote-uid (vec id-format) "The uid of the remote connection VEC, in ID-FORMAT. ID-FORMAT valid values are `string' and `integer'." (with-tramp-connection-property vec (format "uid-%s" id-format) - (or (when-let - ((handler - (find-file-name-handler - (tramp-make-tramp-file-name vec) 'tramp-get-remote-uid))) - (funcall handler #'tramp-get-remote-uid vec id-format)) + (or (tramp-file-name-handler #'tramp-get-remote-uid vec id-format) ;; Ensure there is a valid result. (and (equal id-format 'integer) tramp-unknown-id-integer) (and (equal id-format 'string) tramp-unknown-id-string)))) @@ -5416,11 +5762,7 @@ ID-FORMAT valid values are `string' and `integer'." "The gid of the remote connection VEC, in ID-FORMAT. ID-FORMAT valid values are `string' and `integer'." (with-tramp-connection-property vec (format "gid-%s" id-format) - (or (when-let - ((handler - (find-file-name-handler - (tramp-make-tramp-file-name vec) 'tramp-get-remote-gid))) - (funcall handler #'tramp-get-remote-gid vec id-format)) + (or (tramp-file-name-handler #'tramp-get-remote-gid vec id-format) ;; Ensure there is a valid result. (and (equal id-format 'integer) tramp-unknown-id-integer) (and (equal id-format 'string) tramp-unknown-id-string)))) @@ -5443,8 +5785,7 @@ This handles also chrooted environments, which are not regarded as local." (null tramp-crypt-enabled) ;; The local temp directory must be writable for the other user. (file-writable-p - (tramp-make-tramp-file-name - vec tramp-compat-temporary-file-directory 'nohop)) + (tramp-make-tramp-file-name vec tramp-compat-temporary-file-directory)) ;; On some systems, chown runs only for root. (or (zerop (user-uid)) (zerop (tramp-get-remote-uid vec 'integer)))))) @@ -5538,7 +5879,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 @@ -5574,8 +5915,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: @@ -5598,14 +5938,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))) @@ -5636,10 +5974,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)))) @@ -5684,20 +6022,22 @@ verbosity of 6." ;; tramp-cache-read-persistent-data t)'" instead. (defun tramp-read-passwd (proc &optional prompt) "Read a password from user (compat function). -Consults the auth-source package. -Invokes `password-read' if available, `read-passwd' else." +Consults the auth-source package." (let* (;; If `auth-sources' contains "~/.authinfo.gpg", and ;; `exec-path' contains a relative file name like ".", it ;; could happen that the "gpg" command is not found. So we ;; adapt `default-directory'. (Bug#39389, Bug#39489) (default-directory tramp-compat-temporary-file-directory) (case-fold-search t) - (key (tramp-make-tramp-file-name - ;; In tramp-sh.el, we must use "password-vector" due to - ;; multi-hop. - (tramp-get-connection-property - proc "password-vector" (process-get proc 'vector)) - 'noloc 'nohop)) + ;; In tramp-sh.el, we must use "password-vector" due to + ;; multi-hop. + (vec (tramp-get-connection-property + proc "password-vector" (process-get proc 'vector))) + (key (tramp-make-tramp-file-name vec 'noloc)) + (method (tramp-file-name-method vec)) + (user (or (tramp-file-name-user-domain vec) + (tramp-get-connection-property key "login-as" nil))) + (host (tramp-file-name-host-port vec)) (pw-prompt (or prompt (with-current-buffer (process-buffer proc) @@ -5707,68 +6047,67 @@ 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) (unwind-protect - (with-parsed-tramp-file-name key nil - (setq tramp-password-save-function nil - user - (or user (tramp-get-connection-property key "login-as" nil))) - (prog1 - (or - ;; See if auth-sources contains something useful. - (ignore-errors - (and (tramp-get-connection-property - v "first-password-request" nil) - ;; Try with Tramp's current method. - (setq auth-info - (car - (auth-source-search - :max 1 - (and user :user) - (if domain - (concat - user tramp-prefix-domain-format domain) - user) - :host - (if port - (concat - host tramp-prefix-port-format port) - host) - :port method - :require (cons :secret (and user '(:user))) - :create t)) - tramp-password-save-function - (plist-get auth-info :save-function) - auth-passwd (plist-get auth-info :secret))) - (while (functionp auth-passwd) - (setq auth-passwd (funcall auth-passwd))) - auth-passwd) - - ;; Try the password cache. Exists since Emacs 26.1. - (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)) + ;; We cannot use `with-parsed-tramp-file-name', because it + ;; expands the file name. + (or + (setq tramp-password-save-function nil) + ;; See if auth-sources contains something useful. + (ignore-errors + (and (tramp-get-connection-property + vec "first-password-request" nil) + ;; Try with Tramp's current method. If there is no + ;; user name, `:create' triggers to ask for. We + ;; suppress it. + (setq auth-info + (car + (auth-source-search + :max 1 :user user :host host :port method + :require (cons :secret (and user '(:user))) + :create (and user t))) + tramp-password-save-function + (plist-get auth-info :save-function) + auth-passwd + (tramp-compat-auth-info-password auth-info)))) + + ;; 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)) - ;; Workaround. Prior Emacs 28.1, auth-source has saved - ;; empty passwords. See discussion in Bug#50399. - (when (zerop (length auth-passwd)) - (setq tramp-password-save-function nil)) - (tramp-set-connection-property v "first-password-request" nil))) + ;; Workaround. Prior Emacs 28.1, auth-source has saved empty + ;; passwords. See discussion in Bug#50399. + (when (zerop (length auth-passwd)) + (setq tramp-password-save-function nil)) + (tramp-set-connection-property vec "first-password-request" nil) ;; Reenable the timers. (with-timeout-unsuspend stimers)))) (put #'tramp-read-passwd 'tramp-suppress-trace t) +(defun tramp-read-passwd-without-cache (proc &optional prompt) + "Read a password from user (compat function)." + ;; We suspend the timers while reading the password. + (let ((stimers (with-timeout-suspend))) + (unwind-protect + (password-read + (or prompt + (with-current-buffer (process-buffer proc) + (tramp-check-for-regexp proc tramp-password-prompt-regexp) + (match-string 0)))) + ;; Reenable the timers. + (with-timeout-unsuspend stimers)))) + +(put #'tramp-read-passwd-without-cache 'tramp-suppress-trace t) + (defun tramp-clear-passwd (vec) "Clear password cache for connection related to VEC." (let ((method (tramp-file-name-method vec)) @@ -5781,7 +6120,7 @@ Invokes `password-read' if available, `read-passwd' else." (auth-source-forget `(:max 1 ,(and user-domain :user) ,user-domain :host ,host-port :port ,method)) - (password-cache-remove (tramp-make-tramp-file-name vec 'noloc 'nohop)))) + (password-cache-remove (tramp-make-tramp-file-name vec 'noloc)))) (put #'tramp-clear-passwd 'tramp-suppress-trace t) @@ -5868,40 +6207,60 @@ 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 'interrupt-process-functions #'tramp-interrupt-process) +(add-hook + 'tramp-unload-hook + (lambda () + (remove-hook 'interrupt-process-functions #'tramp-interrupt-process))) + +(defun tramp-signal-process (process sigcode &optional remote) + "Send PROCESS the signal with code SIGCODE. +PROCESS may also be a number specifying the process id of the +process to signal; in this case, the process need not be a child of +this Emacs. +If PROCESS is a process object which contains the property +`remote-pid', or PROCESS is a number and REMOTE is a remote file name, +PROCESS is interpreted as process on the respective remote host, which +will be the process to signal. +SIGCODE may be an integer, or a symbol whose name is a signal name." + (let (pid vec) + (cond + ((processp process) + (setq pid (process-get process 'remote-pid) + vec (process-get process 'vector))) + ((numberp process) + (setq pid process + vec (and (stringp remote) (tramp-dissect-file-name remote)))) + (t (signal 'wrong-type-argument (list #'processp process)))) + (unless (or (numberp sigcode) (symbolp sigcode)) + (signal 'wrong-type-argument (list #'numberp sigcode))) + ;; If it's a Tramp process, send SIGCODE remotely. + (when (and pid vec) + (tramp-message + vec 5 "Send signal %s to process %s with pid %s" sigcode process pid) + ;; This is for tramp-sh.el. Other backends do not support this (yet). + (if (tramp-compat-funcall + 'tramp-send-command-and-check + vec (format "\\kill -%s %d" sigcode pid)) + 0 -1)))) + +;; `signal-process-functions' exists since Emacs 29.1. +(when (boundp 'signal-process-functions) + (add-hook 'signal-process-functions #'tramp-signal-process) (add-hook 'tramp-unload-hook (lambda () - (remove-hook 'interrupt-process-functions #'tramp-interrupt-process)))) + (remove-hook 'signal-process-functions #'tramp-signal-process)))) (defun tramp-get-remote-null-device (vec) "Return null device on the remote host identified by VEC. -If VEC is nil, return local null device." - (if (null vec) +If VEC is `tramp-null-hop', return local null device." + (if (equal vec tramp-null-hop) null-device (with-tramp-connection-property vec "null-device" (let ((default-directory (tramp-make-tramp-file-name vec))) (tramp-compat-null-device))))) -(defmacro tramp-skeleton-delete-directory (directory recursive trash &rest body) - "Skeleton for `tramp-*-handle-delete-directory'. -BODY is the backend specific code." - (declare (indent 3) (debug t)) - `(with-parsed-tramp-file-name (expand-file-name ,directory) nil - (if (and delete-by-moving-to-trash ,trash) - ;; Move non-empty dir to trash only if recursive deletion was - ;; requested. - (if (not (or ,recursive (tramp-compat-directory-empty-p ,directory))) - (tramp-error - v 'file-error "Directory is not empty, not moving to trash") - (move-file-to-trash ,directory)) - ,@body) - (tramp-flush-directory-properties v localname))) - -(put #'tramp-skeleton-delete-directory 'tramp-suppress-trace t) - ;; Checklist for `tramp-unload-hook' ;; - Unload all `tramp-*' packages ;; - Reset `file-name-handler-alist' @@ -5940,5 +6299,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 9c04abc8289..e3bcd568d72 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.3-pre -;; 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.3-pre" +(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.3-pre 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/net/webjump.el b/lisp/net/webjump.el index 21c6f5dd9d0..b2ef47898cd 100644 --- a/lisp/net/webjump.el +++ b/lisp/net/webjump.el @@ -61,6 +61,13 @@ ;;; Code: +;; TODO: +;; - Add a menu bar and tool bar for this library. +;; - Add commands to create/delete link from the hotlist. +;; - Add something like a bookmark folder in modern browsers. +;; - Add a command that can open/follow all links in a folder. +;; - Add tags for Web sites in the hotlist. + ;;-------------------------------------------------------- Package Dependencies (require 'browse-url) diff --git a/lisp/newcomment.el b/lisp/newcomment.el index 95adf9f90a1..385dd80beba 100644 --- a/lisp/newcomment.el +++ b/lisp/newcomment.el @@ -1235,33 +1235,21 @@ changed with `comment-style'." ;; FIXME: maybe we should call uncomment depending on ARG. (funcall comment-region-function beg end arg))) -(defun comment-region-default-1 (beg end &optional arg noadjust) - "Comment region between BEG and END. -See `comment-region' for ARG. If NOADJUST, do not skip past -leading/trailing space when determining the region to comment -out." +(defun comment-region-default-1 (beg end &optional arg) (let* ((numarg (prefix-numeric-value arg)) (style (cdr (assoc comment-style comment-styles))) (lines (nth 2 style)) (block (nth 1 style)) (multi (nth 0 style))) - (if noadjust - (when (bolp) - (setq end (1- end))) - ;; We use `chars' instead of `syntax' because `\n' might be - ;; of end-comment syntax rather than of whitespace syntax. - ;; sanitize BEG and END - (goto-char beg) - (skip-chars-forward " \t\n\r") - (beginning-of-line) - (setq beg (max beg (point))) - (goto-char end) - (skip-chars-backward " \t\n\r") - (end-of-line) - (setq end (min end (point))) - (when (>= beg end) - (error "Nothing to comment"))) + ;; We use `chars' instead of `syntax' because `\n' might be + ;; of end-comment syntax rather than of whitespace syntax. + ;; sanitize BEG and END + (goto-char beg) (skip-chars-forward " \t\n\r") (beginning-of-line) + (setq beg (max beg (point))) + (goto-char end) (skip-chars-backward " \t\n\r") (end-of-line) + (setq end (min end (point))) + (if (>= beg end) (error "Nothing to comment")) ;; sanitize LINES (setq lines diff --git a/lisp/notifications.el b/lisp/notifications.el index 5ad64ff73b6..b58a1a02116 100644 --- a/lisp/notifications.el +++ b/lisp/notifications.el @@ -202,7 +202,7 @@ This function returns a notification id, an integer, which can be used to manipulate the notification item with `notifications-close-notification' or the `:replaces-id' argument of another `notifications-notify' call." - (with-demoted-errors + (with-demoted-errors "Notification error: %S" (let ((bus (or (plist-get params :bus) :session)) (title (plist-get params :title)) (body (plist-get params :body)) diff --git a/lisp/novice.el b/lisp/novice.el index 3512aed3645..3a3596e30f8 100644 --- a/lisp/novice.el +++ b/lisp/novice.el @@ -43,71 +43,65 @@ If nil, the feature is disabled, i.e., all commands work normally.") ;; because we won't get called otherwise. ;;;###autoload (defun disabled-command-function (&optional cmd keys) - (unless cmd (setq cmd this-command)) - (unless keys (setq keys (this-command-keys))) - (let (char) - (save-window-excursion - (with-output-to-temp-buffer "*Disabled Command*" ;; (help-buffer) - (if (or (eq (aref keys 0) - (if (stringp keys) - (aref "\M-x" 0) - ?\M-x)) - (and (>= (length keys) 2) - (eq (aref keys 0) meta-prefix-char) - (eq (aref keys 1) ?x))) - (princ (format "You have invoked the disabled command %s.\n" cmd)) - (princ (format "You have typed %s, invoking disabled command %s.\n" - (key-description keys) cmd))) - ;; Print any special message saying why the command is disabled. - (if (stringp (get cmd 'disabled)) - (princ (get cmd 'disabled)) - (princ "It is disabled because new users often find it confusing.\n") - (princ (substitute-command-keys - "Here's the first part of its description:\n\n")) - ;; Keep only the first paragraph of the documentation. - (with-current-buffer "*Disabled Command*" ;; standard-output - (goto-char (point-max)) - (let ((start (point))) - (save-excursion - (princ (or (condition-case () - (documentation cmd) - (error nil)) - "<< not documented >>"))) - (if (search-forward "\n\n" nil t) - (delete-region (match-beginning 0) (point-max))) - (goto-char (point-max)) - (indent-rigidly start (point) 3)))) - (princ "\n\nDo you want to use this command anyway?\n\n") - (princ (substitute-command-keys "You can now type -y to try it and enable it (no questions if you use it again). -n to cancel--don't try the command, and it remains disabled. -SPC to try the command just this once, but leave it disabled. -! to try it, and enable all disabled commands for this session only.")) - ;; Redundant since with-output-to-temp-buffer will do it anyway. - ;; (with-current-buffer standard-output - ;; (help-mode)) - ) - (fit-window-to-buffer (get-buffer-window "*Disabled Command*")) - (message "Type y, n, ! or SPC (the space bar): ") - (let ((cursor-in-echo-area t)) - (while (progn (setq char (read-event)) - (or (not (numberp char)) - (not (memq (downcase char) - '(?! ?y ?n ?\s ?\C-g))))) - (ding) - (message "Please type y, n, ! or SPC (the space bar): ")))) - (setq char (downcase char)) + (let* ((cmd (or cmd this-command)) + (keys (or keys (this-command-keys))) + (help-string + (concat + (if (or (eq (aref keys 0) + (if (stringp keys) + (aref "\M-x" 0) + ?\M-x)) + (and (>= (length keys) 2) + (eq (aref keys 0) meta-prefix-char) + (eq (aref keys 1) ?x))) + (format "You have invoked the disabled command %s.\n" cmd) + (substitute-command-keys + (format "You have typed \\`%s', invoking disabled command %s.\n" + (key-description keys) cmd))) + ;; Any special message saying why the command is disabled. + (if (stringp (get cmd 'disabled)) + (get cmd 'disabled) + (concat + "It is disabled because new users often find it confusing.\n" + (substitute-command-keys + "Here's the first part of its description:\n\n") + ;; Keep only the first paragraph of the documentation. + (with-temp-buffer + (insert (condition-case () + (documentation cmd) + (error "<< not documented >>"))) + (goto-char (point-min)) + (when (search-forward "\n\n" nil t) + (delete-region (match-beginning 0) (point-max))) + (indent-rigidly (point-min) (point-max) 3) + (buffer-string)))) + (substitute-command-keys "\n +Do you want to use this command anyway? + +You can now type: + \\`y' to try it and enable it (no questions if you use it again). + \\`n' to cancel--don't try the command, and it remains disabled. + \\`SPC' to try the command just this once, but leave it disabled. + \\`!' to try it, and enable all disabled commands for this session only."))) + (char + (car (read-multiple-choice "Use this command?" + '((?y "yes") + (?n "no") + (?! "yes; enable for session") + (?\s "(space bar) yes; once")) + help-string + "*Disabled Command*")))) (pcase char - (?\C-g (setq quit-flag t)) - (?! (setq disabled-command-function nil)) - (?y - (if (and user-init-file - (not (string= "" user-init-file)) - (y-or-n-p "Enable command for future editing sessions also? ")) - (enable-command cmd) - (put cmd 'disabled nil)))) - (or (char-equal char ?n) - (call-interactively cmd)))) + (?\C-g (setq quit-flag t)) + (?! (setq disabled-command-function nil)) + (?y + (if (and user-init-file + (not (string= "" user-init-file)) + (y-or-n-p "Enable command for future editing sessions also? ")) + (enable-command cmd) + (put cmd 'disabled nil)))) + (unless (char-equal char ?n) + (call-interactively cmd)))) (defun en/disable-command (command disable) (unless (commandp command) diff --git a/lisp/nxml/nxml-mode.el b/lisp/nxml/nxml-mode.el index b8f6cb5ad36..171b7088c10 100644 --- a/lisp/nxml/nxml-mode.el +++ b/lisp/nxml/nxml-mode.el @@ -566,7 +566,8 @@ Many aspects this mode can be customized using (font-lock-syntactic-face-function . sgml-font-lock-syntactic-face))) - (with-demoted-errors (rng-nxml-mode-init))) + (with-demoted-errors "RNG NXML error: %S" + (rng-nxml-mode-init))) (defun nxml--buffer-substring-filter (string) ;; The `rng-state' property is huge, so don't copy it to the kill ring. diff --git a/lisp/nxml/rng-cmpct.el b/lisp/nxml/rng-cmpct.el index 3e24db64775..453c2b736dd 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 c68f274e64f..ecdf510782a 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 b1877d18321..003410577a6 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/autoarg.el b/lisp/obsolete/autoarg.el index b0d6abe0207..8d5ded93421 100644 --- a/lisp/autoarg.el +++ b/lisp/obsolete/autoarg.el @@ -5,6 +5,7 @@ ;; Author: Dave Love <fx@gnu.org> ;; Created: 1998-09-04 ;; Keywords: abbrev, emulations +;; Obsolete-since: 29.1 ;; This file is part of GNU Emacs. diff --git a/lisp/obsolete/cl-compat.el b/lisp/obsolete/cl-compat.el index f36f5af4ef5..e58f475d1c2 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 40e05f0f45b..93f9dee4b4b 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 b8944e42609..8424c42b69c 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/emacs-lisp/eieio-compat.el b/lisp/obsolete/eieio-compat.el index 553b84af4fc..8d8211b8498 100644 --- a/lisp/emacs-lisp/eieio-compat.el +++ b/lisp/obsolete/eieio-compat.el @@ -70,7 +70,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 +104,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/obsolete/eudcb-ph.el b/lisp/obsolete/eudcb-ph.el index 1ca7d5513a4..8f3928d5641 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 82dd58b40f1..1614935f03a 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/gs.el b/lisp/obsolete/gs.el index 971e7d2640a..7bf324ceecf 100644 --- a/lisp/obsolete/gs.el +++ b/lisp/obsolete/gs.el @@ -116,7 +116,7 @@ FILE is the value to substitute for the place-holder `<file>'." (/ (* 25.4 mm) 72.0))) (declare-function x-change-window-property "xfns.c" - (prop value &optional frame type format outer-p)) + (prop value &optional frame type format outer-p window-id)) (defun gs-set-ghostview-window-prop (frame spec img-width img-height) "Set the `GHOSTVIEW' window property of FRAME. diff --git a/lisp/obsolete/iswitchb.el b/lisp/obsolete/iswitchb.el index 3afdf84d5b2..1929d1994e7 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 @@ -1076,8 +1064,7 @@ Return the modified list with the last element prepended to it." ;; then create a new buffer (progn (setq newbufcreated (get-buffer-create buf)) - (if (fboundp 'set-buffer-major-mode) - (set-buffer-major-mode newbufcreated)) + (set-buffer-major-mode newbufcreated) (iswitchb-visit-buffer newbufcreated)) ;; else won't create new buffer (message "no buffer matching `%s'" buf)))) @@ -1326,9 +1313,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/mouse-sel.el b/lisp/obsolete/mouse-sel.el index a9d6bfee604..3eacac65fba 100644 --- a/lisp/obsolete/mouse-sel.el +++ b/lisp/obsolete/mouse-sel.el @@ -438,7 +438,7 @@ Click sets point & mark to click position. Dragging extends region/selection. Multi-clicking selects word/lines/paragraphs, as determined by -'mouse-sel-determine-selection-thing. +`mouse-sel-determine-selection-thing'. Clicking mouse-2 while selecting copies selected text to the kill-ring. Clicking mouse-1 or mouse-3 kills the selected text. @@ -459,7 +459,7 @@ Click sets the start of the secondary selection to click position. Dragging extends the secondary selection. Multi-clicking selects word/lines/paragraphs, as determined by -'mouse-sel-determine-selection-thing. +`mouse-sel-determine-selection-thing'. Clicking mouse-2 while selecting copies selected text to the kill-ring. Clicking mouse-1 or mouse-3 kills the selected text. diff --git a/lisp/obsolete/otodo-mode.el b/lisp/obsolete/otodo-mode.el index e5c2e28de1d..82017f4dbcf 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 7f2c6df16f6..5542e995c02 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 734392ff6a3..16ca4e1431b 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 c75675ab704..8c4ec8f7e09 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 becaac29d8d..17aa73697bc 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 7f7ed1260f0..537d65c6587 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/vc/vc-mtn.el b/lisp/obsolete/vc-mtn.el index 20fbf92bb12..cd56b290072 100644 --- a/lisp/vc/vc-mtn.el +++ b/lisp/obsolete/vc-mtn.el @@ -5,6 +5,7 @@ ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: vc ;; Package: vc +;; Obsolete-since: 29.1 ;; This file is part of GNU Emacs. diff --git a/lisp/vt-control.el b/lisp/obsolete/vt-control.el index b80d3505b30..190ccbaa83c 100644 --- a/lisp/vt-control.el +++ b/lisp/obsolete/vt-control.el @@ -4,6 +4,7 @@ ;; Author: Rob Riepel <riepel@networking.stanford.edu> ;; Keywords: terminals +;; Obsolete-since: 29.1 ;; This file is part of GNU Emacs. diff --git a/lisp/vt100-led.el b/lisp/obsolete/vt100-led.el index a6a256a6a74..d741a112aa7 100644 --- a/lisp/vt100-led.el +++ b/lisp/obsolete/vt100-led.el @@ -5,6 +5,7 @@ ;; Author: Howard Gayle ;; Maintainer: emacs-devel@gnu.org ;; Keywords: hardware +;; Obsolete-since: 29.1 ;; This file is part of GNU Emacs. diff --git a/lisp/org/ob-core.el b/lisp/org/ob-core.el index 23ef162a7f3..04af84d2e44 100644 --- a/lisp/org/ob-core.el +++ b/lisp/org/ob-core.el @@ -480,7 +480,7 @@ value. The value can either be a string or a closure that evaluates to a string. The closure is evaluated when the source block is being evaluated (e.g. during execution or export), with point at the source block. It is not possible to use an -arbitrary function symbol (e.g. 'some-func), since org uses +arbitrary function symbol (e.g. `some-func'), since org uses lexical binding. To achieve the same functionality, call the function within a closure (e.g. (lambda () (some-func))). diff --git a/lisp/org/ob-julia.el b/lisp/org/ob-julia.el index abddca36134..50a44bcf448 100644 --- a/lisp/org/ob-julia.el +++ b/lisp/org/ob-julia.el @@ -250,8 +250,8 @@ end") (defun org-babel-julia-evaluate-external-process (body result-type result-params column-names-p) "Evaluate BODY in external julia process. -If RESULT-TYPE equals 'output then return standard output as a -string. If RESULT-TYPE equals 'value then return the value of the +If RESULT-TYPE equals `output' then return standard output as a +string. If RESULT-TYPE equals `value' then return the value of the last statement in BODY, as elisp." (cl-case result-type (value @@ -274,8 +274,8 @@ last statement in BODY, as elisp." (defun org-babel-julia-evaluate-session (session body result-type result-params column-names-p) "Evaluate BODY in SESSION. -If RESULT-TYPE equals 'output then return standard output as a -string. If RESULT-TYPE equals 'value then return the value of the +If RESULT-TYPE equals `output' then return standard output as a +string. If RESULT-TYPE equals `value' then return the value of the last statement in BODY, as elisp." (cl-case result-type (value diff --git a/lisp/org/ob-lua.el b/lisp/org/ob-lua.el index 48de0dbad06..b6e78fb7fd8 100644 --- a/lisp/org/ob-lua.el +++ b/lisp/org/ob-lua.el @@ -395,7 +395,7 @@ fd:close()" (org-babel-lua-table-or-string results))))) (defun org-babel-lua-read-string (string) - "Strip 's from around Lua string." + "Strip \\=' characters from around Lua string." (org-unbracket-string "'" "'" string)) (provide 'ob-lua) diff --git a/lisp/org/ob-table.el b/lisp/org/ob-table.el index 2f092998d8b..f6729e0ece7 100644 --- a/lisp/org/ob-table.el +++ b/lisp/org/ob-table.el @@ -84,7 +84,7 @@ is the equivalent of the following source code block: #+end_src NOTE: The quotation marks around the function name, -'source-block', are optional. +`source-block', are optional. NOTE: By default, string variable names are interpreted as references to source-code blocks, to force interpretation of a diff --git a/lisp/org/ol-eshell.el b/lisp/org/ol-eshell.el index 1dee61b98b8..1ca2aa2b28b 100644 --- a/lisp/org/ol-eshell.el +++ b/lisp/org/ol-eshell.el @@ -46,7 +46,7 @@ followed by a colon." (eshell-buffer-name (car buffer-and-command)) (command (cadr buffer-and-command))) (if (get-buffer eshell-buffer-name) - (pop-to-buffer-same-window eshell-buffer-name) + (pop-to-buffer eshell-buffer-name display-comint-buffer-action) (eshell)) (goto-char (point-max)) (eshell-kill-input) diff --git a/lisp/org/ol-eww.el b/lisp/org/ol-eww.el index 69bf1ba62dd..d1bb5195107 100644 --- a/lisp/org/ol-eww.el +++ b/lisp/org/ol-eww.el @@ -115,7 +115,7 @@ keep the structure of the Org file." (setq transform-start (region-beginning)) (setq transform-end (region-end)) ;; Deactivate mark if current mark is activate. - (when (fboundp 'deactivate-mark) (deactivate-mark))) + (deactivate-mark)) (message "Transforming links...") (save-excursion (goto-char transform-start) diff --git a/lisp/org/ol-man.el b/lisp/org/ol-man.el index 3806d95cdaf..beed216acf9 100644 --- a/lisp/org/ol-man.el +++ b/lisp/org/ol-man.el @@ -8,12 +8,12 @@ ;; ;; This file is part of GNU Emacs. ;; -;; This program is free software; you can redistribute it and/or modify +;; 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, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. -;; This program is distributed in the hope that it will be useful, +;; 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. diff --git a/lisp/org/ol-w3m.el b/lisp/org/ol-w3m.el index 517329889c6..80d6811a5c5 100644 --- a/lisp/org/ol-w3m.el +++ b/lisp/org/ol-w3m.el @@ -72,7 +72,7 @@ so that it can be yanked into an Org buffer with links working correctly." (setq transform-start (region-beginning)) (setq transform-end (region-end)) ;; Deactivate mark if current mark is activate. - (when (fboundp 'deactivate-mark) (deactivate-mark))) + (deactivate-mark)) (message "Transforming links...") (save-excursion (goto-char transform-start) diff --git a/lisp/org/org-agenda.el b/lisp/org/org-agenda.el index 71aac271f7b..a43b083d536 100644 --- a/lisp/org/org-agenda.el +++ b/lisp/org/org-agenda.el @@ -1615,7 +1615,7 @@ alpha-down Sort headlines alphabetically, reversed. The different possibilities will be tried in sequence, and testing stops if one comparison returns a \"not-equal\". For example, the default - '(time-up category-keep priority-down) + `(time-up category-keep priority-down)' means: Pull out all entries having a specified time of day and sort them, in order to make a time schedule for the current day the first thing in the agenda listing for the day. Of the entries without a time indication, keep @@ -4124,7 +4124,7 @@ dimming them." ;FIXME: The arg isn't used, actually! If the header at `org-hd-marker' is blocked according to `org-entry-blocked-p', then if `org-agenda-dim-blocked-tasks' is -'invisible and the header is not blocked by checkboxes, set the +`invisible' and the header is not blocked by checkboxes, set the text property `org-todo-blocked' to `invisible', otherwise set it to t." (when (get-text-property 0 'todo-state entry) @@ -7399,7 +7399,7 @@ Argument ARG is the prefix argument." When in a restricted subtree, remove it. The restriction will span over the entire file if TYPE is `file', -or if type is '(4), or if the cursor is before the first headline +or if type is \\='(4), or if the cursor is before the first headline in the file. Otherwise, only apply the restriction to the current subtree." (interactive "P") diff --git a/lisp/org/org-capture.el b/lisp/org/org-capture.el index bfead3aa5af..2fd9a9c74da 100644 --- a/lisp/org/org-capture.el +++ b/lisp/org/org-capture.el @@ -1816,10 +1816,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 081a6178345..fdc9818a5a8 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) @@ -659,7 +658,6 @@ there is no recent clock to choose from." (if (< i 10) (+ i ?0) (+ i (- ?A 10))) m)) - (if (fboundp 'int-to-char) (setf (car s) (int-to-char (car s)))) (push s sel-list))) (run-hooks 'org-clock-before-select-task-hook) (goto-char (point-min)) @@ -2838,7 +2836,7 @@ a number of clock tables." (pcase (if range (car range) (plist-get params :tstart)) ((and (pred numberp) n) (pcase-let ((`(,m ,d ,y) (calendar-gregorian-from-absolute n))) - (apply #'encode-time (list 0 0 org-extend-today-until d m y)))) + (encode-time 0 0 org-extend-today-until d m y))) (timestamp (seconds-to-time (org-matcher-time (or timestamp @@ -2848,7 +2846,7 @@ a number of clock tables." (pcase (if range (nth 1 range) (plist-get params :tend)) ((and (pred numberp) n) (pcase-let ((`(,m ,d ,y) (calendar-gregorian-from-absolute n))) - (apply #'encode-time (list 0 0 org-extend-today-until d m y)))) + (encode-time 0 0 org-extend-today-until d m y))) (timestamp (seconds-to-time (org-matcher-time timestamp)))))) (while (time-less-p start end) (unless (bolp) (insert "\n")) diff --git a/lisp/org/org-compat.el b/lisp/org/org-compat.el index c26eb6f10ab..3e394fbab1c 100644 --- a/lisp/org/org-compat.el +++ b/lisp/org/org-compat.el @@ -39,7 +39,7 @@ (declare-function org-calendar-goto-agenda "org-agenda" ()) (declare-function org-align-tags "org" (&optional all)) (declare-function org-at-heading-p "org" (&optional ignored)) -(declare-function org-at-table.el-p "org" ()) +(declare-function org-at-table.el-p "org-table" ()) (declare-function org-element-at-point "org-element" ()) (declare-function org-element-context "org-element" (&optional element)) (declare-function org-element-lineage "org-element" (blob &optional types with-self)) @@ -199,8 +199,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) @@ -239,7 +238,7 @@ This is a floating point number if the size is too large for an integer." (if (fboundp 'string-collate-lessp) (defalias 'org-string-collate-lessp 'string-collate-lessp) - (defun org-string-collate-lessp (s1 s2 &rest _) + (defun org-string-collate-lessp (s1 s2 &optional _ _) "Return non-nil if STRING1 is less than STRING2 in lexicographic order. Case is significant." (string< s1 s2))) diff --git a/lisp/org/org-id.el b/lisp/org/org-id.el index b4acec7bdd7..7334050b8b4 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-macs.el b/lisp/org/org-macs.el index b10725bd526..bb0562dde06 100644 --- a/lisp/org/org-macs.el +++ b/lisp/org/org-macs.el @@ -37,6 +37,7 @@ (declare-function org-mode "org" ()) (declare-function org-show-context "org" (&optional key)) (declare-function org-string-collate-lessp "org-compat" (s1 s2 &optional locale ignore-case)) +(declare-function org-time-convert-to-integer "org-compat" (time)) (defvar org-ts-regexp0) (defvar ffap-url-regexp) @@ -257,15 +258,16 @@ ignored in this case." (defun org-file-newer-than-p (file time) "Non-nil if FILE is newer than TIME. -FILE is a filename, as a string, TIME is a list of integers, as +FILE is a filename, as a string, TIME is a Lisp time value, as returned by, e.g., `current-time'." (and (file-exists-p file) ;; Only compare times up to whole seconds as some file-systems ;; (e.g. HFS+) do not retain any finer granularity. As ;; a consequence, make sure we return non-nil when the two ;; times are equal. - (not (time-less-p (cl-subseq (nth 5 (file-attributes file)) 0 2) - (cl-subseq time 0 2))))) + (not (time-less-p (org-time-convert-to-integer + (nth 5 (file-attributes file))) + (org-time-convert-to-integer time))))) (defun org-compile-file (source process ext &optional err-msg log-buf spec) "Compile a SOURCE file using PROCESS. diff --git a/lisp/org/org-mouse.el b/lisp/org/org-mouse.el index 20c20acc320..a590ff87f24 100644 --- a/lisp/org/org-mouse.el +++ b/lisp/org/org-mouse.el @@ -208,7 +208,7 @@ this function is called. Otherwise, the current major mode menu is used." (interactive "@e \nP") (if (and (= (event-click-count event) 1) (or (not mark-active) - (sit-for (/ double-click-time 1000.0)))) + (sit-for (/ (mouse-double-click-time) 1000.0)))) (progn (select-window (posn-window (event-start event))) (when (not (org-mouse-mark-active)) diff --git a/lisp/org/org-plot.el b/lisp/org/org-plot.el index bf84c99e042..4507fbe7ddc 100644 --- a/lisp/org/org-plot.el +++ b/lisp/org/org-plot.el @@ -280,7 +280,7 @@ When NORMALISE is non-nil, the count is divided by the number of values." collect (cons n (/ (length m) normaliser))))) (defun org--plot/prime-factors (value) - "Return the prime decomposition of VALUE, e.g. for 12, '(3 2 2)." + "Return the prime decomposition of VALUE, e.g. for 12, \\='(3 2 2)." (let ((factors '(1)) (i 1)) (while (/= 1 value) (setq i (1+ i)) diff --git a/lisp/org/org-refile.el b/lisp/org/org-refile.el index 5ad73422efa..71d00a7a22b 100644 --- a/lisp/org/org-refile.el +++ b/lisp/org/org-refile.el @@ -577,7 +577,7 @@ prefix argument (`C-u C-u C-u C-c C-w')." (with-demoted-errors "Bookmark set error: %S" (bookmark-set bookmark-name)))) (move-marker org-capture-last-stored-marker (point))) - (when (fboundp 'deactivate-mark) (deactivate-mark)) + (deactivate-mark) (run-hooks 'org-after-refile-insert-hook))) (unless org-refile-keep (if regionp @@ -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/org/org-table.el b/lisp/org/org-table.el index 860fd6e5608..c301bc6af1a 100644 --- a/lisp/org/org-table.el +++ b/lisp/org/org-table.el @@ -5465,7 +5465,7 @@ The table is taken from the parameter TXT, or from the buffer at point." (nreverse table))))) (defun org-table-collapse-header (table &optional separator max-header-lines) - "Collapse the lines before 'hline into a single header. + "Collapse the lines before `hline' into a single header. The given TABLE is a list of lists as returned by `org-table-to-lisp'. The leading lines before the first `hline' symbol are considered diff --git a/lisp/org/org.el b/lisp/org/org.el index 06af12339ec..008230500d7 100644 --- a/lisp/org/org.el +++ b/lisp/org/org.el @@ -3301,7 +3301,7 @@ Replace format-specifiers in the command as noted below and use %i: The LaTeX fragment to be converted. For example, this could be used with LaTeXML as -\"latexmlc 'literal:%i' --profile=math --preload=siunitx.sty 2>/dev/null\"." +\"latexmlc \\='literal:%i\\=' --profile=math --preload=siunitx.sty 2>/dev/null\"." :group 'org-latex :package-version '(Org . "9.4") :type '(choice @@ -12160,7 +12160,7 @@ This works in the agenda, and also in an Org buffer." (progn (message "[s]et or [r]emove? ") (equal (read-char-exclusive) ?r)))) - (when (fboundp 'deactivate-mark) (deactivate-mark)) + (deactivate-mark) (let ((agendap (equal major-mode 'org-agenda-mode)) l1 l2 m buf pos newhead (cnt 0)) (goto-char end) diff --git a/lisp/org/ox-html.el b/lisp/org/ox-html.el index 81ef002a052..9cf9125aebd 100644 --- a/lisp/org/ox-html.el +++ b/lisp/org/ox-html.el @@ -2909,7 +2909,7 @@ Starred and \"displaymath\" environments are not numbered." (defun org-html--unlabel-latex-environment (latex-frag) "Change environment in LATEX-FRAG string to an unnumbered one. -For instance, change an 'equation' environment to 'equation*'." +For instance, change an `equation' environment to `equation*'." (replace-regexp-in-string "\\`[ \t]*\\\\begin{\\([^*]+?\\)}" "\\1*" diff --git a/lisp/org/ox-icalendar.el b/lisp/org/ox-icalendar.el index 7e40f5bcd0b..a3fe31d7b8f 100644 --- a/lisp/org/ox-icalendar.el +++ b/lisp/org/ox-icalendar.el @@ -824,8 +824,7 @@ as a communication channel." (if (not (plist-get info :with-author)) "" (org-export-data (plist-get info :author) info)) ;; Timezone. - (if (org-string-nw-p org-icalendar-timezone) org-icalendar-timezone - (cadr (current-time-zone))) + (or (org-string-nw-p org-icalendar-timezone) (format-time-string "%Z")) ;; Description. (org-export-data (plist-get info :title) info) contents)) @@ -972,7 +971,7 @@ This function assumes major mode for current buffer is (org-icalendar--vcalendar org-icalendar-combined-name user-full-name - (or (org-string-nw-p org-icalendar-timezone) (cadr (current-time-zone))) + (or (org-string-nw-p org-icalendar-timezone) (format-time-string "%Z")) org-icalendar-combined-description contents))) (run-hook-with-args 'org-icalendar-after-save-hook file))) @@ -995,7 +994,7 @@ FILES is a list of files to build the calendar from." user-full-name ;; Timezone. (or (org-string-nw-p org-icalendar-timezone) - (cadr (current-time-zone))) + (format-time-string "Z")) ;; Description. org-icalendar-combined-description ;; Contents. diff --git a/lisp/org/ox-publish.el b/lisp/org/ox-publish.el index 636bd0d2ae3..51e2352b4e8 100644 --- a/lisp/org/ox-publish.el +++ b/lisp/org/ox-publish.el @@ -839,7 +839,7 @@ in `org-export-options-alist' or in export back-ends. In the latter case, optional argument BACKEND has to be set to the back-end where the option is defined, e.g., - (org-publish-find-property file :subtitle 'latex) + (org-publish-find-property file :subtitle \\='latex) Return value may be a string or a list, depending on the type of PROPERTY, i.e. \"behavior\" parameter from `org-export-options-alist'." diff --git a/lisp/outline.el b/lisp/outline.el index 00a557ca4e8..7fd43195cc0 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-" @@ -194,6 +196,7 @@ This option is only in effect when `outline-minor-mode-cycle' is non-nil." (function :tag "Custom filter function")) :version "28.1") +(defvar outline-minor-mode-cycle) (defun outline-minor-mode-cycle--bind (map key binding &optional filter) (define-key map key `(menu-item @@ -202,8 +205,10 @@ This option is only in effect when `outline-minor-mode-cycle' is non-nil." :filter ,(or filter (lambda (cmd) - (when (or (not (functionp outline-minor-mode-cycle-filter)) - (funcall outline-minor-mode-cycle-filter)) + (when (and outline-minor-mode-cycle + (outline-on-heading-p t) + (or (not (functionp outline-minor-mode-cycle-filter)) + (funcall outline-minor-mode-cycle-filter))) cmd)))))) (defvar outline-minor-mode-cycle-map @@ -228,16 +233,10 @@ This option is only in effect when `outline-minor-mode-cycle' is non-nil." (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 - (list 'face (outline-font-lock-face) - 'keymap outline-minor-mode-cycle-map) - (list 'face nil - 'keymap outline-minor-mode-cycle-map)) - (if outline-minor-mode-highlight - (list 'face (outline-font-lock-face)))) + (if outline-minor-mode-highlight + (list 'face (outline-font-lock-face))) (outline-font-lock-face)) (when outline-minor-mode (pcase outline-minor-mode-highlight @@ -281,6 +280,25 @@ This option is only in effect when `outline-minor-mode-cycle' is non-nil." (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. @@ -303,8 +321,11 @@ data reflects the `outline-regexp'.") (defvar outline-mode-hook nil "This hook is run when outline mode starts.") -(defvar outline-blank-line nil - "Non-nil means to leave unhidden blank line before heading.") +(defcustom outline-blank-line nil + "Non-nil means to leave an unhidden blank line before headings." + :type 'boolean + :safe #'booleanp + :version "22.1") ;;;###autoload (define-derived-mode outline-mode text-mode "Outline" @@ -342,7 +363,8 @@ Turning on outline mode calls the value of `text-mode-hook' and then of '(outline-font-lock-keywords t nil nil backward-paragraph)) (setq-local imenu-generic-expression (list (list nil (concat "^\\(?:" outline-regexp "\\).*$") 0))) - (add-hook 'change-major-mode-hook #'outline-show-all nil t)) + (add-hook 'change-major-mode-hook #'outline-show-all nil t) + (add-hook 'hack-local-variables-hook #'outline-apply-default-state nil t)) (defvar outline-minor-mode-map) @@ -367,8 +389,8 @@ line likewise cycles the visibility state of the whole buffer Typing these keys anywhere outside heading lines invokes their default bindings, per the current major mode." :type 'boolean + :safe #'booleanp :version "28.1") -;;;###autoload(put 'outline-minor-mode-cycle 'safe-local-variable 'booleanp) (defcustom outline-minor-mode-highlight nil "Whether to highlight headings in `outline-minor-mode' using font-lock keywords. @@ -385,8 +407,8 @@ outline font-lock faces to those of major mode." (const :tag "Append outline font-lock faces to major mode's" append) (const :tag "Highlight with outline font-lock faces only if major mode doesn't" 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. @@ -402,8 +424,8 @@ outline font-lock faces to those of major mode." (goto-char (match-beginning 0)) (not (get-text-property (point) 'face)))) (overlay-put overlay 'face (outline-font-lock-face))) - (when outline-minor-mode-cycle - (overlay-put overlay 'keymap outline-minor-mode-cycle-map))) + (when outline-minor-mode-use-buttons + (outline--insert-open-button))) (goto-char (match-end 0)))))) ;;;###autoload @@ -412,11 +434,13 @@ outline font-lock faces to those of major mode." See the command `outline-mode' for more information on this mode." :lighter " Outl" - :keymap (list (cons [menu-bar] outline-minor-mode-menu-bar-map) - (cons outline-minor-mode-prefix outline-mode-prefix-map)) + :keymap (easy-mmode-define-keymap + `(([menu-bar] . ,outline-minor-mode-menu-bar-map) + (,outline-minor-mode-prefix . ,outline-mode-prefix-map)) + :inherit outline-minor-mode-cycle-map) (if outline-minor-mode (progn - (when (or outline-minor-mode-cycle outline-minor-mode-highlight) + (when outline-minor-mode-highlight (if (and global-font-lock-mode (font-lock-specified-p major-mode)) (progn (font-lock-add-keywords nil outline-font-lock-keywords t) @@ -428,8 +452,9 @@ See the command `outline-mode' for more information on this mode." nil t) (setq-local line-move-ignore-invisible t) ;; Cause use of ellipses for invisible text. - (add-to-invisibility-spec '(outline . t))) - (when (or outline-minor-mode-cycle outline-minor-mode-highlight) + (add-to-invisibility-spec '(outline . t)) + (outline-apply-default-state)) + (when outline-minor-mode-highlight (if font-lock-fontified (font-lock-remove-keywords nil outline-font-lock-keywords)) (remove-overlays nil nil 'outline-overlay t) @@ -821,6 +846,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)) @@ -937,11 +963,80 @@ 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 + "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 + "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 () @@ -957,9 +1052,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") @@ -1223,9 +1322,187 @@ convenient way to make a table of contents of the buffer." (insert "\n\n")))))) (kill-new (buffer-string))))))) +(defcustom outline-default-state nil + "If non-nil, some headings are initially outlined. + +Note that the default state is applied when Outline major and +minor modes are set or when the command +`outline-apply-default-state' is called interactively. + +When nil, no default state is defined and +`outline-apply-default-state' is a no-op. + +If equal to `outline-show-all', all text of buffer is shown. + +If equal to `outline-show-only-headings', show only headings, +whatever their level is. + +If equal to a number, show only headings up to and including the +corresponding level. See `outline-default-rules' to customize +visibility of the subtree at that level. + +If equal to a lambda function or function name, this function is +expected to toggle headings visibility, and will be +called without arguments after the mode is enabled." + :version "29.1" + :type '(choice (const :tag "Disabled" nil) + (const :tag "Show all" outline-show-all) + (const :tag "Only headings" outline-show-only-headings) + (natnum :tag "Show headings up to level" :value 1) + (function :tag "Custom function"))) + +(defcustom outline-default-rules nil + "Determines visibility of subtree starting at `outline-default-state' level. + +The rules apply if and only if `outline-default-state' is a +number. + +When nil, the subtree is hidden unconditionally. + +When equal to a list, each element should be one of the following: + +- A cons cell with CAR `match-regexp' and CDR a regexp, the + subtree will be hidden when the outline heading match the + regexp. + +- `subtree-has-long-lines' to only show the heading branches when + long lines are detected in its subtree (see + `outline-default-long-line' for the definition of long lines). + +- `subtree-is-long' to only show the heading branches when its + subtree contains more than `outline-default-line-count' lines. + +- A cons cell of the form (custom-function . FUNCTION) where + FUNCTION is a lambda function or function name which will be + called without arguments with point at the beginning of the + heading and the match data set appropriately, the function + being expected to toggle the heading visibility." + :version "29.1" + :type '(choice (const :tag "Hide subtree" nil) + (set :tag "Show subtree unless" + (cons :tag "Heading match regexp" + (const match-regexp) string) + (const :tag "Subtree has long lines" + subtree-has-long-lines) + (const :tag "Subtree is long" + subtree-is-long) + (cons :tag "Custom function" + (const custom-function) function)))) + +(defcustom outline-default-long-line 1000 + "Minimal number of characters in a line for a heading to be outlined." + :version "29.1" + :type '(natnum :tag "Number of characters")) + +(defcustom outline-default-line-count 50 + "Minimal number of lines for a heading to be outlined." + :version "29.1" + :type '(natnum :tag "Number of lines")) + +(defun outline-apply-default-state () + "Apply the outline state defined by `outline-default-state'." + (interactive) + (cond + ((integerp outline-default-state) + (outline--show-headings-up-to-level outline-default-state)) + ((functionp outline-default-state) + (funcall outline-default-state)))) + +(defun outline-show-only-headings () + "Show only headings." + (interactive) + (outline-show-all) + (outline-hide-region-body (point-min) (point-max))) + +(eval-when-compile (require 'so-long)) +(autoload 'so-long-detected-long-line-p "so-long") +(defvar so-long-skip-leading-comments) +(defvar so-long-threshold) +(defvar so-long-max-lines) + +(defun outline--show-headings-up-to-level (level) + "Show only headings up to a LEVEL level. + +Like `outline-hide-sublevels' but, for each heading at level +LEVEL, decides of subtree visibility according to +`outline-default-rules'." + (if (not outline-default-rules) + (outline-hide-sublevels level) + (if (< level 1) + (error "Must keep at least one level of headers")) + (save-excursion + (let* (outline-view-change-hook + (beg (progn + (goto-char (point-min)) + ;; Skip the prelude, if any. + (unless (outline-on-heading-p t) (outline-next-heading)) + (point))) + (end (progn + (goto-char (point-max)) + ;; Keep empty last line, if available. + (if (bolp) (1- (point)) (point)))) + (heading-regexp + (cdr-safe + (assoc 'match-regexp outline-default-rules))) + (check-line-count + (memq 'subtree-is-long outline-default-rules)) + (check-long-lines + (memq 'subtree-has-long-lines outline-default-rules)) + (custom-function + (cdr-safe + (assoc 'custom-function outline-default-rules)))) + (if (< end beg) + (setq beg (prog1 end (setq end beg)))) + ;; First hide everything. + (outline-hide-sublevels level) + ;; Then unhide the top level headers. + (outline-map-region + (lambda () + (let ((current-level (funcall outline-level))) + (when (< current-level level) + (outline-show-heading) + (outline-show-entry)) + (when (= current-level level) + (cond + ((and heading-regexp + (let ((beg (point)) + (end (progn (outline-end-of-heading) (point)))) + (string-match-p heading-regexp (buffer-substring beg end)))) + ;; hide entry when heading match regexp + (outline-hide-entry)) + ((and check-line-count + (save-excursion + (let ((beg (point)) + (end (progn (outline-end-of-subtree) (point)))) + (<= outline-default-line-count (count-lines beg end))))) + ;; show only branches when line count of subtree > + ;; threshold + (outline-show-branches)) + ((and check-long-lines + (save-excursion + (let ((beg (point)) + (end (progn (outline-end-of-subtree) (point)))) + (save-restriction + (narrow-to-region beg end) + (let ((so-long-skip-leading-comments nil) + (so-long-threshold outline-default-long-line) + (so-long-max-lines nil)) + (so-long-detected-long-line-p)))))) + ;; show only branches when long lines are detected + ;; in subtree + (outline-show-branches)) + (custom-function + ;; call custom function if defined + (funcall custom-function)) + (t + ;; if no previous clause succeeds, show subtree + (outline-show-subtree)))))) + beg end))) + (run-hooks 'outline-view-change-hook))) + (defun outline--cycle-state () "Return the cycle state of current heading. -Return either 'hide-all, 'headings-only, or 'show-all." +Return either `hide-all', `headings-only', or `show-all'." (save-excursion (let (start end ov-list heading-end) (outline-back-to-heading) @@ -1320,7 +1597,8 @@ the heading lines in the buffer. It cycles them between `hide 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 2793b3d6f2f..4c268dbf771 100644 --- a/lisp/paren.el +++ b/lisp/paren.el @@ -88,6 +88,28 @@ 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 around the opening paren if it 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. + +By default, the context is shown in the echo area. + +If set to the symbol `overlay', the context is shown in an +overlay at the top-left of the window. + +If set to the symbol `child-frame', the context is shown in a +child frame at the top-left of the window. You might want to +customize the `child-frame-border' face (especially the +background color) to give the child frame a distinguished border. +On non-graphical frames, the context is shown in the echo area." + :type '(choice (const :tag "Off" nil) + (const :tag "In echo area" t) + (const :tag "In overlay" overlay) + (const :tag "In child-frame" child-frame)) + :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) @@ -203,6 +225,13 @@ It is the default value of `show-paren-data-function'." (let* ((temp (show-paren--locate-near-paren)) (dir (car temp)) (outside (cdr temp)) + ;; If we're inside a comment, then we probably want to blink + ;; a matching parentheses in the comment. So don't ignore + ;; comments in that case. + (parse-sexp-ignore-comments + (if (ppss-comment-depth (syntax-ppss)) + nil + parse-sexp-ignore-comments)) pos mismatch here-beg here-end) ;; ;; Find the other end of the sexp. @@ -252,6 +281,136 @@ It is the default value of `show-paren-data-function'." (if (= dir 1) pos (1+ pos)) mismatch))))))) +(defvar show-paren--context-child-frame nil) + +(defun show-paren--context-child-frame-redirect-focus () + "Redirect focus from child frame." + (redirect-frame-focus + show-paren--context-child-frame + (frame-parent show-paren--context-child-frame))) + +(defun show-paren--context-child-frame-buffer (text) + (with-current-buffer + (get-buffer-create " *show-paren context*") + ;; Redirect focus to parent. + (add-hook 'pre-command-hook + #'show-paren--delete-context-child-frame + nil t) + ;; Use an empty keymap. + (use-local-map (make-keymap)) + (dolist (var '((mode-line-format . nil) + (header-line-format . nil) + (tab-line-format . nil) + (tab-bar-format . nil) ;; Emacs 28 tab-bar-format + (frame-title-format . "") + (truncate-lines . t) + (cursor-in-non-selected-windows . nil) + (cursor-type . nil) + (show-trailing-whitespace . nil) + (display-line-numbers . nil) + (left-fringe-width . nil) + (right-fringe-width . nil) + (left-margin-width . 0) + (right-margin-width . 0) + (fringes-outside-margins . 0) + (buffer-read-only . t))) + (set (make-local-variable (car var)) (cdr var))) + (let ((inhibit-modification-hooks t) + (inhibit-read-only t)) + (erase-buffer) + (insert text) + (goto-char (point-min))) + (current-buffer))) + +(defvar show-paren--context-child-frame-parameters + `((visibility . nil) + (width . 0) (height . 0) + (min-width . t) (min-height . t) + (no-accept-focus . t) + (no-focus-on-map . t) + (border-width . 0) + (child-frame-border-width . 1) + (left-fringe . 0) + (right-fringe . 0) + (vertical-scroll-bars . nil) + (horizontal-scroll-bars . nil) + (menu-bar-lines . 0) + (tool-bar-lines . 0) + (tab-bar-lines . 0) + (no-other-frame . t) + (no-other-window . t) + (no-delete-other-windows . t) + (unsplittable . t) + (undecorated . t) + (cursor-type . nil) + (no-special-glyphs . t) + (desktop-dont-save . t))) + +(defun show-paren--delete-context-child-frame () + (when show-paren--context-child-frame + (delete-frame show-paren--context-child-frame) + (setq show-paren--context-child-frame nil)) + (remove-hook 'post-command-hook + #'show-paren--delete-context-child-frame)) + +(defun show-paren--show-context-in-child-frame (text) + "Show TEXT in a child-frame at the top-left of the current window." + (let ((minibuffer (minibuffer-window (window-frame))) + (buffer (show-paren--context-child-frame-buffer text)) + (x (window-pixel-left)) + (y (window-pixel-top)) + (window-min-height 1) + (window-min-width 1) + after-make-frame-functions) + (show-paren--delete-context-child-frame) + (setq show-paren--context-child-frame + (make-frame + `((parent-frame . ,(window-frame)) + (minibuffer . ,minibuffer) + ,@show-paren--context-child-frame-parameters))) + (let ((win (frame-root-window show-paren--context-child-frame))) + (set-window-buffer win buffer) + (set-window-dedicated-p win t) + (set-frame-size show-paren--context-child-frame + (string-width text) + (length (string-lines text))) + (set-frame-position show-paren--context-child-frame x y) + (make-frame-visible show-paren--context-child-frame) + (add-hook 'post-command-hook + #'show-paren--delete-context-child-frame)))) + +(defvar-local show-paren--context-overlay nil) + +(defun show-paren--delete-context-overlay () + (when show-paren--context-overlay + (delete-overlay show-paren--context-overlay) + (setq show-paren--context-overlay nil)) + (remove-hook 'post-command-hook #'show-paren--delete-overlays + 'local)) + +(defun show-paren--show-context-in-overlay (text) + "Show TEXT in an overlay at the top-left of the current window." + (setq text (replace-regexp-in-string "\n" " " text)) + (show-paren--delete-context-overlay) + (let* ((beg (window-start)) + (end (save-excursion + (goto-char beg) + (line-end-position)))) + (setq show-paren--context-overlay (make-overlay beg end))) + (overlay-put show-paren--context-overlay 'display text) + (overlay-put show-paren--context-overlay + 'face `(:box + ( :line-width (1 . -1) + :color ,(face-attribute 'shadow :foreground)))) + (add-hook 'post-command-hook #'show-paren--delete-context-overlay + nil 'local)) + +;; The last position of point for which `show-paren-function' was +;; called. We track it in order to C-g away a context overlay or +;; child-frame without having it pop up again after +;; `show-paren-delay'. +(defvar-local show-paren--last-pos nil) + (defun show-paren-function () "Highlight the parentheses until the next input arrives." (let ((data (and show-paren-mode (funcall show-paren-data-function)))) @@ -260,7 +419,8 @@ It is the default value of `show-paren-data-function'." ;; If show-paren-mode is nil in this buffer or if not at a paren that ;; has a match, turn off any previous paren highlighting. (delete-overlay show-paren--overlay) - (delete-overlay show-paren--overlay-1)) + (delete-overlay show-paren--overlay-1) + (setq show-paren--last-pos (point))) ;; Found something to highlight. (let* ((here-beg (nth 0 data)) @@ -291,8 +451,8 @@ It is the default value of `show-paren-data-function'." ;; Otherwise, turn off any such highlighting. (if (or (not here-beg) (and (not show-paren-highlight-openparen) - (> here-end (point)) - (<= here-beg (point)) + (> here-end (point)) + (<= here-beg (point)) (integerp there-beg))) (delete-overlay show-paren--overlay-1) (move-overlay show-paren--overlay-1 @@ -307,11 +467,32 @@ It is the default value of `show-paren-data-function'." (delete-overlay show-paren--overlay) (if highlight-expression (move-overlay show-paren--overlay - (if (< there-beg here-beg) here-end here-beg) + (if (< there-beg here-beg) here-end here-beg) (if (< there-beg here-beg) there-beg there-end) (current-buffer)) (move-overlay show-paren--overlay there-beg there-end (current-buffer))) + ;; If `show-paren-context-when-offscreen' is non-nil and + ;; point is at a closing paren, show the context around the + ;; opening paren. + (let ((openparen (min here-beg there-beg))) + (when (and show-paren-context-when-offscreen + (not (eql show-paren--last-pos (point))) + (< there-beg here-beg) + (not (pos-visible-in-window-p openparen))) + (let ((context (blink-paren-open-paren-line-string + openparen)) + (message-log-max nil)) + (cond + ((and + (eq show-paren-context-when-offscreen 'child-frame) + (display-graphic-p)) + (show-paren--show-context-in-child-frame context)) + ((eq show-paren-context-when-offscreen 'overlay) + (show-paren--show-context-in-overlay context)) + (show-paren-context-when-offscreen + (minibuffer-message "Matches %s" context)))))) + (setq show-paren--last-pos (point)) ;; 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/pcmpl-gnu.el b/lisp/pcmpl-gnu.el index d0ae9390e31..3c9bf1ec9d2 100644 --- a/lisp/pcmpl-gnu.el +++ b/lisp/pcmpl-gnu.el @@ -134,7 +134,7 @@ Return the new list." "Add to TARGETS the list of target names in MAKEFILE and files it includes. Return the new list." (with-temp-buffer - (with-demoted-errors ;Could be a directory or something. + (with-demoted-errors "Error inserting makefile: %S" (insert-file-contents makefile)) (let ((filenames (when pcmpl-gnu-makefile-includes (pcmpl-gnu-make-includes)))) diff --git a/lisp/pcomplete.el b/lisp/pcomplete.el index 09ee17caafe..a1492af89d2 100644 --- a/lisp/pcomplete.el +++ b/lisp/pcomplete.el @@ -189,6 +189,16 @@ and how is entirely up to the behavior of the `pcomplete-parse-arguments-function'." :type 'boolean) +(defvar pcomplete-allow-modifications nil + "If non-nil, allow effects in `pcomplete-parse-arguments-function'. +For the `pcomplete' command, it was common for functions in +`pcomplete-parse-arguments-function' to make modifications to the +buffer, like expanding variables are such. +For `completion-at-point-functions', this is not an option any more, so +this variable is used to tell `pcomplete-parse-arguments-function' +whether it can do the modifications like it used to, or whether +it should refrain from doing so.") + (defcustom pcomplete-parse-arguments-function #'pcomplete-parse-buffer-arguments "A function to call to parse the current line's arguments. @@ -392,6 +402,9 @@ Same as `pcomplete' but using the standard completion UI." ;; imposing the pcomplete UI over the standard UI. (catch 'pcompleted (let* ((pcomplete-stub) + (buffer-read-only + ;; Make sure the function obeys `pcomplete-allow-modifications'. + (if pcomplete-allow-modifications buffer-read-only t)) pcomplete-seen pcomplete-norm-func pcomplete-args pcomplete-last pcomplete-index (pcomplete-autolist pcomplete-autolist) @@ -526,6 +539,7 @@ completion functions list (it should occur fairly early in the list)." pcomplete-last-completion-raw nil) (catch 'pcompleted (let* ((pcomplete-stub) + (pcomplete-allow-modifications t) pcomplete-seen pcomplete-norm-func pcomplete-args pcomplete-last pcomplete-index (pcomplete-autolist pcomplete-autolist) @@ -551,7 +565,8 @@ completion functions list (it should occur fairly early in the list)." "Expand the textual value of the current argument. This will modify the current buffer." (interactive) - (let ((pcomplete-expand-before-complete t)) + (let ((pcomplete-expand-before-complete t) + (pcomplete-allow-modifications t)) (with-suppressed-warnings ((obsolete pcomplete)) (pcomplete)))) @@ -569,6 +584,7 @@ This will modify the current buffer." This will modify the current buffer." (interactive) (let ((pcomplete-expand-before-complete t) + (pcomplete-allow-modifications t) (pcomplete-expand-only-p t)) (with-suppressed-warnings ((obsolete pcomplete)) (pcomplete)) @@ -680,8 +696,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 +1022,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 +1056,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 +1078,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 +1260,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 934812b0508..fc7e680c262 100644 --- a/lisp/pixel-scroll.el +++ b/lisp/pixel-scroll.el @@ -32,8 +32,10 @@ ;;; Commentary: -;; This package offers a global minor mode which makes mouse-wheel -;; scroll a line smoothly. +;; This file contains two somewhat related features. + +;; The first is a global minor mode which makes Emacs try to scroll +;; each line smoothly. ;; ;; Scrolling a line up by `set-window-vscroll' and that by `scroll-up' ;; give similar display as shown below. @@ -58,6 +60,25 @@ ;; (set-window-vscroll nil vs t) (sit-for 0)) ;; (scroll-up 1) +;; The second is another global minor mode that redefines `wheel-up' +;; and `wheel-down' to a command that tries to scroll the display +;; according to the precise movement of a trackpad or mouse. + +;; But it operates in a much more intelligent manner than simply +;; setting the vscroll. It will set window start to the position +;; closest to the position at the top-left corner of the window if +;; vscroll were set accordingly, in a smart and fast manner, and only +;; set vscroll the rest of the way. There is no visible difference, +;; but it is much faster, and doesn't move the display by a huge +;; portion if vscroll is reset for some reason. + +;; It also tries to move point out of the way, so redisplay will not +;; recenter the display as it scrolls. This works well almost all of +;; the time, but is impossible to get right with images larger than +;; the window they're displayed in. A feature that will allow +;; redisplay to skip recentering is in the works, and will completely +;; resolve this problem. + ;;; Todo: ;; ;; Allowing pixel-level scrolling in Emacs requires a thorough review @@ -67,6 +88,9 @@ ;;; Code: (require 'mwheel) +(require 'subr-x) +(require 'ring) +(require 'cua-base) (defvar pixel-wait 0 "Idle time on each step of pixel scroll specified in second. @@ -90,6 +114,114 @@ 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) + (define-key map [mode-line wheel-down] 'pixel-scroll-precision) + (define-key map [mode-line wheel-up] 'pixel-scroll-precision) + (define-key map [mode-line touch-end] 'pixel-scroll-start-momentum) + (define-key map [header-line wheel-down] 'pixel-scroll-precision) + (define-key map [header-line wheel-up] 'pixel-scroll-precision) + (define-key map [header-line touch-end] 'pixel-scroll-start-momentum) + (define-key map [vertical-scroll-bar wheel-down] 'pixel-scroll-precision) + (define-key map [vertical-scroll-bar wheel-up] 'pixel-scroll-precision) + (define-key map [vertical-scroll-bar touch-end] 'pixel-scroll-start-momentum) + (define-key map [tool-bar wheel-down] 'pixel-scroll-precision) + (define-key map [tool-bar wheel-up] 'pixel-scroll-precision) + (define-key map [tool-bar touch-end] 'pixel-scroll-start-momentum) + (define-key map [left-margin wheel-down] 'pixel-scroll-precision) + (define-key map [left-margin wheel-up] 'pixel-scroll-precision) + (define-key map [left-margin touch-end] 'pixel-scroll-start-momentum) + (define-key map [right-margin wheel-down] 'pixel-scroll-precision) + (define-key map [right-margin wheel-up] 'pixel-scroll-precision) + (define-key map [right-margin touch-end] 'pixel-scroll-start-momentum) + (define-key map [left-fringe wheel-down] 'pixel-scroll-precision) + (define-key map [left-fringe wheel-up] 'pixel-scroll-precision) + (define-key map [left-fringe touch-end] 'pixel-scroll-start-momentum) + (define-key map [right-fringe wheel-down] 'pixel-scroll-precision) + (define-key map [right-fringe wheel-up] 'pixel-scroll-precision) + (define-key map [right-fringe touch-end] 'pixel-scroll-start-momentum) + (define-key map [next] 'pixel-scroll-interpolate-down) + (define-key map [prior] 'pixel-scroll-interpolate-up) + 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.0335 4) + "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") + +(defcustom pixel-scroll-precision-interpolate-page nil + "Whether or not to interpolate scrolling via the Page Down and Page Up keys. +This is only effective when `pixel-scroll-precision-mode' is enabled." + :group 'scrolling + :type 'boolean + :version "29.1") + +(defcustom pixel-scroll-precision-interpolate-mice t + "Whether or not to interpolate scrolling from a mouse. +If non-nil, scrolling from the mouse wheel of an actual mouse (as +opposed to a touchpad) will cause Emacs to interpolate the scroll." + :group 'scrolling + :type 'boolean + :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 +455,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 +502,339 @@ 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))) + (set-window-start nil desired-start) + (signal 'end-of-buffer nil)) + (while (when-let ((posn (posn-at-point))) + (< (cdr (posn-x-y posn)) delta)) + (when (zerop (vertical-motion 1)) + (set-window-start nil desired-start) + (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 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))) + (setq delta (- delta current-vscroll)) + (set-window-vscroll nil 0 t t) + (when (> delta 0) + (let* ((start (window-start)) + (dims (window-text-pixel-size nil (cons start (- delta)) + start nil nil nil t)) + (height (nth 1 dims)) + (position (nth 2 dims))) + (set-window-start nil 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 (> height usable-height) + (goto-char position)) + (when (or (not position) (eq position start)) + (signal 'beginning-of-buffer nil)) + (setq delta (- delta height)))) + (when (< delta 0) + (set-window-vscroll nil (- delta) t t))))) + +(defun pixel-scroll-precision-interpolate (delta &optional old-window) + "Interpolate a scroll of DELTA pixels. +OLD-WINDOW is the window which will be selected when redisplay +takes place, or nil for the current window. 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) + (with-selected-window (or old-window + (selected-window)) + (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)) + (current-window (selected-window))) + (when (framep window) + (setq window (frame-selected-window window))) + (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 (or (and pixel-scroll-precision-interpolate-mice + (eq (device-class last-event-frame + last-event-device) + 'mouse)) + (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 30)) + (aset kin-state 1 nil)) + (pixel-scroll-precision-interpolate delta current-window)) + (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 (&optional window) + "Return the kinetic scroll state of WINDOW. +If WINDOW is nil, return the state of the current window. +It is a vector of the form [ VELOCITY TIME SIGN ]." + (or (window-parameter window 'kinetic-state) + (set-window-parameter window 'kinetic-state + (vector (make-ring 30) nil 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) + (aref state 2))))) + (aset state 0 (make-ring 30))) + (aset state 2 (< delta 0)) + (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 (last elts)))) + pixel-scroll-precision-initial-velocity-factor))) + +(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)) + (when (framep window) + (setq window (frame-selected-window window))) + (setq state (pixel-scroll-kinetic-state window)) + (when (and (aref state 1) + (listp (aref state 0))) + (condition-case nil + (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)) + (original-velocity velocity) + (time-spent 0)) + (if (> velocity 0) + (while (and (> velocity 0) + (<= time-spent + pixel-scroll-precision-momentum-seconds)) + (when (> (round velocity) 0) + (with-selected-window window + (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) + (with-selected-window window + (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 30)) + (aset state 1 nil))) + (beginning-of-buffer + (message (error-message-string '(beginning-of-buffer)))) + (end-of-buffer + (message (error-message-string '(end-of-buffer))))))))) + +(defun pixel-scroll-interpolate-down () + "Interpolate a scroll downwards by one page." + (interactive) + (if pixel-scroll-precision-interpolate-page + (pixel-scroll-precision-interpolate (- (window-text-height nil t))) + (cua-scroll-up))) + +(defun pixel-scroll-interpolate-up () + "Interpolate a scroll upwards by one page." + (interactive) + (if pixel-scroll-precision-interpolate-page + (pixel-scroll-precision-interpolate (window-text-height nil t)) + (cua-scroll-down))) + +;;;###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/5x5.el b/lisp/play/5x5.el index dde0c4f08ff..8fe72ddf593 100644 --- a/lisp/play/5x5.el +++ b/lisp/play/5x5.el @@ -107,39 +107,37 @@ (defvar 5x5-buffer-name "*5x5*" "Name of the 5x5 play buffer.") -(defvar 5x5-mode-map - (let ((map (make-sparse-keymap))) - (suppress-keymap map t) - (define-key map "?" #'describe-mode) - (define-key map "\r" #'5x5-flip-current) - (define-key map " " #'5x5-flip-current) - (define-key map [up] #'5x5-up) - (define-key map [down] #'5x5-down) - (define-key map [left] #'5x5-left) - (define-key map [tab] #'5x5-right) - (define-key map [right] #'5x5-right) - (define-key map [(control a)] #'5x5-bol) - (define-key map [(control e)] #'5x5-eol) - (define-key map [(control p)] #'5x5-up) - (define-key map [(control n)] #'5x5-down) - (define-key map [(control b)] #'5x5-left) - (define-key map [(control f)] #'5x5-right) - (define-key map [home] #'5x5-bol) - (define-key map [end] #'5x5-eol) - (define-key map [prior] #'5x5-first) - (define-key map [next] #'5x5-last) - (define-key map "r" #'5x5-randomize) - (define-key map [(control c) (control r)] #'5x5-crack-randomly) - (define-key map [(control c) (control c)] #'5x5-crack-mutating-current) - (define-key map [(control c) (control b)] #'5x5-crack-mutating-best) - (define-key map [(control c) (control x)] #'5x5-crack-xor-mutate) - (define-key map "n" #'5x5-new-game) - (define-key map "s" #'5x5-solve-suggest) - (define-key map "<" #'5x5-solve-rotate-left) - (define-key map ">" #'5x5-solve-rotate-right) - (define-key map "q" #'5x5-quit-game) - map) - "Local keymap for the 5x5 game.") +(defvar-keymap 5x5-mode-map + :doc "Local keymap for the 5x5 game." + :suppress 'nodigits + "?" #'describe-mode + "RET" #'5x5-flip-current + "SPC" #'5x5-flip-current + "<up>" #'5x5-up + "<down>" #'5x5-down + "<left>" #'5x5-left + "<tab>" #'5x5-right + "<right>" #'5x5-right + "C-a" #'5x5-bol + "C-e" #'5x5-eol + "C-p" #'5x5-up + "C-n" #'5x5-down + "C-b" #'5x5-left + "C-f" #'5x5-right + "<home>" #'5x5-bol + "<end>" #'5x5-eol + "<prior>" #'5x5-first + "<next>" #'5x5-last + "r" #'5x5-randomize + "C-c C-r" #'5x5-crack-randomly + "C-c C-c" #'5x5-crack-mutating-current + "C-c C-b" #'5x5-crack-mutating-best + "C-c C-x" #'5x5-crack-xor-mutate + "n" #'5x5-new-game + "s" #'5x5-solve-suggest + "<" #'5x5-solve-rotate-left + ">" #'5x5-solve-rotate-right + "q" #'5x5-quit-game) (defvar-local 5x5-solver-output nil "List that is the output of an arithmetic solver. diff --git a/lisp/play/animate.el b/lisp/play/animate.el index 25f560e3203..4f4c936cd67 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/blackbox.el b/lisp/play/blackbox.el index 2eb2d12e29c..8db24c91276 100644 --- a/lisp/play/blackbox.el +++ b/lisp/play/blackbox.el @@ -85,32 +85,21 @@ (defvar bb-balls-placed nil "List of already placed balls.") -;; This is used below to remap existing bindings for cursor motion to -;; blackbox-specific bindings in blackbox-mode-map. This is so that -;; users who prefer non-default key bindings for cursor motion don't -;; lose that when they play Blackbox. -(defun blackbox-redefine-key (map oldfun newfun) - "Redefine keys that run the function OLDFUN to run NEWFUN instead." - (define-key map (vector 'remap oldfun) newfun)) - - -(defvar blackbox-mode-map - (let ((map (make-keymap))) - (suppress-keymap map t) - (blackbox-redefine-key map 'backward-char 'bb-left) - (blackbox-redefine-key map 'left-char 'bb-left) - (blackbox-redefine-key map 'forward-char 'bb-right) - (blackbox-redefine-key map 'right-char 'bb-right) - (blackbox-redefine-key map 'previous-line 'bb-up) - (blackbox-redefine-key map 'next-line 'bb-down) - (blackbox-redefine-key map 'move-end-of-line 'bb-eol) - (blackbox-redefine-key map 'move-beginning-of-line 'bb-bol) - (define-key map " " 'bb-romp) - (define-key map "q" 'bury-buffer) - (define-key map [insert] 'bb-romp) - (define-key map [return] 'bb-done) - (blackbox-redefine-key map 'newline 'bb-done) - map)) +(defvar-keymap blackbox-mode-map + :suppress 'nodigits + "SPC" #'bb-romp + "q" #'bury-buffer + "<insert>" #'bb-romp + "<return>" #'bb-done + "<remap> <backward-char>" #'bb-left + "<remap> <left-char>" #'bb-left + "<remap> <forward-char>" #'bb-right + "<remap> <right-char>" #'bb-right + "<remap> <previous-line>" #'bb-up + "<remap> <next-line>" #'bb-down + "<remap> <move-end-of-line>" #'bb-eol + "<remap> <move-beginning-of-line>" #'bb-bol + "<remap> <newline>" #'bb-done) ;; Blackbox mode is suitable only for specially formatted data. @@ -426,6 +415,11 @@ a reflection." (insert c) (backward-char 1))) +(defun blackbox-redefine-key (map oldfun newfun) + "Redefine keys that run the function OLDFUN to run NEWFUN instead." + (declare (obsolete define-key "29.1")) + (define-key map (vector 'remap oldfun) newfun)) + (provide 'blackbox) ;;; blackbox.el ends here diff --git a/lisp/play/bubbles.el b/lisp/play/bubbles.el index 082f52d98c9..93fbc3b51b7 100644 --- a/lisp/play/bubbles.el +++ b/lisp/play/bubbles.el @@ -809,22 +809,21 @@ static char * dot3d_xpm[] = { (bubbles--update-faces-or-images)) -(defvar bubbles-mode-map - (let ((map (make-sparse-keymap 'bubbles-mode-map))) - ;; (suppress-keymap map t) - (define-key map "q" 'bubbles-quit) - (define-key map "\n" 'bubbles-plop) - (define-key map " " 'bubbles-plop) - (define-key map [double-down-mouse-1] 'bubbles-plop) - (define-key map [mouse-2] 'bubbles-plop) - (define-key map "\C-m" 'bubbles-plop) - (define-key map "u" 'bubbles-undo) - (define-key map "p" 'previous-line) - (define-key map "n" 'next-line) - (define-key map "f" 'forward-char) - (define-key map "b" 'backward-char) - map) - "Mode map for `bubbles'.") +(defvar-keymap bubbles-mode-map + :doc "Mode map for `bubbles'." + :name 'bubbles-mode-map + "q" #'bubbles-quit + "C-j" #'bubbles-plop + "SPC" #'bubbles-plop + "C-m" #'bubbles-plop + "u" #'bubbles-undo + "p" #'previous-line + "n" #'next-line + "f" #'forward-char + "b" #'backward-char + + "<double-down-mouse-1>" #'bubbles-plop + "<mouse-2>" #'bubbles-plop) (easy-menu-define bubbles-menu bubbles-mode-map "Menu for `bubbles'." diff --git a/lisp/play/decipher.el b/lisp/play/decipher.el index aeb4726bb9b..bb3369de5fc 100644 --- a/lisp/play/decipher.el +++ b/lisp/play/decipher.el @@ -138,36 +138,31 @@ the tail of the list." (2 font-lock-string-face))) "Font Lock keywords for Decipher mode.") -(defvar decipher-mode-map - (let ((map (make-keymap))) - (suppress-keymap map) - (define-key map "A" #'decipher-show-alphabet) - (define-key map "C" #'decipher-complete-alphabet) - (define-key map "D" #'decipher-digram-list) - (define-key map "F" #'decipher-frequency-count) - (define-key map "M" #'decipher-make-checkpoint) - (define-key map "N" #'decipher-adjacency-list) - (define-key map "R" #'decipher-restore-checkpoint) - (define-key map "U" #'decipher-undo) - (define-key map " " #'decipher-keypress) - (define-key map [remap undo] #'decipher-undo) - (define-key map [remap advertised-undo] #'decipher-undo) - (let ((key ?a)) - (while (<= key ?z) - (define-key map (vector key) #'decipher-keypress) - (cl-incf key))) - map) - "Keymap for Decipher mode.") - - -(defvar decipher-stats-mode-map - (let ((map (make-keymap))) - (suppress-keymap map) - (define-key map "D" #'decipher-digram-list) - (define-key map "F" #'decipher-frequency-count) - (define-key map "N" #'decipher-adjacency-list) - map) - "Keymap for Decipher-Stats mode.") +(defvar-keymap decipher-mode-map + :doc "Keymap for Decipher mode." + :suppress t + "A" #'decipher-show-alphabet + "C" #'decipher-complete-alphabet + "D" #'decipher-digram-list + "F" #'decipher-frequency-count + "M" #'decipher-make-checkpoint + "N" #'decipher-adjacency-list + "R" #'decipher-restore-checkpoint + "U" #'decipher-undo + "SPC" #'decipher-keypress + "<remap> <undo>" #'decipher-undo + "<remap> <advertised-undo>" #'decipher-undo) +(let ((key ?a)) + (while (<= key ?z) + (keymap-set decipher-mode-map (char-to-string key) #'decipher-keypress) + (cl-incf key))) + +(defvar-keymap decipher-stats-mode-map + :doc "Keymap for Decipher-Stats mode." + :suppress t + "D" #'decipher-digram-list + "F" #'decipher-frequency-count + "N" #'decipher-adjacency-list) (defvar decipher-mode-syntax-table diff --git a/lisp/play/doctor.el b/lisp/play/doctor.el index a640f8ca66d..b93d768cbe3 100644 --- a/lisp/play/doctor.el +++ b/lisp/play/doctor.el @@ -126,11 +126,9 @@ (set what ww) first)) -(defvar doctor-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\n" 'doctor-read-print) - (define-key map "\r" 'doctor-ret-or-read) - map)) +(defvar-keymap doctor-mode-map + "C-j" #'doctor-read-print + "RET" #'doctor-ret-or-read) (define-derived-mode doctor-mode text-mode "Doctor" "Major mode for running the Doctor (Eliza) program. diff --git a/lisp/play/dunnet.el b/lisp/play/dunnet.el index 07f27374df7..b859176bb47 100644 --- a/lisp/play/dunnet.el +++ b/lisp/play/dunnet.el @@ -898,7 +898,7 @@ Regular objects have whole numbers lower than 255. Objects that cannot be taken but might move and are described during room description are negative. Stuff that is described and might change are 255, and are -handled specially by 'dun-describe-room.") +handled specially by `dun-describe-room'.") (defconst dun-room-silents (list nil (list obj-tree obj-coconut) ;; dead-end diff --git a/lisp/play/gamegrid.el b/lisp/play/gamegrid.el index 256b4e19ce8..55c9244f2e4 100644 --- a/lisp/play/gamegrid.el +++ b/lisp/play/gamegrid.el @@ -343,11 +343,17 @@ format." (gamegrid-colorize-glyph color)) ((listp data) (find-image data)) ;untested! - ((vectorp data) - (gamegrid-make-image-from-vector data))))) + ;; Remove when `gamegrid-make-image-from-vector' is removed: + ((vectorp data) + (lwarn 'gamegrid :warning + "Using obsolete XEmacs style \"glyph\"; \ +convert to an Emacs image-spec instead") + (with-suppressed-warnings ((obsolete gamegrid-make-image-from-vector)) + (gamegrid-make-image-from-vector data)))))) (defun gamegrid-make-image-from-vector (vect) "Convert an XEmacs style \"glyph\" to an image-spec." + (declare (obsolete nil "29.1")) (let ((l (list 'image :type))) (dotimes (n (length vect)) (setf l (nconc l (list (aref vect n))))) diff --git a/lisp/play/gametree.el b/lisp/play/gametree.el index c3323ac4527..6a0dc6a623c 100644 --- a/lisp/play/gametree.el +++ b/lisp/play/gametree.el @@ -554,54 +554,55 @@ buffer, it is replaced by the new value. See the documentation for (gametree-hack-file-layout)) nil) -;;;; Key bindings -(defvar gametree-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\C-c\C-j" 'gametree-break-line-here) - (define-key map "\C-c\C-v" 'gametree-insert-new-leaf) - (define-key map "\C-c\C-m" 'gametree-merge-line) - (define-key map "\C-c\C-r " 'gametree-layout-to-register) - (define-key map "\C-c\C-r/" 'gametree-layout-to-register) - (define-key map "\C-c\C-rj" 'gametree-apply-register-layout) - (define-key map "\C-c\C-y" 'gametree-save-and-hack-layout) - (define-key map "\C-c;" 'gametree-insert-score) - (define-key map "\C-c^" 'gametree-compute-and-insert-score) - map)) - -(define-derived-mode gametree-mode outline-mode "GameTree" - "Major mode for managing game analysis trees. -Useful to postal and email chess (and, it is hoped, also checkers, go, -shogi, etc.) players, it is a slightly modified version of Outline mode. - -\\{gametree-mode-map}" - (auto-fill-mode 0) - (add-hook 'write-contents-functions 'gametree-save-and-hack-layout nil t)) + +;;;; Mouse commands -;;;; Goodies for mousing users (defun gametree-mouse-break-line-here (event) (interactive "e") (mouse-set-point event) (gametree-break-line-here)) + (defun gametree-mouse-show-children-and-entry (event) (interactive "e") (mouse-set-point event) (gametree-show-children-and-entry)) + (defun gametree-mouse-show-subtree (event) (interactive "e") (mouse-set-point event) (outline-show-subtree)) + (defun gametree-mouse-hide-subtree (event) (interactive "e") (mouse-set-point event) (outline-hide-subtree)) -(define-key gametree-mode-map [M-down-mouse-2 M-mouse-2] - 'gametree-mouse-break-line-here) -(define-key gametree-mode-map [S-down-mouse-1 S-mouse-1] - 'gametree-mouse-show-children-and-entry) -(define-key gametree-mode-map [S-down-mouse-2 S-mouse-2] - 'gametree-mouse-show-subtree) -(define-key gametree-mode-map [S-down-mouse-3 S-mouse-3] - 'gametree-mouse-hide-subtree) + + +;;;; Key bindings + +(defvar-keymap gametree-mode-map + "C-c C-j" #'gametree-break-line-here + "C-c C-v" #'gametree-insert-new-leaf + "C-c C-m" #'gametree-merge-line + "C-c C-r SPC" #'gametree-layout-to-register + "C-c C-r /" #'gametree-layout-to-register + "C-c C-r j" #'gametree-apply-register-layout + "C-c C-y" #'gametree-save-and-hack-layout + "C-c ;" #'gametree-insert-score + "C-c ^" #'gametree-compute-and-insert-score + "M-<down-mouse-2> M-<mouse-2>" #'gametree-mouse-break-line-here + "S-<down-mouse-1> S-<mouse-1>" #'gametree-mouse-show-children-and-entry + "S-<down-mouse-2> S-<mouse-2>" #'gametree-mouse-show-subtree + "S-<down-mouse-3> S-<mouse-3>" #'gametree-mouse-hide-subtree) + +(define-derived-mode gametree-mode outline-mode "GameTree" + "Major mode for managing game analysis trees. +Useful to postal and email chess (and, it is hoped, also checkers, go, +shogi, etc.) players, it is a slightly modified version of Outline mode. + +\\{gametree-mode-map}" + (auto-fill-mode 0) + (add-hook 'write-contents-functions 'gametree-save-and-hack-layout nil t)) (provide 'gametree) diff --git a/lisp/play/gomoku.el b/lisp/play/gomoku.el index 02aff75e157..f8822c30db1 100644 --- a/lisp/play/gomoku.el +++ b/lisp/play/gomoku.el @@ -100,65 +100,61 @@ SHOULD be at least 2 (MUST BE at least 1).") "Number of lines between the Gomoku board and the top of the window.") -(defvar gomoku-mode-map - (let ((map (make-sparse-keymap))) - - ;; Key bindings for cursor motion. - (define-key map "y" 'gomoku-move-nw) ; y - (define-key map "u" 'gomoku-move-ne) ; u - (define-key map "b" 'gomoku-move-sw) ; b - (define-key map "n" 'gomoku-move-se) ; n - (define-key map "h" 'gomoku-move-left) ; h - (define-key map "l" 'gomoku-move-right) ; l - (define-key map "j" 'gomoku-move-down) ; j - (define-key map "k" 'gomoku-move-up) ; k - - (define-key map [kp-7] 'gomoku-move-nw) - (define-key map [kp-9] 'gomoku-move-ne) - (define-key map [kp-1] 'gomoku-move-sw) - (define-key map [kp-3] 'gomoku-move-se) - (define-key map [kp-4] 'gomoku-move-left) - (define-key map [kp-6] 'gomoku-move-right) - (define-key map [kp-2] 'gomoku-move-down) - (define-key map [kp-8] 'gomoku-move-up) - - (define-key map "\C-b" 'gomoku-move-left) ; C-b - (define-key map "\C-f" 'gomoku-move-right) ; C-f - (define-key map "\C-n" 'gomoku-move-down) ; C-n - (define-key map "\C-p" 'gomoku-move-up) ; C-p - - ;; Key bindings for entering Human moves. - (define-key map "X" 'gomoku-human-plays) ; X - (define-key map "x" 'gomoku-human-plays) ; x - (define-key map " " 'gomoku-human-plays) ; SPC - (define-key map "\C-m" 'gomoku-human-plays) ; RET - (define-key map "\C-c\C-p" 'gomoku-human-plays) ; C-c C-p - (define-key map "\C-c\C-b" 'gomoku-human-takes-back) ; C-c C-b - (define-key map "\C-c\C-r" 'gomoku-human-resigns) ; C-c C-r - (define-key map "\C-c\C-e" 'gomoku-emacs-plays) ; C-c C-e - - (define-key map [kp-enter] 'gomoku-human-plays) - (define-key map [insert] 'gomoku-human-plays) - (define-key map [down-mouse-1] 'gomoku-click) - (define-key map [drag-mouse-1] 'gomoku-click) - (define-key map [mouse-1] 'gomoku-click) - (define-key map [down-mouse-2] 'gomoku-click) - (define-key map [mouse-2] 'gomoku-mouse-play) - (define-key map [drag-mouse-2] 'gomoku-mouse-play) - - (define-key map [remap backward-char] 'gomoku-move-left) - (define-key map [remap left-char] 'gomoku-move-left) - (define-key map [remap forward-char] 'gomoku-move-right) - (define-key map [remap right-char] 'gomoku-move-right) - (define-key map [remap previous-line] 'gomoku-move-up) - (define-key map [remap next-line] 'gomoku-move-down) - (define-key map [remap move-beginning-of-line] 'gomoku-beginning-of-line) - (define-key map [remap move-end-of-line] 'gomoku-end-of-line) - (define-key map [remap undo] 'gomoku-human-takes-back) - (define-key map [remap advertised-undo] 'gomoku-human-takes-back) - map) - - "Local keymap to use in Gomoku mode.") +(defvar-keymap gomoku-mode-map + :doc "Local keymap to use in Gomoku mode." + ;; Key bindings for cursor motion. + "y" #'gomoku-move-nw + "u" #'gomoku-move-ne + "b" #'gomoku-move-sw + "n" #'gomoku-move-se + "h" #'gomoku-move-left + "l" #'gomoku-move-right + "j" #'gomoku-move-down + "k" #'gomoku-move-up + + "<kp-7>" #'gomoku-move-nw + "<kp-9>" #'gomoku-move-ne + "<kp-1>" #'gomoku-move-sw + "<kp-3>" #'gomoku-move-se + "<kp-4>" #'gomoku-move-left + "<kp-6>" #'gomoku-move-right + "<kp-2>" #'gomoku-move-down + "<kp-8>" #'gomoku-move-up + + "C-b" #'gomoku-move-left + "C-f" #'gomoku-move-right + "C-n" #'gomoku-move-down + "C-p" #'gomoku-move-up + + ;; Key bindings for entering Human moves. + "X" #'gomoku-human-plays + "x" #'gomoku-human-plays + "SPC" #'gomoku-human-plays + "RET" #'gomoku-human-plays + "C-c C-p" #'gomoku-human-plays + "C-c C-b" #'gomoku-human-takes-back + "C-c C-r" #'gomoku-human-resigns + "C-c C-e" #'gomoku-emacs-plays + + "<kp-enter>" #'gomoku-human-plays + "<insert>" #'gomoku-human-plays + "<down-mouse-1>" #'gomoku-click + "<drag-mouse-1>" #'gomoku-click + "<mouse-1>" #'gomoku-click + "<down-mouse-2>" #'gomoku-click + "<mouse-2>" #'gomoku-mouse-play + "<drag-mouse-2>" #'gomoku-mouse-play + + "<remap> <backward-char>" #'gomoku-move-left + "<remap> <left-char>" #'gomoku-move-left + "<remap> <forward-char>" #'gomoku-move-right + "<remap> <right-char>" #'gomoku-move-right + "<remap> <previous-line>" #'gomoku-move-up + "<remap> <next-line>" #'gomoku-move-down + "<remap> <move-beginning-of-line>" #'gomoku-beginning-of-line + "<remap> <move-end-of-line>" #'gomoku-end-of-line + "<remap> <undo>" #'gomoku-human-takes-back + "<remap> <advertised-undo>" #'gomoku-human-takes-back) (defvar gomoku-emacs-won () diff --git a/lisp/play/handwrite.el b/lisp/play/handwrite.el index 14624ddce23..68a82f5a9ef 100644 --- a/lisp/play/handwrite.el +++ b/lisp/play/handwrite.el @@ -1,6 +1,6 @@ ;;; handwrite.el --- turns your emacs buffer into a handwritten document -*- lexical-binding: t -*- -;; Copyright (C) 1996, 2001-2022 Free Software Foundation, Inc. +;; Copyright (C) 1996-2022 Free Software Foundation, Inc. ;; Author: Danny Roozendaal (was: <danny@tvs.kun.nl>) ;; Maintainer: emacs-devel@gnu.org @@ -29,44 +29,42 @@ ;; ;; Other functions that may be useful are: ;; -;; handwrite-10pt: sets the font size to 10 and finds corresponding -;; values for the line spacing and the number of lines -;; on a page. -;; handwrite-11pt: which is similar -;; handwrite-12pt: which is also similar -;; handwrite-13pt: which is similar, too +;; `handwrite-10pt': set the font size to 10 and find corresponding +;; values for the line spacing and the number of lines +;; on a page. +;; `handwrite-11pt': which is similar +;; `handwrite-12pt': which is also similar +;; `handwrite-13pt': which is similar, too ;; -;; handwrite-set-pagenumber: set and unset page numbering +;; `handwrite-set-pagenumber': set and unset page numbering ;; ;; ;; If you are not satisfied with the type page there are a number of ;; variables you may want to set. ;; -;; To use this, say "M-x handwrite" or type at your prompt +;; To use this, say `M-x handwrite' or type at your prompt ;; "emacs -l handwrite.el". ;; ;; I tried to make it `iso_8859_1'-friendly, but there are some exotic ;; characters missing. ;; ;; -;; Known bugs: -Page feeds do not do their work, but are ignored instead. -;; -Tabs are not always properly displayed. -;; -Handwrite may create corrupt PostScript if it encounters -;; unknown characters. +;; Known bugs: +;; - Page feeds do not work, and are ignored instead. +;; - Tabs are not always properly displayed. +;; - Handwrite may create corrupt PostScript if it encounters +;; unknown characters. ;; ;; Thanks to anyone who emailed me suggestions! ;;; Code: -;; From ps-print.el -(defvar ps-printer-name) -(defvar ps-lpr-command) -(defvar ps-lpr-switches) +(require 'ps-print) ;; Variables (defgroup handwrite nil - "Turns your Emacs buffer into a handwritten document." + "Turn your Emacs buffer into a handwritten document." :prefix "handwrite-" :group 'games) @@ -235,20 +233,13 @@ Variables: `handwrite-linespace' (default 12) (while (search-forward "\f" nil t) (replace-match "" nil t) ) (untabify textp (point-max)) ; this may result in strange tabs - (if (y-or-n-p "Send this to the printer? ") - (progn - (require 'ps-print) - (let* ((coding-system-for-write 'raw-text-unix) - (ps-printer-name (or ps-printer-name - (and (boundp 'printer-name) - printer-name))) - (ps-lpr-switches - (if (stringp ps-printer-name) - (list (concat "-P" ps-printer-name))))) - (apply (or (and (boundp 'ps-print-region-function) - ps-print-region-function) - 'call-process-region) - (point-min) (point-max) ps-lpr-command nil nil nil)))) + (when (y-or-n-p "Send this to the printer? ") + (let* ((coding-system-for-write 'raw-text-unix) + (printer-name (or ps-printer-name printer-name)) + (lpr-printer-switch ps-printer-name-option) + (print-region-function ps-print-region-function) + (lpr-command ps-lpr-command)) + (lpr-print-region (point-min) (point-max) ps-lpr-switches nil))) (message "") (bury-buffer ()) (switch-to-buffer cur-buf) @@ -264,8 +255,8 @@ Variables: `handwrite-linespace' (default 12) (defun handwrite-10pt () "Specify 10-point output for `handwrite'. -This sets `handwrite-fontsize' to 10 and finds correct -values for `handwrite-linespace' and `handwrite-numlines'." +Set `handwrite-fontsize' to 10 and find correct values for +`handwrite-linespace' and `handwrite-numlines'." (interactive) (setq handwrite-fontsize 10) (setq handwrite-linespace 11) @@ -274,8 +265,8 @@ values for `handwrite-linespace' and `handwrite-numlines'." (defun handwrite-11pt () "Specify 11-point output for `handwrite'. -This sets `handwrite-fontsize' to 11 and finds correct -values for `handwrite-linespace' and `handwrite-numlines'." +Set `handwrite-fontsize' to 11 and find correct values for +`handwrite-linespace' and `handwrite-numlines'." (interactive) (setq handwrite-fontsize 11) (setq handwrite-linespace 12) @@ -284,8 +275,8 @@ values for `handwrite-linespace' and `handwrite-numlines'." (defun handwrite-12pt () "Specify 12-point output for `handwrite'. -This sets `handwrite-fontsize' to 12 and finds correct -values for `handwrite-linespace' and `handwrite-numlines'." +Set `handwrite-fontsize' to 12 and find correct values for +`handwrite-linespace' and `handwrite-numlines'." (interactive) (setq handwrite-fontsize 12) (setq handwrite-linespace 13) @@ -294,8 +285,8 @@ values for `handwrite-linespace' and `handwrite-numlines'." (defun handwrite-13pt () "Specify 13-point output for `handwrite'. -This sets `handwrite-fontsize' to 13 and finds correct -values for `handwrite-linespace' and `handwrite-numlines'." +Set `handwrite-fontsize' to 13 and find correct values for +`handwrite-linespace' and `handwrite-numlines'." (interactive) (setq handwrite-fontsize 13) (setq handwrite-linespace 14) diff --git a/lisp/play/morse.el b/lisp/play/morse.el index 974e9fbc49c..5b7d343a79e 100644 --- a/lisp/play/morse.el +++ b/lisp/play/morse.el @@ -1,6 +1,6 @@ ;;; morse.el --- convert text to morse code and back -*- lexical-binding: t -*- -;; Copyright (C) 1995, 2001-2022 Free Software Foundation, Inc. +;; Copyright (C) 1995-2022 Free Software Foundation, Inc. ;; Author: Rick Farnbach <rick_farnbach@MENTORG.COM> ;; Keywords: games @@ -22,11 +22,11 @@ ;;; Commentary: -;; Converts text to Morse code and back with M-x morse-region and -;; M-x unmorse-region (though Morse code is no longer official :-(). +;; Convert plain text to Morse code and back with `M-x morse-region' and +;; `M-x unmorse-region'. -;; Converts text to NATO phonetic alphabet and back with M-x -;; nato-region and M-x denato-region. +;; Convert plain text to NATO spelling alphabet and back with +;; `M-x nato-region' and `M-x denato-region'. ;;; Code: @@ -142,14 +142,16 @@ ("(" . "Open") (")" . "Close") ("@" . "At")) - "NATO phonetic alphabet. + "NATO spelling alphabet. See “International Code of Signals” (INTERCO), United States Edition, 1969 Edition (Revised 2003) available from National -Geospatial-Intelligence Agency at URL `https://www.nga.mil/'") +Geospatial-Intelligence Agency at <https://www.nga.mil/>. +See also <https://en.wikipedia.org/wiki/NATO_phonetic_alphabet>.") ;;;###autoload (defun morse-region (beg end) - "Convert all text in a given region to morse code." + "Convert plain text in region to Morse code. +See <https://en.wikipedia.org/wiki/Morse_code>." (interactive "*r") (if (integerp end) (setq end (copy-marker end))) @@ -172,7 +174,7 @@ Geospatial-Intelligence Agency at URL `https://www.nga.mil/'") ;;;###autoload (defun unmorse-region (beg end) - "Convert morse coded text in region to ordinary ASCII text." + "Convert Morse coded text in region to plain text." (interactive "*r") (if (integerp end) (setq end (copy-marker end))) @@ -194,7 +196,7 @@ Geospatial-Intelligence Agency at URL `https://www.nga.mil/'") ;;;###autoload (defun nato-region (beg end) - "Convert all text in a given region to NATO phonetic alphabet." + "Convert plain text in region to NATO spelling alphabet." ;; Copied from morse-region. -- ashawley 2009-02-10 (interactive "*r") (if (integerp end) @@ -218,7 +220,7 @@ Geospatial-Intelligence Agency at URL `https://www.nga.mil/'") ;;;###autoload (defun denato-region (beg end) - "Convert NATO phonetic alphabet in region to ordinary ASCII text." + "Convert NATO spelling alphabet text in region to plain text." ;; Copied from unmorse-region. -- ashawley 2009-02-10 (interactive "*r") (if (integerp end) diff --git a/lisp/play/mpuz.el b/lisp/play/mpuz.el index 860ba4817ec..1cacf01a20c 100644 --- a/lisp/play/mpuz.el +++ b/lisp/play/mpuz.el @@ -76,17 +76,12 @@ The value t means never ding, and `error' means only ding on wrong input." "Hook to run upon entry to mpuz." :type 'hook) -(defvar mpuz-mode-map - (let ((map (make-sparse-keymap))) - (mapc (lambda (ch) - (define-key map (char-to-string ch) 'mpuz-try-letter)) - "abcdefghijABCDEFGHIJ") - (define-key map "\C-g" 'mpuz-offer-abort) - (define-key map "?" 'describe-mode) - map) - "Local keymap to use in Mult Puzzle.") - - +(defvar-keymap mpuz-mode-map + :doc "Local keymap to use in Mult Puzzle." + "C-g" #'mpuz-offer-abort + "?" #'describe-mode) +(dolist (ch (mapcar #'char-to-string "abcdefghijABCDEFGHIJ")) + (keymap-set mpuz-mode-map ch #'mpuz-try-letter)) (define-derived-mode mpuz-mode fundamental-mode "Mult Puzzle" :interactive nil diff --git a/lisp/play/pong.el b/lisp/play/pong.el index bc71e2a2666..79beeb72e2b 100644 --- a/lisp/play/pong.el +++ b/lisp/play/pong.el @@ -173,23 +173,23 @@ ;;; Initialize maps -(defvar pong-mode-map - (let ((map (make-sparse-keymap 'pong-mode-map))) - (define-key map [left] 'pong-move-left) - (define-key map [right] 'pong-move-right) - (define-key map [up] 'pong-move-up) - (define-key map [down] 'pong-move-down) - (define-key map pong-left-key 'pong-move-left) - (define-key map pong-right-key 'pong-move-right) - (define-key map pong-up-key 'pong-move-up) - (define-key map pong-down-key 'pong-move-down) - (define-key map pong-quit-key 'pong-quit) - (define-key map pong-pause-key 'pong-pause) - map) - "Modemap for pong-mode.") - -(defvar pong-null-map - (make-sparse-keymap 'pong-null-map) "Null map for pong-mode.") +(defvar-keymap pong-mode-map + :doc "Modemap for pong-mode." + :name 'pong-mode-map + "<left>" #'pong-move-left + "<right>" #'pong-move-right + "<up>" #'pong-move-up + "<down>" #'pong-move-down + pong-left-key #'pong-move-left + pong-right-key #'pong-move-right + pong-up-key #'pong-move-up + pong-down-key #'pong-move-down + pong-quit-key #'pong-quit + pong-pause-key #'pong-pause) + +(defvar-keymap pong-null-map + :doc "Null map for pong-mode." + :name 'pong-null-map) diff --git a/lisp/play/snake.el b/lisp/play/snake.el index 1056b17c91b..d8074edfc4c 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/solitaire.el b/lisp/play/solitaire.el index 2fc33fa2335..3c6d85b4094 100644 --- a/lisp/play/solitaire.el +++ b/lisp/play/solitaire.el @@ -40,48 +40,46 @@ "Hook to run upon entry to Solitaire." :type 'hook) -(defvar solitaire-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map special-mode-map) - - (define-key map "\C-f" 'solitaire-right) - (define-key map "\C-b" 'solitaire-left) - (define-key map "\C-p" 'solitaire-up) - (define-key map "\C-n" 'solitaire-down) - (define-key map "\r" 'solitaire-move) - (define-key map [remap undo] 'solitaire-undo) - (define-key map " " 'solitaire-do-check) - - (define-key map [right] 'solitaire-right) - (define-key map [left] 'solitaire-left) - (define-key map [up] 'solitaire-up) - (define-key map [down] 'solitaire-down) - - (define-key map [S-right] 'solitaire-move-right) - (define-key map [S-left] 'solitaire-move-left) - (define-key map [S-up] 'solitaire-move-up) - (define-key map [S-down] 'solitaire-move-down) - - (define-key map [kp-6] 'solitaire-right) - (define-key map [kp-4] 'solitaire-left) - (define-key map [kp-8] 'solitaire-up) - (define-key map [kp-2] 'solitaire-down) - (define-key map [kp-5] 'solitaire-center-point) - - (define-key map [S-kp-6] 'solitaire-move-right) - (define-key map [S-kp-4] 'solitaire-move-left) - (define-key map [S-kp-8] 'solitaire-move-up) - (define-key map [S-kp-2] 'solitaire-move-down) - - (define-key map [kp-enter] 'solitaire-move) - (define-key map [kp-0] 'solitaire-undo) - - ;; spoil it with s ;) - (define-key map [?s] 'solitaire-solve) - - ;; (define-key map [kp-0] 'solitaire-hint) - Not yet provided ;) - map) - "Keymap for playing Solitaire.") +(defvar-keymap solitaire-mode-map + :doc "Keymap for playing Solitaire." + :parent special-mode-map + "C-f" #'solitaire-right + "C-b" #'solitaire-left + "C-p" #'solitaire-up + "C-n" #'solitaire-down + "RET" #'solitaire-move + "SPC" #'solitaire-do-check + + "<right>" #'solitaire-right + "<left>" #'solitaire-left + "<up>" #'solitaire-up + "<down>" #'solitaire-down + + "S-<right>" #'solitaire-move-right + "S-<left>" #'solitaire-move-left + "S-<up>" #'solitaire-move-up + "S-<down>" #'solitaire-move-down + + "<kp-6>" #'solitaire-right + "<kp-4>" #'solitaire-left + "<kp-8>" #'solitaire-up + "<kp-2>" #'solitaire-down + "<kp-5>" #'solitaire-center-point + + "S-<kp-6>" #'solitaire-move-right + "S-<kp-4>" #'solitaire-move-left + "S-<kp-8>" #'solitaire-move-up + "S-<kp-2>" #'solitaire-move-down + + "<kp-enter>" #'solitaire-move + "<kp-0>" #'solitaire-undo + "<remap> <undo>" #'solitaire-undo + + ;; spoil it with s ;) + "s" #'solitaire-solve + + ;; "[kp-0]" #'solitaire-hint - Not yet provided ;) + ) ;; Solitaire mode is suitable only for specially formatted data. (put 'solitaire-mode 'mode-class 'special) diff --git a/lisp/play/tetris.el b/lisp/play/tetris.el index 6fe82fa7fc9..8ce2453c753 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 f451091332f..a27638d3679 100644 --- a/lisp/proced.el +++ b/lisp/proced.el @@ -29,10 +29,6 @@ ;; ;; To do: ;; - Interactive temporary customizability of flags in `proced-grammar-alist' -;; - Allow "sudo kill PID", "sudo renice PID" -;; `proced-send-signal' operates on multiple processes one by one. -;; With "sudo" we want to execute one "kill" or "renice" command -;; for all marked processes. Is there a `sudo-call-process'? ;; ;; Thoughts and Ideas ;; - Currently, `process-attributes' returns the list of @@ -55,12 +51,19 @@ :group 'unix :prefix "proced-") +(defcustom proced-show-remote-processes nil + "Whether processes of the remote host shall be shown. +This happens only when `default-directory' is remote." + :version "29.1" + :type 'boolean) + (defcustom proced-signal-function #'signal-process "Name of signal function. It can be an elisp function (usually `signal-process') or a string specifying the external command (usually \"kill\")." :type '(choice (function :tag "function") (string :tag "command"))) +(make-obsolete-variable 'proced-signal-function "no longer used." "29.1") (defcustom proced-renice-command "renice" "Name of renice command." @@ -275,8 +278,8 @@ It can also be a list of keys appearing in `proced-grammar-alist'." ;; FIXME: is there a better name for filter `user' that does not coincide ;; with an attribute key? (defcustom proced-filter-alist - `((user (user . ,(concat "\\`" (regexp-quote (user-real-login-name)) "\\'"))) - (user-running (user . ,(concat "\\`" (regexp-quote (user-real-login-name)) "\\'")) + `((user (user . proced-user-name)) + (user-running (user . proced-user-name) (state . "\\`[Rr]\\'")) (all) (all-running (state . "\\`[Rr]\\'")) @@ -366,7 +369,7 @@ May be used to revert the process listing." ;; Internal variables -(defvar proced-available (not (null (list-system-processes))) +(defvar proced-available t;(not (null (list-system-processes))) "Non-nil means Proced is known to work on this system.") (defvar-local proced-process-alist nil @@ -565,6 +568,12 @@ Important: the match ends just after the marker.") :help "Renice Marked Processes"])) ;; helper functions +(defun proced-user-name (user) + "Check the `user' attribute with user name `proced' is running for." + (string-equal user (if (file-remote-p default-directory) + (file-remote-p default-directory 'user) + (user-real-login-name)))) + (defun proced-marker-regexp () "Return regexp matching `proced-marker-char'." ;; `proced-marker-char' must appear in column zero @@ -626,6 +635,7 @@ Return nil if point is not on a process line." Type \\[proced] to start a Proced session. In a Proced buffer type \\<proced-mode-map>\\[proced-mark] to mark a process for later commands. Type \\[proced-send-signal] to send signals to marked processes. +Type \\[proced-renice] to renice marked processes. The initial content of a listing is defined by the variable `proced-filter' and the variable `proced-format'. @@ -658,6 +668,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 @@ -676,8 +687,13 @@ After displaying or updating a Proced buffer, Proced runs the normal hook (defun proced (&optional arg) "Generate a listing of UNIX system processes. \\<proced-mode-map> -If invoked with optional ARG, do not select the window displaying -the process information. +If invoked with optional non-negative ARG, do not select the +window displaying the process information. + +If `proced-show-remote-processes' is non-nil or the command is +invoked with a negative ARG `\\[universal-argument] \\[negative-argument]', \ +and `default-directory' +points to a remote host, the system processes of that host are shown. This function runs the normal hook `proced-post-display-hook'. @@ -688,6 +704,11 @@ Proced buffers." (error "Proced is not available on this system")) (let ((buffer (get-buffer-create "*Proced*")) new) (set-buffer buffer) + (when (and (file-remote-p default-directory) + (not + (or proced-show-remote-processes + (eq arg '-)))) + (setq default-directory temporary-file-directory)) (setq new (zerop (buffer-size))) (when new (proced-mode) @@ -721,7 +742,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 +754,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 +783,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 +809,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 +851,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 +891,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 +968,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 +1079,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 +1162,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 +1291,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 +1313,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 +1352,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) @@ -1403,7 +1426,7 @@ Replace newline characters by \"^J\" (two characters)." ;; If none of the alternatives is non-nil, the attribute is ignored ;; in the listing. (let ((standard-attributes - (car (proced-process-attributes (list (emacs-pid))))) + (car (proced-process-attributes (list-system-processes)))) new-format fmi) (if (and proced-tree-flag (assq 'ppid standard-attributes)) @@ -1535,7 +1558,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 +1591,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 +1797,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 +1823,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")))))) @@ -1816,7 +1841,8 @@ supported but discouraged. It will be removed in a future version of Emacs." (dolist (process process-alist) (condition-case err (unless (zerop (funcall - proced-signal-function (car process) signal)) + proced-signal-function (car process) signal + (file-remote-p default-directory))) (proced-log "%s\n" (cdr process)) (push (cdr process) failures)) (error ; catch errors from failed signals @@ -1828,7 +1854,7 @@ supported but discouraged. It will be removed in a future version of Emacs." (dolist (process process-alist) (with-temp-buffer (condition-case nil - (unless (zerop (call-process + (unless (zerop (process-file proced-signal-function nil t nil signal (number-to-string (car process)))) (proced-log (current-buffer)) @@ -1862,14 +1888,15 @@ 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) (dolist (process process-alist) (with-temp-buffer (condition-case nil - (unless (zerop (call-process + (unless (zerop (process-file proced-renice-command nil t nil priority (number-to-string (car process)))) (proced-log (current-buffer)) @@ -1894,7 +1921,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 +1973,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 +1983,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/antlr-mode.el b/lisp/progmodes/antlr-mode.el index 4bc6de0c759..d6e2ab8a87a 100644 --- a/lisp/progmodes/antlr-mode.el +++ b/lisp/progmodes/antlr-mode.el @@ -2437,7 +2437,6 @@ the default language." #'antlr-imenu-create-index-function) (set (make-local-variable 'imenu-generic-expression) t) ; fool stupid test (and antlr-imenu-name ; there should be a global variable... - (fboundp 'imenu-add-to-menubar) (imenu-add-to-menubar (if (stringp antlr-imenu-name) antlr-imenu-name "Index"))) (antlr-set-tabs)) diff --git a/lisp/progmodes/asm-mode.el b/lisp/progmodes/asm-mode.el index 370fb1b80b4..aaf063b5174 100644 --- a/lisp/progmodes/asm-mode.el +++ b/lisp/progmodes/asm-mode.el @@ -24,16 +24,16 @@ ;;; Commentary: ;; This mode was written by Eric S. Raymond <esr@snark.thyrsus.com>, -;; inspired by an earlier asm-mode by Martin Neitzel. +;; inspired by an earlier `asm-mode' by Martin Neitzel. -;; This major mode is based on prog mode. It defines a private abbrev table -;; that can be used to save abbrevs for assembler mnemonics. It binds just -;; five keys: +;; This major mode is based on `prog-mode'. It defines a private +;; abbrev table that can be used to save abbrevs for assembler +;; mnemonics. It binds just five keys: ;; ;; TAB tab to next tab stop ;; : outdent preceding label, tab to tab stop ;; comment char place or move comment -;; asm-comment-char specifies which character this is; +;; `asm-comment-char' specifies which character this is; ;; you can use a different character in different ;; Asm mode buffers. ;; C-j, C-m newline and tab to tab stop @@ -41,9 +41,9 @@ ;; Code is indented to the first tab stop level. ;; This mode runs two hooks: -;; 1) An asm-mode-set-comment-hook before the part of the initialization -;; depending on asm-comment-char, and -;; 2) an asm-mode-hook at the end of initialization. +;; 1) `asm-mode-set-comment-hook' before the part of the initialization +;; depending on `asm-comment-char', and +;; 2) `asm-mode-hook' at the end of initialization. ;;; Code: @@ -68,13 +68,11 @@ "Abbrev table used while in Asm mode.") (define-abbrev-table 'asm-mode-abbrev-table ()) -(defvar asm-mode-map - (let ((map (make-sparse-keymap))) - ;; Note that the comment character isn't set up until asm-mode is called. - (define-key map ":" 'asm-colon) - (define-key map "\C-c;" 'comment-region) - map) - "Keymap for Asm mode.") +(defvar-keymap asm-mode-map + :doc "Keymap for Asm mode." + ;; Note that the comment character isn't set up until asm-mode is called. + ":" #'asm-colon + "C-c ;" #'comment-region) (easy-menu-define asm-mode-menu asm-mode-map "Menu for Asm mode." @@ -130,7 +128,7 @@ Special commands: (setq-local tab-always-indent nil) (run-hooks 'asm-mode-set-comment-hook) - ;; Make our own local child of asm-mode-map + ;; Make our own local child of `asm-mode-map' ;; so we can define our own comment character. (use-local-map (nconc (make-sparse-keymap) asm-mode-map)) (local-set-key (vector asm-comment-char) #'asm-comment) diff --git a/lisp/progmodes/bat-mode.el b/lisp/progmodes/bat-mode.el index 7ef2500e46b..6bac297a298 100644 --- a/lisp/progmodes/bat-mode.el +++ b/lisp/progmodes/bat-mode.el @@ -71,8 +71,8 @@ "doskey" "echo" "endlocal" "erase" "fc" "find" "findstr" "format" "ftype" "label" "md" "mkdir" "more" "move" "net" "path" "pause" "popd" "prompt" "pushd" "rd" "ren" "rename" "replace" "rmdir" "set" - "setlocal" "shift" "sort" "subst" "time" "title" "tree" "type" - "ver" "vol" "xcopy")) + "setlocal" "setx" "shift" "sort" "subst" "time" "title" "tree" + "type" "ver" "vol" "xcopy")) (CONTROLFLOW '("call" "cmd" "defined" "do" "else" "equ" "exist" "exit" "for" "geq" "goto" "gtr" "if" "in" "leq" "lss" "neq" "not" "start")) @@ -82,7 +82,7 @@ (2 font-lock-constant-face t)) ("^:[^:].*" . 'bat-label-face) - ("\\_<\\(defined\\|set\\)\\_>[ \t]*\\(\\(\\sw\\|\\s_\\)+\\)" + ("\\_<\\(defined\\|set\\|setx\\)\\_>[ \t]*\\(\\(\\sw\\|\\s_\\)+\\)" (2 font-lock-variable-name-face)) ("%~\\([0-9]\\)" (1 font-lock-variable-name-face)) diff --git a/lisp/progmodes/bug-reference.el b/lisp/progmodes/bug-reference.el index 0a2d5ed796b..d3626dbaf01 100644 --- a/lisp/progmodes/bug-reference.el +++ b/lisp/progmodes/bug-reference.el @@ -40,12 +40,10 @@ ;; Somewhat arbitrary, by analogy with eg goto-address. :group 'comm) -(defvar bug-reference-map - (let ((map (make-sparse-keymap))) - (define-key map [mouse-2] 'bug-reference-push-button) - (define-key map (kbd "C-c RET") 'bug-reference-push-button) - map) - "Keymap used by bug reference buttons.") +(defvar-keymap bug-reference-map + :doc "Keymap used by bug reference buttons." + "<mouse-2>" #'bug-reference-push-button + "C-c RET" #'bug-reference-push-button) ;; E.g., "https://gcc.gnu.org/PR%s" (defvar bug-reference-url-format nil @@ -269,9 +267,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 +283,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 +300,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 +321,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-align.el b/lisp/progmodes/cc-align.el index 8298d5fef04..e14f5b9058f 100644 --- a/lisp/progmodes/cc-align.el +++ b/lisp/progmodes/cc-align.el @@ -202,6 +202,58 @@ Works with: arglist-cont-nonempty, arglist-close." (skip-chars-forward " \t")) (vector (current-column))))))) +(defun c-lineup-argcont-1 (elem) + ;; Move to the start of the current arg and return non-nil, otherwise + ;; return nil. + (beginning-of-line) + + (when (eq (car elem) 'arglist-cont-nonempty) + ;; Our argument list might not be the innermost one. If it + ;; isn't, go back to the first position in it. We do this by + ;; stepping back over open parens until we get to the open paren + ;; of our argument list. + (let ((open-paren (c-langelem-2nd-pos c-syntactic-element)) + (paren-state (c-parse-state))) + (while (not (eq (car paren-state) open-paren)) + (unless (consp (car paren-state)) ;; ignore matched braces + (goto-char (car paren-state))) + (setq paren-state (cdr paren-state))))) + + (let ((start (point)) c) + + (when (bolp) + ;; Previous line ending in a comma means we're the start of an + ;; argument. This should quickly catch most cases not for us. + ;; This case is only applicable if we're the innermost arglist. + (c-backward-syntactic-ws) + (setq c (char-before))) + + (unless (eq c ?,) + ;; In a gcc asm, ":" on the previous line means the start of an + ;; argument. And lines starting with ":" are not for us, don't + ;; want them to indent to the preceding operand. + (let ((gcc-asm (save-excursion + (goto-char start) + (c-in-gcc-asm-p)))) + (unless (and gcc-asm + (or (eq c ?:) + (save-excursion + (goto-char start) + (looking-at "[ \t]*:")))) + + (c-lineup-argcont-scan (if gcc-asm ?:)) + t))))) + +(defun c-lineup-argcont-scan (&optional other-match) + ;; Find the start of an argument, for `c-lineup-argcont'. + (when (zerop (c-backward-token-2 1 t)) + (let ((c (char-after))) + (if (or (eq c ?,) (eq c other-match)) + (progn + (forward-char) + (c-forward-syntactic-ws)) + (c-lineup-argcont-scan other-match))))) + ;; Contributed by Kevin Ryde <user42@zip.com.au>. (defun c-lineup-argcont (elem) "Line up a continued argument. @@ -217,56 +269,30 @@ but of course only between operand specifications, not in the expressions for the operands. Works with: arglist-cont, arglist-cont-nonempty." - (save-excursion - (beginning-of-line) + (when (c-lineup-argcont-1 elem) + (vector (current-column))))) - (when (eq (car elem) 'arglist-cont-nonempty) - ;; Our argument list might not be the innermost one. If it - ;; isn't, go back to the last position in it. We do this by - ;; stepping back over open parens until we get to the open paren - ;; of our argument list. - (let ((open-paren (c-langelem-2nd-pos c-syntactic-element)) - (paren-state (c-parse-state))) - (while (not (eq (car paren-state) open-paren)) - (unless (consp (car paren-state)) ;; ignore matched braces - (goto-char (car paren-state))) - (setq paren-state (cdr paren-state))))) - - (let ((start (point)) c) - - (when (bolp) - ;; Previous line ending in a comma means we're the start of an - ;; argument. This should quickly catch most cases not for us. - ;; This case is only applicable if we're the innermost arglist. - (c-backward-syntactic-ws) - (setq c (char-before))) - - (unless (eq c ?,) - ;; In a gcc asm, ":" on the previous line means the start of an - ;; argument. And lines starting with ":" are not for us, don't - ;; want them to indent to the preceding operand. - (let ((gcc-asm (save-excursion - (goto-char start) - (c-in-gcc-asm-p)))) - (unless (and gcc-asm - (or (eq c ?:) - (save-excursion - (goto-char start) - (looking-at "[ \t]*:")))) - - (c-lineup-argcont-scan (if gcc-asm ?:)) - (vector (current-column)))))))) +(defun c-lineup-argcont-+ (langelem) + "Indent an argument continuation `c-basic-offset' in from the first argument. -(defun c-lineup-argcont-scan (&optional other-match) - ;; Find the start of an argument, for `c-lineup-argcont'. - (when (zerop (c-backward-token-2 1 t)) - (let ((c (char-after))) - (if (or (eq c ?,) (eq c other-match)) - (progn - (forward-char) - (c-forward-syntactic-ws)) - (c-lineup-argcont-scan other-match))))) +This first argument is that on a previous line at the same level of nesting. + +foo (xyz, uvw, aaa + bbb + ccc + + ddd + eee + fff); <- c-lineup-argcont-+ + <--> c-basic-offset + +Only continuation lines like this are touched, nil being returned +on lines which are the start of an argument. + +Works with: arglist-cont, arglist-cont-nonempty." + (save-excursion + (when (c-lineup-argcont-1 langelem) ; Check we've got a continued argument... + ;; ... but ignore the position found. + (goto-char (c-langelem-2nd-pos c-syntactic-element)) + (forward-char) + (c-forward-syntactic-ws) + (vector (+ (current-column) c-basic-offset))))) (defun c-lineup-arglist-intro-after-paren (_langelem) "Line up a line to just after the open paren of the surrounding paren diff --git a/lisp/progmodes/cc-awk.el b/lisp/progmodes/cc-awk.el index 188d5a8a837..9ea1557391b 100644 --- a/lisp/progmodes/cc-awk.el +++ b/lisp/progmodes/cc-awk.el @@ -56,6 +56,8 @@ ;; Silence the byte compiler. (cc-bytecomp-defvar c-new-BEG) (cc-bytecomp-defvar c-new-END) +(cc-bytecomp-defun c-restore-string-fences) +(cc-bytecomp-defun c-clear-string-fences) ;; Some functions in cc-engine that are used below. There's a cyclic ;; dependency so it can't be required here. (Perhaps some functions @@ -934,7 +936,7 @@ ;; It prepares the buffer for font ;; locking, hence must get called before `font-lock-after-change-function'. ;; - ;; This function is the AWK value of `c-before-font-lock-function'. + ;; This function is the AWK value of `c-before-font-lock-functions'. ;; It does hidden buffer changes. (c-save-buffer-state () (setq c-new-END (c-awk-end-of-change-region beg end old-len)) @@ -1109,29 +1111,30 @@ nor helpful. Note that this function might do hidden buffer changes. See the comment at the start of cc-engine.el for more info." (interactive "p") - (or arg (setq arg 1)) - (save-match-data - (c-save-buffer-state ; ensures the buffer is writable. - nil - (let ((found t)) ; Has the most recent regexp search found b-of-defun? - (if (>= arg 0) - ;; Go back one defun each time round the following loop. (For +ve arg) - (while (and found (> arg 0) (not (eq (point) (point-min)))) - ;; Go back one "candidate" each time round the next loop until one - ;; is genuinely a beginning-of-defun. - (while (and (setq found (search-backward-regexp - "^[^#} \t\n\r]" (point-min) 'stop-at-limit)) - (not (memq (c-awk-get-NL-prop-prev-line) '(?\$ ?\} ?\#))))) - (setq arg (1- arg))) - ;; The same for a -ve arg. - (if (not (eq (point) (point-max))) (forward-char 1)) - (while (and found (< arg 0) (not (eq (point) (point-max)))) ; The same for -ve arg. - (while (and (setq found (search-forward-regexp - "^[^#} \t\n\r]" (point-max) 'stop-at-limit)) - (not (memq (c-awk-get-NL-prop-prev-line) '(?\$ ?\} ?\#))))) - (setq arg (1+ arg))) - (if found (goto-char (match-beginning 0)))) - (eq arg 0))))) + (c-with-string-fences + (or arg (setq arg 1)) + (save-match-data + (c-save-buffer-state ; ensures the buffer is writable. + nil + (let ((found t)) ; Has the most recent regexp search found b-of-defun? + (if (>= arg 0) + ;; Go back one defun each time round the following loop. (For +ve arg) + (while (and found (> arg 0) (not (eq (point) (point-min)))) + ;; Go back one "candidate" each time round the next loop until one + ;; is genuinely a beginning-of-defun. + (while (and (setq found (search-backward-regexp + "^[^#} \t\n\r]" (point-min) 'stop-at-limit)) + (not (memq (c-awk-get-NL-prop-prev-line) '(?\$ ?\} ?\#))))) + (setq arg (1- arg))) + ;; The same for a -ve arg. + (if (not (eq (point) (point-max))) (forward-char 1)) + (while (and found (< arg 0) (not (eq (point) (point-max)))) ; The same for -ve arg. + (while (and (setq found (search-forward-regexp + "^[^#} \t\n\r]" (point-max) 'stop-at-limit)) + (not (memq (c-awk-get-NL-prop-prev-line) '(?\$ ?\} ?\#))))) + (setq arg (1+ arg))) + (if found (goto-char (match-beginning 0)))) + (eq arg 0)))))) (defun c-awk-forward-awk-pattern () ;; Point is at the start of an AWK pattern (which may be null) or function @@ -1187,39 +1190,40 @@ no explicit action; see function `c-awk-beginning-of-defun'. Note that this function might do hidden buffer changes. See the comment at the start of cc-engine.el for more info." (interactive "p") - (or arg (setq arg 1)) - (save-match-data - (c-save-buffer-state - nil - (let ((start-point (point)) end-point) - ;; Strategy: (For +ve ARG): If we're not already at a beginning-of-defun, - ;; move backwards to one. - ;; Repeat [(i) move forward to end-of-current-defun (see below); - ;; (ii) If this isn't it, move forward to beginning-of-defun]. - ;; We start counting ARG only when step (i) has passed the original point. - (when (> arg 0) - ;; Try to move back to a beginning-of-defun, if not already at one. - (if (not (c-awk-beginning-of-defun-p)) - (when (not (c-awk-beginning-of-defun 1)) ; No bo-defun before point. - (goto-char start-point) - (c-awk-beginning-of-defun -1))) ; if this fails, we're at EOB, tough! - ;; Now count forward, one defun at a time - (while (and (not (eobp)) - (c-awk-end-of-defun1) - (if (> (point) start-point) (setq arg (1- arg)) t) - (> arg 0) - (c-awk-beginning-of-defun -1)))) - - (when (< arg 0) - (setq end-point start-point) - (while (and (not (bobp)) - (c-awk-beginning-of-defun 1) - (if (< (setq end-point (if (bobp) (point) - (save-excursion (c-awk-end-of-defun1)))) - start-point) - (setq arg (1+ arg)) t) - (< arg 0))) - (goto-char (min start-point end-point))))))) + (c-with-string-fences + (or arg (setq arg 1)) + (save-match-data + (c-save-buffer-state + nil + (let ((start-point (point)) end-point) + ;; Strategy: (For +ve ARG): If we're not already at a beginning-of-defun, + ;; move backwards to one. + ;; Repeat [(i) move forward to end-of-current-defun (see below); + ;; (ii) If this isn't it, move forward to beginning-of-defun]. + ;; We start counting ARG only when step (i) has passed the original point. + (when (> arg 0) + ;; Try to move back to a beginning-of-defun, if not already at one. + (if (not (c-awk-beginning-of-defun-p)) + (when (not (c-awk-beginning-of-defun 1)) ; No bo-defun before point. + (goto-char start-point) + (c-awk-beginning-of-defun -1))) ; if this fails, we're at EOB, tough! + ;; Now count forward, one defun at a time + (while (and (not (eobp)) + (c-awk-end-of-defun1) + (if (> (point) start-point) (setq arg (1- arg)) t) + (> arg 0) + (c-awk-beginning-of-defun -1)))) + + (when (< arg 0) + (setq end-point start-point) + (while (and (not (bobp)) + (c-awk-beginning-of-defun 1) + (if (< (setq end-point (if (bobp) (point) + (save-excursion (c-awk-end-of-defun1)))) + start-point) + (setq arg (1+ arg)) t) + (< arg 0))) + (goto-char (min start-point end-point)))))))) (cc-provide 'cc-awk) ; Changed from 'awk-mode, ACM 2002/5/21 diff --git a/lisp/progmodes/cc-cmds.el b/lisp/progmodes/cc-cmds.el index f42f82e53bb..e9cc63709e6 100644 --- a/lisp/progmodes/cc-cmds.el +++ b/lisp/progmodes/cc-cmds.el @@ -49,6 +49,8 @@ ; which looks at this. (cc-bytecomp-defun electric-pair-post-self-insert-function) (cc-bytecomp-defvar c-indent-to-body-directives) +(cc-bytecomp-defun c-restore-string-fences) +(cc-bytecomp-defun c-clear-string-fences) (defvar c-syntactic-context) ;; Indentation / Display syntax functions @@ -210,35 +212,36 @@ and takes care to set the indentation before calling "Show syntactic information for current line. With universal argument, inserts the analysis as a comment on that line." (interactive "P") - (let* ((c-parsing-error nil) - (syntax (if (boundp 'c-syntactic-context) - ;; Use `c-syntactic-context' in the same way as - ;; `c-indent-line', to be consistent. - c-syntactic-context - (c-save-buffer-state nil - (c-guess-basic-syntax))))) - (if (not (consp arg)) - (let (elem pos ols) - (message "Syntactic analysis: %s" syntax) - (unwind-protect - (progn - (while syntax - (setq elem (pop syntax)) - (when (setq pos (c-langelem-pos elem)) - (push (c-put-overlay pos (1+ pos) - 'face 'highlight) - ols)) - (when (setq pos (c-langelem-2nd-pos elem)) - (push (c-put-overlay pos (1+ pos) - 'face 'secondary-selection) - ols))) - (sit-for 10)) - (while ols - (c-delete-overlay (pop ols))))) - (indent-for-comment) - (insert-and-inherit (format "%s" syntax)) - )) - (c-keep-region-active)) + (c-with-string-fences + (let* ((c-parsing-error nil) + (syntax (if (boundp 'c-syntactic-context) + ;; Use `c-syntactic-context' in the same way as + ;; `c-indent-line', to be consistent. + c-syntactic-context + (c-save-buffer-state nil + (c-guess-basic-syntax))))) + (if (not (consp arg)) + (let (elem pos ols) + (message "Syntactic analysis: %s" syntax) + (unwind-protect + (progn + (while syntax + (setq elem (pop syntax)) + (when (setq pos (c-langelem-pos elem)) + (push (c-put-overlay pos (1+ pos) + 'face 'highlight) + ols)) + (when (setq pos (c-langelem-2nd-pos elem)) + (push (c-put-overlay pos (1+ pos) + 'face 'secondary-selection) + ols))) + (sit-for 10)) + (while ols + (c-delete-overlay (pop ols))))) + (indent-for-comment) + (insert-and-inherit (format "%s" syntax)) + )) + (c-keep-region-active))) (defun c-syntactic-information-on-region (from to) "Insert a comment with the syntactic analysis on every line in the region." @@ -414,23 +417,25 @@ argument is supplied, or `c-hungry-delete-key' is nil, or point is inside a literal then the function in the variable `c-backspace-function' is called." (interactive "*P") - (if (c-save-buffer-state () - (or (not c-hungry-delete-key) - arg - (c-in-literal))) - (funcall c-backspace-function (prefix-numeric-value arg)) - (c-hungry-delete-backwards))) + (c-with-string-fences + (if (c-save-buffer-state () + (or (not c-hungry-delete-key) + arg + (c-in-literal))) + (funcall c-backspace-function (prefix-numeric-value arg)) + (c-hungry-delete-backwards)))) (defun c-hungry-delete-backwards () "Delete the preceding character or all preceding whitespace back to the previous non-whitespace character. See also \\[c-hungry-delete-forward]." (interactive) - (let ((here (point))) - (c-skip-ws-backward) - (if (/= (point) here) - (delete-region (point) here) - (funcall c-backspace-function 1)))) + (c-with-string-fences + (let ((here (point))) + (c-skip-ws-backward) + (if (/= (point) here) + (delete-region (point) here) + (funcall c-backspace-function 1))))) (defalias 'c-hungry-backspace 'c-hungry-delete-backwards) @@ -442,23 +447,26 @@ argument is supplied, or `c-hungry-delete-key' is nil, or point is inside a literal then the function in the variable `c-delete-function' is called." (interactive "*P") - (if (c-save-buffer-state () - (or (not c-hungry-delete-key) - arg - (c-in-literal))) - (funcall c-delete-function (prefix-numeric-value arg)) - (c-hungry-delete-forward))) + (c-with-string-fences + (if + (c-save-buffer-state () + (or (not c-hungry-delete-key) + arg + (c-in-literal))) + (funcall c-delete-function (prefix-numeric-value arg)) + (c-hungry-delete-forward)))) (defun c-hungry-delete-forward () "Delete the following character or all following whitespace up to the next non-whitespace character. See also \\[c-hungry-delete-backwards]." (interactive) - (let ((here (point))) - (c-skip-ws-forward) - (if (/= (point) here) - (delete-region (point) here) - (funcall c-delete-function 1)))) + (c-with-string-fences + (let ((here (point))) + (c-skip-ws-forward) + (if (/= (point) here) + (delete-region (point) here) + (funcall c-delete-function 1))))) ;; This function is only used in XEmacs. (defun c-electric-delete (arg) @@ -519,7 +527,8 @@ function to control that." (defmacro c--call-post-self-insert-hook-more-safely () ;; Call post-self-insert-hook, if such exists. See comment for - ;; `c--call-post-self-insert-hook-more-safely-1'. + ;; `c--call-post-self-insert-hook-more-safely-1'. This macro should be + ;; invoked OUTSIDE of `c-with-string-fences'. (if (boundp 'post-self-insert-hook) '(c--call-post-self-insert-hook-more-safely-1) '(progn))) @@ -530,30 +539,30 @@ If `c-electric-flag' is set, handle it specially according to the variable `c-electric-pound-behavior'. If a numeric ARG is supplied, or if point is inside a literal or a macro, nothing special happens." (interactive "*P") - (if (c-save-buffer-state () - (or arg - (not c-electric-flag) - (not (memq 'alignleft c-electric-pound-behavior)) - (save-excursion - (skip-chars-backward " \t") - (not (bolp))) - (save-excursion - (and (= (forward-line -1) 0) - (progn (end-of-line) - (eq (char-before) ?\\)))) - (c-in-literal))) - ;; do nothing special - (let (post-self-insert-hook) ; Disable random functionality. - (self-insert-command (prefix-numeric-value arg))) - ;; place the pound character at the left edge - (let ((pos (- (point-max) (point))) - (bolp (bolp))) - (beginning-of-line) - (delete-horizontal-space) - (insert (c-last-command-char)) - (and (not bolp) - (goto-char (- (point-max) pos))) - )) + (c-with-string-fences + (if (c-save-buffer-state () + (or arg + (not c-electric-flag) + (not (memq 'alignleft c-electric-pound-behavior)) + (save-excursion + (skip-chars-backward " \t") + (not (bolp))) + (save-excursion + (and (= (forward-line -1) 0) + (progn (end-of-line) + (eq (char-before) ?\\)))) + (c-in-literal))) + ;; do nothing special + (let (post-self-insert-hook) ; Disable random functionality. + (self-insert-command (prefix-numeric-value arg))) + ;; place the pound character at the left edge + (let ((pos (- (point-max) (point))) + (bolp (bolp))) + (beginning-of-line) + (delete-horizontal-space) + (insert (c-last-command-char)) + (and (not bolp) + (goto-char (- (point-max) pos)))))) (c--call-post-self-insert-hook-more-safely)) (defun c-point-syntax () @@ -883,25 +892,26 @@ settings of `c-cleanup-list' are done." (interactive "*P") (let (safepos literal - ;; We want to inhibit blinking the paren since this would be - ;; most disruptive. We'll blink it ourselves later on. - (old-blink-paren blink-paren-function) - blink-paren-function case-fold-search - (at-eol (looking-at "[ \t]*\\\\?$")) - (active-region (and (fboundp 'use-region-p) (use-region-p))) - got-pair-} electric-pair-deletion) - - (c-save-buffer-state () - (setq safepos (c-safe-position (point) (c-parse-state)) - literal (c-in-literal safepos))) - - ;; Insert the brace. Note that expand-abbrev might reindent - ;; the line here if there's a preceding "else" or something. - (let (post-self-insert-hook) ; the only way to get defined functionality - ; from `self-insert-command'. - (self-insert-command (prefix-numeric-value arg))) - - ;; Emulate `electric-pair-mode'. + ;; We want to inhibit blinking the paren since this would be + ;; most disruptive. We'll blink it ourselves later on. + (old-blink-paren blink-paren-function) + blink-paren-function case-fold-search + (at-eol (looking-at "[ \t]*\\\\?$")) + (active-region (and (fboundp 'use-region-p) (use-region-p))) + got-pair-} electric-pair-deletion) + + (c-with-string-fences + (c-save-buffer-state () + (setq safepos (c-safe-position (point) (c-parse-state)) + literal (c-in-literal safepos))) + + ;; Insert the brace. Note that expand-abbrev might reindent + ;; the line here if there's a preceding "else" or something. + (let (post-self-insert-hook) ; the only way to get defined functionality + ; from `self-insert-command'. + (self-insert-command (prefix-numeric-value arg)))) + + ;; Emulate `electric-pair-mode', outside of `c-with-string-fences'. (when (and (boundp 'electric-pair-mode) electric-pair-mode) (let ((size (buffer-size)) @@ -912,30 +922,31 @@ settings of `c-cleanup-list' are done." (eq (char-after) ?})) electric-pair-deletion (< (buffer-size) size)))) - ;; Perform any required CC Mode electric actions. - (cond - ((or literal arg (not c-electric-flag) active-region)) - ((not at-eol) - (c-indent-line)) - (electric-pair-deletion - (c-indent-line) - (c-do-brace-electrics 'ignore nil)) - (t (c-do-brace-electrics nil nil) - (when got-pair-} + (c-with-string-fences + ;; Perform any required CC Mode electric actions. + (cond + ((or literal arg (not c-electric-flag) active-region)) + ((not at-eol) + (c-indent-line)) + (electric-pair-deletion + (c-indent-line) + (c-do-brace-electrics 'ignore nil)) + (t (c-do-brace-electrics nil nil) + (when got-pair-} + (save-excursion + (forward-char) + (c-do-brace-electrics 'assume 'ignore)) + (c-indent-line)))) + + ;; blink the paren + (and (eq (c-last-command-char) ?\}) + (not executing-kbd-macro) + old-blink-paren (save-excursion - (forward-char) - (c-do-brace-electrics 'assume 'ignore)) - (c-indent-line)))) - - ;; blink the paren - (and (eq (c-last-command-char) ?\}) - (not executing-kbd-macro) - old-blink-paren - (save-excursion - (c-save-buffer-state nil - (c-backward-syntactic-ws safepos)) - (funcall old-blink-paren))) - (c--call-post-self-insert-hook-more-safely))) + (c-save-buffer-state nil + (c-backward-syntactic-ws safepos)) + (funcall old-blink-paren))))) + (c--call-post-self-insert-hook-more-safely)) (defun c-electric-slash (arg) "Insert a slash character. @@ -956,39 +967,40 @@ If a numeric ARG is supplied, point is inside a literal, or `c-syntactic-indentation' is nil or `c-electric-flag' is nil, indentation is inhibited." (interactive "*P") - (let ((literal (c-save-buffer-state () (c-in-literal))) - indentp - ;; shut this up - (c-echo-syntactic-information-p nil)) + (c-with-string-fences + (let ((literal (c-save-buffer-state () (c-in-literal))) + indentp + ;; shut this up + (c-echo-syntactic-information-p nil)) - ;; comment-close-slash cleanup? This DOESN'T need `c-electric-flag' or - ;; `c-syntactic-indentation' set. - (when (and (not arg) - (eq literal 'c) - (memq 'comment-close-slash c-cleanup-list) - (eq (c-last-command-char) ?/) - (looking-at (concat "[ \t]*\\(" - (regexp-quote comment-end) "\\)?$")) - ; (eq c-block-comment-ender "*/") ; C-style comments ALWAYS end in */ - (save-excursion - (save-restriction - (narrow-to-region (point-min) (point)) - (back-to-indentation) - (looking-at (concat c-current-comment-prefix "[ \t]*$"))))) - (delete-region (progn (forward-line 0) (point)) - (progn (end-of-line) (point))) - (insert-char ?* 1)) ; the / comes later. ; Do I need a t (retain sticky properties) here? - - (setq indentp (and (not arg) - c-syntactic-indentation - c-electric-flag - (eq (c-last-command-char) ?/) - (eq (char-before) (if literal ?* ?/)))) - (let (post-self-insert-hook) ; Disable random functionality. - (self-insert-command (prefix-numeric-value arg))) - (if indentp - (indent-according-to-mode)) - (c--call-post-self-insert-hook-more-safely))) + ;; comment-close-slash cleanup? This DOESN'T need `c-electric-flag' or + ;; `c-syntactic-indentation' set. + (when (and (not arg) + (eq literal 'c) + (memq 'comment-close-slash c-cleanup-list) + (eq (c-last-command-char) ?/) + (looking-at (concat "[ \t]*\\(" + (regexp-quote comment-end) "\\)?$")) + ; (eq c-block-comment-ender "*/") ; C-style comments ALWAYS end in */ + (save-excursion + (save-restriction + (narrow-to-region (point-min) (point)) + (back-to-indentation) + (looking-at (concat c-current-comment-prefix "[ \t]*$"))))) + (delete-region (progn (forward-line 0) (point)) + (progn (end-of-line) (point))) + (insert-char ?* 1)) ; the / comes later. ; Do I need a t (retain sticky properties) here? + + (setq indentp (and (not arg) + c-syntactic-indentation + c-electric-flag + (eq (c-last-command-char) ?/) + (eq (char-before) (if literal ?* ?/)))) + (let (post-self-insert-hook) ; Disable random functionality. + (self-insert-command (prefix-numeric-value arg))) + (if indentp + (indent-according-to-mode)))) + (c--call-post-self-insert-hook-more-safely)) (defun c-electric-star (arg) "Insert a star character. @@ -999,26 +1011,26 @@ supplied, point is inside a literal, or `c-syntactic-indentation' is nil, this indentation is inhibited." (interactive "*P") - (let (post-self-insert-hook) ; Disable random functionality. - (self-insert-command (prefix-numeric-value arg))) - ;; if we are in a literal, or if arg is given do not reindent the - ;; current line, unless this star introduces a comment-only line. - (if (c-save-buffer-state () - (and c-syntactic-indentation - c-electric-flag - (not arg) - (eq (c-in-literal) 'c) - (eq (char-before) ?*) - (save-excursion - (forward-char -1) - (skip-chars-backward "*") - (if (eq (char-before) ?/) - (forward-char -1)) - (skip-chars-backward " \t") - (bolp)))) - (let (c-echo-syntactic-information-p) ; shut this up - (indent-according-to-mode)) - ) + (c-with-string-fences + (let (post-self-insert-hook) ; Disable random functionality. + (self-insert-command (prefix-numeric-value arg))) + ;; if we are in a literal, or if arg is given do not reindent the + ;; current line, unless this star introduces a comment-only line. + (if (c-save-buffer-state () + (and c-syntactic-indentation + c-electric-flag + (not arg) + (eq (c-in-literal) 'c) + (eq (char-before) ?*) + (save-excursion + (forward-char -1) + (skip-chars-backward "*") + (if (eq (char-before) ?/) + (forward-char -1)) + (skip-chars-backward " \t") + (bolp)))) + (let (c-echo-syntactic-information-p) ; shut this up + (indent-according-to-mode)))) (c--call-post-self-insert-hook-more-safely)) (defun c-electric-semi&comma (arg) @@ -1039,60 +1051,61 @@ reindented unless `c-syntactic-indentation' is nil. semicolon following a defun might be cleaned up, depending on the settings of `c-cleanup-list'." (interactive "*P") - (let* (lim literal c-syntactic-context - (here (point)) - ;; shut this up - (c-echo-syntactic-information-p nil)) - - (c-save-buffer-state () - (setq lim (c-most-enclosing-brace (c-parse-state)) - literal (c-in-literal lim))) - - (let (post-self-insert-hook) ; Disable random functionality. - (self-insert-command (prefix-numeric-value arg))) - - (if (and c-electric-flag (not literal) (not arg)) - ;; do all cleanups and newline insertions if c-auto-newline is on. - (if (or (not c-auto-newline) - (not (looking-at "[ \t]*\\\\?$"))) - (if c-syntactic-indentation - (c-indent-line)) - ;; clean ups: list-close-comma or defun-close-semi - (let ((pos (- (point-max) (point)))) - (if (c-save-buffer-state () - (and (or (and - (eq (c-last-command-char) ?,) - (memq 'list-close-comma c-cleanup-list)) - (and - (eq (c-last-command-char) ?\;) - (memq 'defun-close-semi c-cleanup-list))) - (progn - (forward-char -1) - (c-skip-ws-backward) - (eq (char-before) ?})) - ;; make sure matching open brace isn't in a comment - (not (c-in-literal lim)))) - (delete-region (point) here)) - (goto-char (- (point-max) pos))) - ;; reindent line - (when c-syntactic-indentation - (setq c-syntactic-context (c-guess-basic-syntax)) - (c-indent-line c-syntactic-context)) - ;; check to see if a newline should be added - (let ((criteria c-hanging-semi&comma-criteria) - answer add-newline-p) - (while criteria - (setq answer (funcall (car criteria))) - ;; only nil value means continue checking - (if (not answer) - (setq criteria (cdr criteria)) - (setq criteria nil) - ;; only 'stop specifically says do not add a newline - (setq add-newline-p (not (eq answer 'stop))) - )) - (if add-newline-p - (c-newline-and-indent))))) - (c--call-post-self-insert-hook-more-safely))) + (c-with-string-fences + (let* (lim literal c-syntactic-context + (here (point)) + ;; shut this up + (c-echo-syntactic-information-p nil)) + + (c-save-buffer-state () + (setq lim (c-most-enclosing-brace (c-parse-state)) + literal (c-in-literal lim))) + + (let (post-self-insert-hook) ; Disable random functionality. + (self-insert-command (prefix-numeric-value arg))) + + (if (and c-electric-flag (not literal) (not arg)) + ;; do all cleanups and newline insertions if c-auto-newline is on. + (if (or (not c-auto-newline) + (not (looking-at "[ \t]*\\\\?$"))) + (if c-syntactic-indentation + (c-indent-line)) + ;; clean ups: list-close-comma or defun-close-semi + (let ((pos (- (point-max) (point)))) + (if (c-save-buffer-state () + (and (or (and + (eq (c-last-command-char) ?,) + (memq 'list-close-comma c-cleanup-list)) + (and + (eq (c-last-command-char) ?\;) + (memq 'defun-close-semi c-cleanup-list))) + (progn + (forward-char -1) + (c-skip-ws-backward) + (eq (char-before) ?})) + ;; make sure matching open brace isn't in a comment + (not (c-in-literal lim)))) + (delete-region (point) here)) + (goto-char (- (point-max) pos))) + ;; reindent line + (when c-syntactic-indentation + (setq c-syntactic-context (c-guess-basic-syntax)) + (c-indent-line c-syntactic-context)) + ;; check to see if a newline should be added + (let ((criteria c-hanging-semi&comma-criteria) + answer add-newline-p) + (while criteria + (setq answer (funcall (car criteria))) + ;; only nil value means continue checking + (if (not answer) + (setq criteria (cdr criteria)) + (setq criteria nil) + ;; only 'stop specifically says do not add a newline + (setq add-newline-p (not (eq answer 'stop))) + )) + (if add-newline-p + (c-newline-and-indent))))))) + (c--call-post-self-insert-hook-more-safely)) (defun c-electric-colon (arg) "Insert a colon. @@ -1113,89 +1126,90 @@ reindented unless `c-syntactic-indentation' is nil. `c-cleanup-list'." (interactive "*P") - (let* ((bod (c-point 'bod)) - (literal (c-save-buffer-state () (c-in-literal bod))) - newlines is-scope-op - ;; shut this up - (c-echo-syntactic-information-p nil)) - (let (post-self-insert-hook) ; Disable random functionality. - (self-insert-command (prefix-numeric-value arg))) - ;; Any electric action? - (if (and c-electric-flag (not literal) (not arg)) - ;; Unless we're at EOL, only re-indentation happens. - (if (not (looking-at "[ \t]*\\\\?$")) - (if c-syntactic-indentation - (indent-according-to-mode)) - - ;; scope-operator clean-up? - (let ((pos (- (point-max) (point))) - (here (point))) - (if (c-save-buffer-state () ; Why do we need this? [ACM, 2003-03-12] - (and c-auto-newline - (memq 'scope-operator c-cleanup-list) - (eq (char-before) ?:) - (progn - (forward-char -1) - (c-skip-ws-backward) - (eq (char-before) ?:)) - (not (c-in-literal)) - (not (eq (char-after (- (point) 2)) ?:)))) - (progn - (delete-region (point) (1- here)) - (setq is-scope-op t))) - (goto-char (- (point-max) pos))) - - ;; indent the current line if it's done syntactically. - (if c-syntactic-indentation - ;; Cannot use the same syntax analysis as we find below, - ;; since that's made with c-syntactic-indentation-in-macros - ;; always set to t. - (indent-according-to-mode)) - - ;; Calculate where, if anywhere, we want newlines. - (c-save-buffer-state - ((c-syntactic-indentation-in-macros t) - (c-auto-newline-analysis t) - ;; Turn on syntactic macro analysis to help with auto newlines - ;; only. - (syntax (c-guess-basic-syntax)) - (elem syntax)) - ;; Translate substatement-label to label for this operation. - (while elem - (if (eq (car (car elem)) 'substatement-label) - (setcar (car elem) 'label)) - (setq elem (cdr elem))) - ;; some language elements can only be determined by checking - ;; the following line. Let's first look for ones that can be - ;; found when looking on the line with the colon - (setq newlines - (and c-auto-newline - (or (c-lookup-lists '(case-label label access-label) - syntax c-hanging-colons-alist) - (c-lookup-lists '(member-init-intro inher-intro) - (progn - (insert ?\n) - (unwind-protect - (c-guess-basic-syntax) - (delete-char -1))) - c-hanging-colons-alist))))) - ;; does a newline go before the colon? Watch out for already - ;; non-hung colons. However, we don't unhang them because that - ;; would be a cleanup (and anti-social). - (if (and (memq 'before newlines) - (not is-scope-op) - (save-excursion - (skip-chars-backward ": \t") - (not (bolp)))) - (let ((pos (- (point-max) (point)))) - (forward-char -1) - (c-newline-and-indent) - (goto-char (- (point-max) pos)))) - ;; does a newline go after the colon? - (if (and (memq 'after (cdr-safe newlines)) - (not is-scope-op)) - (c-newline-and-indent)))) - (c--call-post-self-insert-hook-more-safely))) + (c-with-string-fences + (let* ((bod (c-point 'bod)) + (literal (c-save-buffer-state () (c-in-literal bod))) + newlines is-scope-op + ;; shut this up + (c-echo-syntactic-information-p nil)) + (let (post-self-insert-hook) ; Disable random functionality. + (self-insert-command (prefix-numeric-value arg))) + ;; Any electric action? + (if (and c-electric-flag (not literal) (not arg)) + ;; Unless we're at EOL, only re-indentation happens. + (if (not (looking-at "[ \t]*\\\\?$")) + (if c-syntactic-indentation + (indent-according-to-mode)) + + ;; scope-operator clean-up? + (let ((pos (- (point-max) (point))) + (here (point))) + (if (c-save-buffer-state () ; Why do we need this? [ACM, 2003-03-12] + (and c-auto-newline + (memq 'scope-operator c-cleanup-list) + (eq (char-before) ?:) + (progn + (forward-char -1) + (c-skip-ws-backward) + (eq (char-before) ?:)) + (not (c-in-literal)) + (not (eq (char-after (- (point) 2)) ?:)))) + (progn + (delete-region (point) (1- here)) + (setq is-scope-op t))) + (goto-char (- (point-max) pos))) + + ;; indent the current line if it's done syntactically. + (if c-syntactic-indentation + ;; Cannot use the same syntax analysis as we find below, + ;; since that's made with c-syntactic-indentation-in-macros + ;; always set to t. + (indent-according-to-mode)) + + ;; Calculate where, if anywhere, we want newlines. + (c-save-buffer-state + ((c-syntactic-indentation-in-macros t) + (c-auto-newline-analysis t) + ;; Turn on syntactic macro analysis to help with auto newlines + ;; only. + (syntax (c-guess-basic-syntax)) + (elem syntax)) + ;; Translate substatement-label to label for this operation. + (while elem + (if (eq (car (car elem)) 'substatement-label) + (setcar (car elem) 'label)) + (setq elem (cdr elem))) + ;; some language elements can only be determined by checking + ;; the following line. Let's first look for ones that can be + ;; found when looking on the line with the colon + (setq newlines + (and c-auto-newline + (or (c-lookup-lists '(case-label label access-label) + syntax c-hanging-colons-alist) + (c-lookup-lists '(member-init-intro inher-intro) + (progn + (insert ?\n) + (unwind-protect + (c-guess-basic-syntax) + (delete-char -1))) + c-hanging-colons-alist))))) + ;; does a newline go before the colon? Watch out for already + ;; non-hung colons. However, we don't unhang them because that + ;; would be a cleanup (and anti-social). + (if (and (memq 'before newlines) + (not is-scope-op) + (save-excursion + (skip-chars-backward ": \t") + (not (bolp)))) + (let ((pos (- (point-max) (point)))) + (forward-char -1) + (c-newline-and-indent) + (goto-char (- (point-max) pos)))) + ;; does a newline go after the colon? + (if (and (memq 'after (cdr-safe newlines)) + (not is-scope-op)) + (c-newline-and-indent)))))) + (c--call-post-self-insert-hook-more-safely)) (defun c-electric-lt-gt (arg) "Insert a \"<\" or \">\" character. @@ -1209,74 +1223,75 @@ finishes a C++ style stream operator in C++ mode. Exceptions are when a numeric argument is supplied, or the point is inside a literal." (interactive "*P") - (let ((literal (c-save-buffer-state () (c-in-literal))) - template-delim include-delim + (let (template-delim include-delim (c-echo-syntactic-information-p nil) final-pos found-delim case-fold-search) - (let (post-self-insert-hook) ; Disable random functionality. - (self-insert-command (prefix-numeric-value arg))) - (setq final-pos (point)) + (c-with-string-fences + (let (post-self-insert-hook) ; Disable random functionality. + (self-insert-command (prefix-numeric-value arg))) + (setq final-pos (point)) ;;;; 2010-01-31: There used to be code here to put a syntax-table text ;;;; property on the new < or > and its mate (if any) when they are template ;;;; parens. This is now done in an after-change function. - (when (and (not arg) (not literal)) - ;; Have we got a delimiter on a #include directive? - (beginning-of-line) - (setq include-delim - (and - (looking-at c-cpp-include-key) - (if (eq (c-last-command-char) ?<) - (eq (match-end 0) (1- final-pos)) - (goto-char (1- final-pos)) - (skip-chars-backward "^<>" (c-point 'bol)) - (eq (char-before) ?<)))) - (goto-char final-pos) - - ;; Indent the line if appropriate. - (when (and c-electric-flag c-syntactic-indentation c-recognize-<>-arglists) - (setq found-delim + (when (and (not arg) + (not (c-save-buffer-state () (c-in-literal)))) + ;; Have we got a delimiter on a #include directive? + (beginning-of-line) + (setq include-delim + (and + (looking-at c-cpp-include-key) (if (eq (c-last-command-char) ?<) - ;; If a <, basically see if it's got "template" before it ..... - (or (and (progn - (backward-char) - (= (point) - (progn (c-beginning-of-current-token) (point)))) - (progn - (c-backward-token-2) - (looking-at c-opt-<>-sexp-key)) - (setq template-delim t)) - ;; ..... or is a C++ << operator. - (and (c-major-mode-is 'c++-mode) - (progn - (goto-char (1- final-pos)) - (c-beginning-of-current-token) - (looking-at "<<")) - (>= (match-end 0) final-pos))) - - ;; It's a >. Either a template/generic terminator ... - (or (and (c-get-char-property (1- final-pos) 'syntax-table) - (setq template-delim t)) - ;; or a C++ >> operator. - (and (c-major-mode-is 'c++-mode) - (progn - (goto-char (1- final-pos)) - (c-beginning-of-current-token) - (looking-at ">>")) - (>= (match-end 0) final-pos))))) - (goto-char final-pos) - - (when found-delim - (indent-according-to-mode))) - - ;; On the off chance that < and > are configured as pairs in - ;; electric-pair-mode. - (when (and (boundp 'electric-pair-mode) electric-pair-mode - (or template-delim include-delim)) - (let (post-self-insert-hook) - (electric-pair-post-self-insert-function)))) + (eq (match-end 0) (1- final-pos)) + (goto-char (1- final-pos)) + (skip-chars-backward "^<>" (c-point 'bol)) + (eq (char-before) ?<)))) + (goto-char final-pos) + + ;; Indent the line if appropriate. + (when (and c-electric-flag c-syntactic-indentation c-recognize-<>-arglists) + (setq found-delim + (if (eq (c-last-command-char) ?<) + ;; If a <, basically see if it's got "template" before it ..... + (or (and (progn + (backward-char) + (= (point) + (progn (c-beginning-of-current-token) (point)))) + (progn + (c-backward-token-2) + (looking-at c-opt-<>-sexp-key)) + (setq template-delim t)) + ;; ..... or is a C++ << operator. + (and (c-major-mode-is 'c++-mode) + (progn + (goto-char (1- final-pos)) + (c-beginning-of-current-token) + (looking-at "<<")) + (>= (match-end 0) final-pos))) + + ;; It's a >. Either a template/generic terminator ... + (or (and (c-get-char-property (1- final-pos) 'syntax-table) + (setq template-delim t)) + ;; or a C++ >> operator. + (and (c-major-mode-is 'c++-mode) + (progn + (goto-char (1- final-pos)) + (c-beginning-of-current-token) + (looking-at ">>")) + (>= (match-end 0) final-pos))))) + (goto-char final-pos) + + (when found-delim + (indent-according-to-mode))))) + + ;; On the off chance that < and > are configured as pairs in + ;; electric-pair-mode. + (when (and (boundp 'electric-pair-mode) electric-pair-mode + (or template-delim include-delim)) + (let (post-self-insert-hook) + (electric-pair-post-self-insert-function))) (when found-delim (when (and (eq (char-before) ?>) @@ -1301,12 +1316,13 @@ removed; see the variable `c-cleanup-list'. Also, if `c-electric-flag' and `c-auto-newline' are both non-nil, some newline cleanups are done if appropriate; see the variable `c-cleanup-list'." (interactive "*P") - (let ((literal (c-save-buffer-state () (c-in-literal))) + (let ((literal (c-save-buffer-state () + (c-with-string-fences (c-in-literal)))) ;; shut this up (c-echo-syntactic-information-p nil) case-fold-search) (let (post-self-insert-hook) ; The only way to get defined functionality - ; from `self-insert-command'. + ; from `self-insert-command'. (self-insert-command (prefix-numeric-value arg))) (if (and (not arg) (not literal)) @@ -1315,46 +1331,47 @@ newline cleanups are done if appropriate; see the variable `c-cleanup-list'." ;; afterwards. (old-blink-paren blink-paren-function) blink-paren-function) - (if (and c-syntactic-indentation c-electric-flag) - (indent-according-to-mode)) - - ;; If we're at EOL, check for new-line clean-ups. - (when (and c-electric-flag c-auto-newline - (looking-at "[ \t]*\\\\?$")) - - ;; clean up brace-elseif-brace - (when - (and (memq 'brace-elseif-brace c-cleanup-list) - (eq (c-last-command-char) ?\() - (re-search-backward - (concat "}" - "\\([ \t\n]\\|\\\\\n\\)*" - "else" - "\\([ \t\n]\\|\\\\\n\\)+" - "if" - "\\([ \t\n]\\|\\\\\n\\)*" - "(" - "\\=") - nil t) - (not (c-save-buffer-state () (c-in-literal)))) - (delete-region (match-beginning 0) (match-end 0)) - (insert-and-inherit "} else if (")) - - ;; clean up brace-catch-brace - (when - (and (memq 'brace-catch-brace c-cleanup-list) - (eq (c-last-command-char) ?\() - (re-search-backward - (concat "}" - "\\([ \t\n]\\|\\\\\n\\)*" - "catch" - "\\([ \t\n]\\|\\\\\n\\)*" - "(" - "\\=") - nil t) - (not (c-save-buffer-state () (c-in-literal)))) - (delete-region (match-beginning 0) (match-end 0)) - (insert-and-inherit "} catch ("))) + (c-with-string-fences + (if (and c-syntactic-indentation c-electric-flag) + (indent-according-to-mode)) + + ;; If we're at EOL, check for new-line clean-ups. + (when (and c-electric-flag c-auto-newline + (looking-at "[ \t]*\\\\?$")) + + ;; clean up brace-elseif-brace + (when + (and (memq 'brace-elseif-brace c-cleanup-list) + (eq (c-last-command-char) ?\() + (re-search-backward + (concat "}" + "\\([ \t\n]\\|\\\\\n\\)*" + "else" + "\\([ \t\n]\\|\\\\\n\\)+" + "if" + "\\([ \t\n]\\|\\\\\n\\)*" + "(" + "\\=") + nil t) + (not (c-save-buffer-state () (c-in-literal)))) + (delete-region (match-beginning 0) (match-end 0)) + (insert-and-inherit "} else if (")) + + ;; clean up brace-catch-brace + (when + (and (memq 'brace-catch-brace c-cleanup-list) + (eq (c-last-command-char) ?\() + (re-search-backward + (concat "}" + "\\([ \t\n]\\|\\\\\n\\)*" + "catch" + "\\([ \t\n]\\|\\\\\n\\)*" + "(" + "\\=") + nil t) + (not (c-save-buffer-state () (c-in-literal)))) + (delete-region (match-beginning 0) (match-end 0)) + (insert-and-inherit "} catch (")))) ;; Apply `electric-pair-mode' stuff. (when (and (boundp 'electric-pair-mode) @@ -1362,41 +1379,42 @@ newline cleanups are done if appropriate; see the variable `c-cleanup-list'." (let (post-self-insert-hook) (electric-pair-post-self-insert-function))) - ;; Check for clean-ups at function calls. These two DON'T need - ;; `c-electric-flag' or `c-syntactic-indentation' set. - ;; Point is currently just after the inserted paren. - (let (beg (end (1- (point)))) - (cond - - ;; space-before-funcall clean-up? - ((and (memq 'space-before-funcall c-cleanup-list) - (eq (c-last-command-char) ?\() - (save-excursion - (backward-char) - (skip-chars-backward " \t") - (setq beg (point)) - (and (c-save-buffer-state () (c-on-identifier)) - ;; Don't add a space into #define FOO().... - (not (and (c-beginning-of-macro) - (c-forward-over-cpp-define-id) - (eq (point) beg)))))) - (save-excursion - (delete-region beg end) - (goto-char beg) - (insert ?\ ))) - - ;; compact-empty-funcall clean-up? - ((c-save-buffer-state () - (and (memq 'compact-empty-funcall c-cleanup-list) - (eq (c-last-command-char) ?\)) - (save-excursion - (c-safe (backward-char 2)) - (when (looking-at "()") - (setq end (point)) - (skip-chars-backward " \t") - (setq beg (point)) - (c-on-identifier))))) - (delete-region beg end)))) + (c-with-string-fences + ;; Check for clean-ups at function calls. These two DON'T need + ;; `c-electric-flag' or `c-syntactic-indentation' set. + ;; Point is currently just after the inserted paren. + (let (beg (end (1- (point)))) + (cond + + ;; space-before-funcall clean-up? + ((and (memq 'space-before-funcall c-cleanup-list) + (eq (c-last-command-char) ?\() + (save-excursion + (backward-char) + (skip-chars-backward " \t") + (setq beg (point)) + (and (c-save-buffer-state () (c-on-identifier)) + ;; Don't add a space into #define FOO().... + (not (and (c-beginning-of-macro) + (c-forward-over-cpp-define-id) + (eq (point) beg)))))) + (save-excursion + (delete-region beg end) + (goto-char beg) + (insert ?\ ))) + + ;; compact-empty-funcall clean-up? + ((c-save-buffer-state () + (and (memq 'compact-empty-funcall c-cleanup-list) + (eq (c-last-command-char) ?\)) + (save-excursion + (c-safe (backward-char 2)) + (when (looking-at "()") + (setq end (point)) + (skip-chars-backward " \t") + (setq beg (point)) + (c-on-identifier))))) + (delete-region beg end))))) (and (eq last-input-event ?\)) (not executing-kbd-macro) old-blink-paren @@ -1405,8 +1423,8 @@ newline cleanups are done if appropriate; see the variable `c-cleanup-list'." ;; Apply `electric-pair-mode' stuff inside a string or comment. (when (and (boundp 'electric-pair-mode) electric-pair-mode) (let (post-self-insert-hook) - (electric-pair-post-self-insert-function)))) - (c--call-post-self-insert-hook-more-safely))) + (electric-pair-post-self-insert-function))))) + (c--call-post-self-insert-hook-more-safely)) (defun c-electric-continued-statement () "Reindent the current line if appropriate. @@ -1868,68 +1886,71 @@ defun." (c-region-is-active-p) (push-mark)) - (c-save-buffer-state - (beginning-of-defun-function - end-of-defun-function - (paren-state (c-parse-state)) - (orig-point-min (point-min)) (orig-point-max (point-max)) - lim ; Position of { which has been widened to. - where pos case-fold-search) - - (save-restriction - (if (eq c-defun-tactic 'go-outward) - (setq lim (c-widen-to-enclosing-decl-scope ; e.g. class, namespace. - paren-state orig-point-min orig-point-max))) - - ;; Move back out of any macro/comment/string we happen to be in. - (c-beginning-of-macro) - (setq pos (c-literal-start)) - (if pos (goto-char pos)) - - (setq where (c-where-wrt-brace-construct)) - - (if (< arg 0) - ;; Move forward to the closing brace of a function. - (progn - (if (memq where '(at-function-end outwith-function)) - (setq arg (1+ arg))) - (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)) - - ;; Move backward to the opening brace of a function, making successively - ;; larger portions of the buffer visible as necessary. - (when (> arg 0) - (c-while-widening-to-decl-block - (> (setq arg (c-backward-to-nth-BOF-{ arg where)) 0))) - - (when (eq arg 0) - ;; Go backward to this function's header. - (c-beginning-of-decl-1) - - (setq pos (point)) - ;; We're now there, modulo comments and whitespace. - ;; Try to be line oriented; position point at the closest - ;; preceding boi that isn't inside a comment, but if we hit - ;; the previous declaration then we use the current point - ;; instead. - (while (and (/= (point) (c-point 'boi)) - (c-backward-single-comment))) - (if (/= (point) (c-point 'boi)) - (goto-char pos))) - - (c-keep-region-active) - (= arg 0))))) + (c-with-string-fences + (c-save-buffer-state + (beginning-of-defun-function + end-of-defun-function + (paren-state (c-parse-state)) + (orig-point-min (point-min)) (orig-point-max (point-max)) + lim ; Position of { which has been widened to. + where pos case-fold-search) + + (save-restriction + (if (eq c-defun-tactic 'go-outward) + (setq lim (c-widen-to-enclosing-decl-scope ; e.g. class, namespace. + paren-state orig-point-min orig-point-max))) + + ;; Move back out of any macro/comment/string we happen to be in. + (c-beginning-of-macro) + (setq pos (c-literal-start)) + (if pos (goto-char pos)) + + (setq where (c-where-wrt-brace-construct)) + + (if (< arg 0) + ;; Move forward to the closing brace of a function. + (progn + (if (memq where '(at-function-end outwith-function)) + (setq arg (1+ arg))) + (if (< arg 0) + (c-while-widening-to-decl-block + (< (setq arg (- (c-forward-to-nth-EOF-\;-or-} (- arg) where))) 0))) + (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. + (when (> arg 0) + (c-while-widening-to-decl-block + (> (setq arg (c-backward-to-nth-BOF-{ arg where)) 0))) + + (when (eq arg 0) + ;; Go backward to this function's header. + (c-beginning-of-decl-1) + + (setq pos (point)) + ;; We're now there, modulo comments and whitespace. + ;; Try to be line oriented; position point at the closest + ;; preceding boi that isn't inside a comment, but if we hit + ;; the previous declaration then we use the current point + ;; instead. + (while (and (/= (point) (c-point 'boi)) + (c-backward-single-comment))) + (if (/= (point) (c-point 'boi)) + (goto-char pos))) + + (c-keep-region-active) + (= arg 0)))))) (defun c-forward-to-nth-EOF-\;-or-} (n where) ;; Skip to the closing brace or semicolon of the Nth function after point. @@ -1996,65 +2017,66 @@ the open-parenthesis that starts a defun; see `beginning-of-defun'." (c-region-is-active-p) (push-mark)) - (c-save-buffer-state - (beginning-of-defun-function - end-of-defun-function - (paren-state (c-parse-state)) - (orig-point-min (point-min)) (orig-point-max (point-max)) - lim - where pos case-fold-search) - - (save-restriction - (if (eq c-defun-tactic 'go-outward) - (setq lim (c-widen-to-enclosing-decl-scope ; e.g. class, namespace - paren-state orig-point-min orig-point-max))) - - ;; Move back out of any macro/comment/string we happen to be in. - (c-beginning-of-macro) - (setq pos (c-literal-start)) - (if pos (goto-char pos)) + (c-with-string-fences + (c-save-buffer-state + (beginning-of-defun-function + end-of-defun-function + (paren-state (c-parse-state)) + (orig-point-min (point-min)) (orig-point-max (point-max)) + lim + where pos case-fold-search) + + (save-restriction + (if (eq c-defun-tactic 'go-outward) + (setq lim (c-widen-to-enclosing-decl-scope ; e.g. class, namespace + paren-state orig-point-min orig-point-max))) + + ;; Move back out of any macro/comment/string we happen to be in. + (c-beginning-of-macro) + (setq pos (c-literal-start)) + (if pos (goto-char pos)) + + (setq where (c-where-wrt-brace-construct)) + + (if (< arg 0) + ;; Move backwards to the } of a function + (progn + (if (memq where '(at-header outwith-function)) + (setq arg (1+ arg))) + (if (< arg 0) + (c-while-widening-to-decl-block + (< (setq arg (- (c-backward-to-nth-BOF-{ (- arg) where))) 0))) + (if (= arg 0) + (c-while-widening-to-decl-block + (progn (c-syntactic-skip-backward "^}") + (not (eq (char-before) ?})))))) + + ;; Move forward to the } of a function + (if (> arg 0) + (c-while-widening-to-decl-block + (> (setq arg (c-forward-to-nth-EOF-\;-or-} arg where)) 0)))) + + ;; Do we need to move forward from the brace to the semicolon? + (when (eq arg 0) + (if (c-in-function-trailer-p) ; after "}" of struct/enum, etc. + (c-syntactic-re-search-forward ";")) - (setq where (c-where-wrt-brace-construct)) + (setq pos (point)) + ;; We're there now, modulo comments and whitespace. + ;; Try to be line oriented; position point after the next + ;; newline that isn't inside a comment, but if we hit the + ;; next declaration then we use the current point instead. + (while (and (not (bolp)) + (not (looking-at "\\s *$")) + (c-forward-single-comment))) + (cond ((bolp)) + ((looking-at "\\s *$") + (forward-line 1)) + (t + (goto-char pos)))) - (if (< arg 0) - ;; Move backwards to the } of a function - (progn - (if (memq where '(at-header outwith-function)) - (setq arg (1+ arg))) - (if (< arg 0) - (c-while-widening-to-decl-block - (< (setq arg (- (c-backward-to-nth-BOF-{ (- arg) where))) 0))) - (if (= arg 0) - (c-while-widening-to-decl-block - (progn (c-syntactic-skip-backward "^}") - (not (eq (char-before) ?})))))) - - ;; Move forward to the } of a function - (if (> arg 0) - (c-while-widening-to-decl-block - (> (setq arg (c-forward-to-nth-EOF-\;-or-} arg where)) 0)))) - - ;; Do we need to move forward from the brace to the semicolon? - (when (eq arg 0) - (if (c-in-function-trailer-p) ; after "}" of struct/enum, etc. - (c-syntactic-re-search-forward ";")) - - (setq pos (point)) - ;; We're there now, modulo comments and whitespace. - ;; Try to be line oriented; position point after the next - ;; newline that isn't inside a comment, but if we hit the - ;; next declaration then we use the current point instead. - (while (and (not (bolp)) - (not (looking-at "\\s *$")) - (c-forward-single-comment))) - (cond ((bolp)) - ((looking-at "\\s *$") - (forward-line 1)) - (t - (goto-char pos)))) - - (c-keep-region-active) - (= arg 0)))) + (c-keep-region-active) + (= arg 0))))) (defun c-defun-name-1 () "Return name of current defun, at current narrowing, or nil if there isn't one. @@ -2340,18 +2362,19 @@ with a brace block, at the outermost level of nesting." "Display the name of the current CC mode defun and the position in it. With a prefix arg, push the name onto the kill ring too." (interactive "P") - (save-restriction - (widen) - (c-save-buffer-state ((name-and-limits (c-defun-name-and-limits nil)) - (name (car name-and-limits)) - (limits (cdr name-and-limits)) - (point-bol (c-point 'bol))) - (when name - (message "%s. Line %s/%s." name - (1+ (count-lines (car limits) (max point-bol (car limits)))) - (count-lines (car limits) (cdr limits))) - (if arg (kill-new name)) - (sit-for 3 t))))) + (c-with-string-fences + (save-restriction + (widen) + (c-save-buffer-state ((name-and-limits (c-defun-name-and-limits nil)) + (name (car name-and-limits)) + (limits (cdr name-and-limits)) + (point-bol (c-point 'bol))) + (when name + (message "%s. Line %s/%s." name + (1+ (count-lines (car limits) (max point-bol (car limits)))) + (count-lines (car limits) (cdr limits))) + (if arg (kill-new name)) + (sit-for 3 t)))))) (put 'c-display-defun-name 'isearch-scroll t) (defun c-mark-function () @@ -2367,34 +2390,35 @@ As opposed to \\[c-beginning-of-defun] and \\[c-end-of-defun], this function does not require the declaration to contain a brace block." (interactive) - (let (decl-limits case-fold-search) - (c-save-buffer-state nil - ;; We try to be line oriented, unless there are several - ;; declarations on the same line. - (if (looking-at c-syntactic-eol) - (c-backward-token-2 1 nil (c-point 'bol))) - (setq decl-limits (c-declaration-limits t))) - - (if (not decl-limits) - (error "Cannot find any declaration") - (let* ((extend-region-p - (and (eq this-command 'c-mark-function) - (eq last-command 'c-mark-function))) - (push-mark-p (and (eq this-command 'c-mark-function) - (not extend-region-p) - (not (c-region-is-active-p))))) - (if push-mark-p (push-mark)) - (if extend-region-p - (progn - (exchange-point-and-mark) - (setq decl-limits (c-declaration-limits t)) - (when (not decl-limits) - (exchange-point-and-mark) - (error "Cannot find any declaration")) - (goto-char (cdr decl-limits)) - (exchange-point-and-mark)) - (goto-char (car decl-limits)) - (push-mark (cdr decl-limits) nil t)))))) + (c-with-string-fences + (let (decl-limits case-fold-search) + (c-save-buffer-state nil + ;; We try to be line oriented, unless there are several + ;; declarations on the same line. + (if (looking-at c-syntactic-eol) + (c-backward-token-2 1 nil (c-point 'bol))) + (setq decl-limits (c-declaration-limits t))) + + (if (not decl-limits) + (error "Cannot find any declaration") + (let* ((extend-region-p + (and (eq this-command 'c-mark-function) + (eq last-command 'c-mark-function))) + (push-mark-p (and (eq this-command 'c-mark-function) + (not extend-region-p) + (not (c-region-is-active-p))))) + (if push-mark-p (push-mark)) + (if extend-region-p + (progn + (exchange-point-and-mark) + (setq decl-limits (c-declaration-limits t)) + (when (not decl-limits) + (exchange-point-and-mark) + (error "Cannot find any declaration")) + (goto-char (cdr decl-limits)) + (exchange-point-and-mark)) + (goto-char (car decl-limits)) + (push-mark (cdr decl-limits) nil t))))))) (defun c-cpp-define-name () "Return the name of the current CPP macro, or NIL if we're not in one." @@ -3031,85 +3055,86 @@ be more \"DWIM:ey\"." nil t)) (if (< count 0) (c-end-of-statement (- count) lim sentence-flag) - (c-save-buffer-state - ((count (or count 1)) - last ; start point for going back ONE chunk. Updated each chunk movement. - (macro-fence - (save-excursion (and (not (bobp)) (c-beginning-of-macro) (point)))) - res ; result from sub-function call - not-bos ; "not beginning-of-statement" - (range (c-collect-line-comments (c-literal-limits lim)))) ; (start.end) of current literal or NIL - - ;; Go back one statement at each iteration of the following loop. - (while (and (/= count 0) - (or (not lim) (> (point) lim))) - ;; Go back one "chunk" each time round the following loop, stopping - ;; when we reach a statement boundary, etc. - (setq last (point)) - (while - (cond ; Each arm of this cond returns NIL on reaching a desired - ; statement boundary, non-NIL otherwise. - ((bobp) - (setq count 0) - nil) - - (range ; point is within or approaching a literal. - (cond - ;; Single line string or sentence-flag is null => skip the - ;; entire literal. - ((or (null sentence-flag) - (c-one-line-string-p range)) - (goto-char (car range)) - (setq range (c-ascertain-preceding-literal)) - ;; N.B. The following is essentially testing for an AWK regexp - ;; at BOS: - ;; Was the previous non-ws thing an end of statement? - (save-excursion - (if macro-fence - (c-backward-comments) - (c-backward-syntactic-ws)) - (not (or (bobp) (c-after-statement-terminator-p))))) - - ;; Comment inside a statement or a multi-line string. - (t (when (setq res ; returns non-nil when we go out of the literal - (if (eq (c-literal-type range) 'string) - (c-beginning-of-sentence-in-string range) - (c-beginning-of-sentence-in-comment range))) - (setq range (c-ascertain-preceding-literal))) - res))) - - ;; Non-literal code. - (t (setq res (c-back-over-illiterals macro-fence)) - (setq not-bos ; "not reached beginning-of-statement". - (or (= (point) last) - (memq (char-after) '(?\) ?\})) - (and - (car res) - ;; We're at a tentative BOS. The next form goes - ;; back over WS looking for an end of previous - ;; statement. - (not (save-excursion - (if macro-fence - (c-backward-comments) - (c-backward-syntactic-ws)) - (or (bobp) (c-after-statement-terminator-p))))))) - ;; Are we about to move backwards into or out of a - ;; preprocessor command? If so, locate its beginning. - (when (eq (cdr res) 'macro-boundary) - (save-excursion - (beginning-of-line) - (setq macro-fence - (and (not (bobp)) - (progn (c-skip-ws-backward) (c-beginning-of-macro)) - (point))))) - ;; Are we about to move backwards into a literal? - (when (memq (cdr res) '(macro-boundary literal)) - (setq range (c-ascertain-preceding-literal))) - not-bos)) - (setq last (point))) - - (if (/= count 0) (setq count (1- count)))) - (c-keep-region-active)))) + (c-with-string-fences + (c-save-buffer-state + ((count (or count 1)) + last ; start point for going back ONE chunk. Updated each chunk movement. + (macro-fence + (save-excursion (and (not (bobp)) (c-beginning-of-macro) (point)))) + res ; result from sub-function call + not-bos ; "not beginning-of-statement" + (range (c-collect-line-comments (c-literal-limits lim)))) ; (start.end) of current literal or NIL + + ;; Go back one statement at each iteration of the following loop. + (while (and (/= count 0) + (or (not lim) (> (point) lim))) + ;; Go back one "chunk" each time round the following loop, stopping + ;; when we reach a statement boundary, etc. + (setq last (point)) + (while + (cond ; Each arm of this cond returns NIL on reaching a desired + ; statement boundary, non-NIL otherwise. + ((bobp) + (setq count 0) + nil) + + (range ; point is within or approaching a literal. + (cond + ;; Single line string or sentence-flag is null => skip the + ;; entire literal. + ((or (null sentence-flag) + (c-one-line-string-p range)) + (goto-char (car range)) + (setq range (c-ascertain-preceding-literal)) + ;; N.B. The following is essentially testing for an AWK regexp + ;; at BOS: + ;; Was the previous non-ws thing an end of statement? + (save-excursion + (if macro-fence + (c-backward-comments) + (c-backward-syntactic-ws)) + (not (or (bobp) (c-after-statement-terminator-p))))) + + ;; Comment inside a statement or a multi-line string. + (t (when (setq res ; returns non-nil when we go out of the literal + (if (eq (c-literal-type range) 'string) + (c-beginning-of-sentence-in-string range) + (c-beginning-of-sentence-in-comment range))) + (setq range (c-ascertain-preceding-literal))) + res))) + + ;; Non-literal code. + (t (setq res (c-back-over-illiterals macro-fence)) + (setq not-bos ; "not reached beginning-of-statement". + (or (= (point) last) + (memq (char-after) '(?\) ?\})) + (and + (car res) + ;; We're at a tentative BOS. The next form goes + ;; back over WS looking for an end of previous + ;; statement. + (not (save-excursion + (if macro-fence + (c-backward-comments) + (c-backward-syntactic-ws)) + (or (bobp) (c-after-statement-terminator-p))))))) + ;; Are we about to move backwards into or out of a + ;; preprocessor command? If so, locate its beginning. + (when (eq (cdr res) 'macro-boundary) + (save-excursion + (beginning-of-line) + (setq macro-fence + (and (not (bobp)) + (progn (c-skip-ws-backward) (c-beginning-of-macro)) + (point))))) + ;; Are we about to move backwards into a literal? + (when (memq (cdr res) '(macro-boundary literal)) + (setq range (c-ascertain-preceding-literal))) + not-bos)) + (setq last (point))) + + (if (/= count 0) (setq count (1- count)))) + (c-keep-region-active))))) (defun c-end-of-statement (&optional count lim sentence-flag) "Go to the end of the innermost C statement. @@ -3127,78 +3152,79 @@ sentence motion in or near comments and multiline strings." (setq count (or count 1)) (if (< count 0) (c-beginning-of-statement (- count) lim sentence-flag) - (c-save-buffer-state - (here ; start point for going forward ONE statement. Updated each statement. - (macro-fence - (save-excursion - (and (not (eobp)) (c-beginning-of-macro) - (progn (c-end-of-macro) (point))))) - res - (range (c-collect-line-comments (c-literal-limits lim)))) ; (start.end) of current literal or NIL - - ;; Go back/forward one statement at each iteration of the following loop. - (while (and (/= count 0) - (or (not lim) (< (point) lim))) - (setq here (point)) ; ONLY HERE is HERE updated - - ;; Go forward one "chunk" each time round the following loop, stopping - ;; when we reach a statement boundary, etc. - (while - (cond ; Each arm of this cond returns NIL on reaching a desired - ; statement boundary, non-NIL otherwise. - ((eobp) - (setq count 0) - nil) + (c-with-string-fences + (c-save-buffer-state + (here ; start point for going forward ONE statement. Updated each statement. + (macro-fence + (save-excursion + (and (not (eobp)) (c-beginning-of-macro) + (progn (c-end-of-macro) (point))))) + res + (range (c-collect-line-comments (c-literal-limits lim)))) ; (start.end) of current literal or NIL + + ;; Go back/forward one statement at each iteration of the following loop. + (while (and (/= count 0) + (or (not lim) (< (point) lim))) + (setq here (point)) ; ONLY HERE is HERE updated + + ;; Go forward one "chunk" each time round the following loop, stopping + ;; when we reach a statement boundary, etc. + (while + (cond ; Each arm of this cond returns NIL on reaching a desired + ; statement boundary, non-NIL otherwise. + ((eobp) + (setq count 0) + nil) + + (range ; point is within a literal. + (cond + ;; sentence-flag is null => skip the entire literal. + ;; or a Single line string. + ((or (null sentence-flag) + (c-one-line-string-p range)) + (goto-char (cdr range)) + (setq range (c-ascertain-following-literal)) + ;; Is there a virtual semicolon here (e.g. for AWK)? + (not (c-at-vsemi-p))) + + ;; Comment or multi-line string. + (t (when (setq res ; gets non-nil when we go out of the literal + (if (eq (c-literal-type range) 'string) + (c-end-of-sentence-in-string range) + (c-end-of-sentence-in-comment range))) + (setq range (c-ascertain-following-literal))) + ;; If we've just come forward out of a literal, check for + ;; vsemi. (N.B. AWK can't have a vsemi after a comment, but + ;; some other language may do in the future) + (and res + (not (c-at-vsemi-p)))))) + + ;; Non-literal code. + (t (setq res (c-forward-over-illiterals macro-fence + (> (point) here))) + ;; Are we about to move forward into or out of a + ;; preprocessor command? + (when (eq (cdr res) 'macro-boundary) + (setq macro-fence + (save-excursion + (if macro-fence + (progn + (end-of-line) + (and (not (eobp)) + (progn (c-skip-ws-forward) + (c-beginning-of-macro)) + (progn (c-end-of-macro) + (point)))) + (and (not (eobp)) + (c-beginning-of-macro) + (progn (c-end-of-macro) (point))))))) + ;; Are we about to move forward into a literal? + (when (memq (cdr res) '(macro-boundary literal)) + (setq range (c-ascertain-following-literal))) + (car res)))) - (range ; point is within a literal. - (cond - ;; sentence-flag is null => skip the entire literal. - ;; or a Single line string. - ((or (null sentence-flag) - (c-one-line-string-p range)) - (goto-char (cdr range)) - (setq range (c-ascertain-following-literal)) - ;; Is there a virtual semicolon here (e.g. for AWK)? - (not (c-at-vsemi-p))) - - ;; Comment or multi-line string. - (t (when (setq res ; gets non-nil when we go out of the literal - (if (eq (c-literal-type range) 'string) - (c-end-of-sentence-in-string range) - (c-end-of-sentence-in-comment range))) - (setq range (c-ascertain-following-literal))) - ;; If we've just come forward out of a literal, check for - ;; vsemi. (N.B. AWK can't have a vsemi after a comment, but - ;; some other language may do in the future) - (and res - (not (c-at-vsemi-p)))))) - - ;; Non-literal code. - (t (setq res (c-forward-over-illiterals macro-fence - (> (point) here))) - ;; Are we about to move forward into or out of a - ;; preprocessor command? - (when (eq (cdr res) 'macro-boundary) - (setq macro-fence - (save-excursion - (if macro-fence - (progn - (end-of-line) - (and (not (eobp)) - (progn (c-skip-ws-forward) - (c-beginning-of-macro)) - (progn (c-end-of-macro) - (point)))) - (and (not (eobp)) - (c-beginning-of-macro) - (progn (c-end-of-macro) (point))))))) - ;; Are we about to move forward into a literal? - (when (memq (cdr res) '(macro-boundary literal)) - (setq range (c-ascertain-following-literal))) - (car res)))) - - (if (/= count 0) (setq count (1- count)))) - (c-keep-region-active)))) + (if (/= count 0) (setq count (1- count)))) + (c-keep-region-active))))) ;; set up electric character functions to work with pending-del, @@ -3413,7 +3439,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. @@ -3536,122 +3563,125 @@ prefix argument is equivalent to -1. depending on the variable `indent-tabs-mode'." (interactive "P") - (let ((indent-function - (if c-syntactic-indentation - (symbol-function 'indent-according-to-mode) - (lambda () - (let ((c-macro-start c-macro-start) - (steps (if (equal arg '(4)) - -1 - (prefix-numeric-value arg)))) - (c-shift-line-indentation (* steps c-basic-offset)) - (when (and c-auto-align-backslashes - (save-excursion - (end-of-line) - (eq (char-before) ?\\)) - (c-query-and-set-macro-start)) - ;; Realign the line continuation backslash if inside a macro. - (c-backslash-region (point) (point) nil t))) - )))) - (if (and c-syntactic-indentation arg) - ;; If c-syntactic-indentation and got arg, always indent this - ;; line as C and shift remaining lines of expression the same - ;; amount. - (let ((shift-amt (save-excursion - (back-to-indentation) - (current-column))) - beg end) - (c-indent-line) - (setq shift-amt (- (save-excursion - (back-to-indentation) - (current-column)) - shift-amt)) - (save-excursion - (if (eq c-tab-always-indent t) - (beginning-of-line)) ; FIXME!!! What is this here for? ACM 2005/10/31 - (setq beg (point)) - (c-forward-sexp 1) - (setq end (point)) - (goto-char beg) - (forward-line 1) - (setq beg (point))) - (if (> end beg) - (indent-code-rigidly beg end shift-amt "#"))) - ;; Else use c-tab-always-indent to determine behavior. - (cond - ;; CASE 1: indent when at column zero or in line's indentation, - ;; otherwise insert a tab - ((not c-tab-always-indent) - (if (save-excursion - (skip-chars-backward " \t") - (not (bolp))) - (funcall c-insert-tab-function) - (funcall indent-function))) - ;; CASE 2: just indent the line - ((eq c-tab-always-indent t) - (funcall indent-function)) - ;; CASE 3: if in a literal, insert a tab, but always indent the - ;; line - (t - (if (c-save-buffer-state () (c-in-literal)) - (funcall c-insert-tab-function)) - (funcall indent-function) - ))))) + (c-with-string-fences + (let ((indent-function + (if c-syntactic-indentation + (symbol-function 'indent-according-to-mode) + (lambda () + (let ((c-macro-start c-macro-start) + (steps (if (equal arg '(4)) + -1 + (prefix-numeric-value arg)))) + (c-shift-line-indentation (* steps c-basic-offset)) + (when (and c-auto-align-backslashes + (save-excursion + (end-of-line) + (eq (char-before) ?\\)) + (c-query-and-set-macro-start)) + ;; Realign the line continuation backslash if inside a macro. + (c-backslash-region (point) (point) nil t))) + )))) + (if (and c-syntactic-indentation arg) + ;; If c-syntactic-indentation and got arg, always indent this + ;; line as C and shift remaining lines of expression the same + ;; amount. + (let ((shift-amt (save-excursion + (back-to-indentation) + (current-column))) + beg end) + (c-indent-line) + (setq shift-amt (- (save-excursion + (back-to-indentation) + (current-column)) + shift-amt)) + (save-excursion + (if (eq c-tab-always-indent t) + (beginning-of-line)) ; FIXME!!! What is this here for? ACM 2005/10/31 + (setq beg (point)) + (c-forward-sexp 1) + (setq end (point)) + (goto-char beg) + (forward-line 1) + (setq beg (point))) + (if (> end beg) + (indent-code-rigidly beg end shift-amt "#"))) + ;; Else use c-tab-always-indent to determine behavior. + (cond + ;; CASE 1: indent when at column zero or in line's indentation, + ;; otherwise insert a tab + ((not c-tab-always-indent) + (if (save-excursion + (skip-chars-backward " \t") + (not (bolp))) + (funcall c-insert-tab-function) + (funcall indent-function))) + ;; CASE 2: just indent the line + ((eq c-tab-always-indent t) + (funcall indent-function)) + ;; CASE 3: if in a literal, insert a tab, but always indent the + ;; line + (t + (if (c-save-buffer-state () (c-in-literal)) + (funcall c-insert-tab-function)) + (funcall indent-function) + )))))) (defun c-indent-exp (&optional shutup-p) "Indent each line in the balanced expression following point syntactically. If optional SHUTUP-P is non-nil, no errors are signaled if no balanced expression is found." (interactive "*P") - (let ((here (point-marker)) - end) - (set-marker-insertion-type here t) - (unwind-protect - (let ((start (save-restriction - ;; Find the closest following open paren that - ;; ends on another line. - (narrow-to-region (point-min) (c-point 'eol)) - (let (beg (end (point))) - (while (and (setq beg (c-down-list-forward end)) - (setq end (c-up-list-forward beg)))) - (and beg - (eq (char-syntax (char-before beg)) ?\() - (1- beg)))))) - ;; sanity check - (if (not start) - (unless shutup-p - (error "Cannot find start of balanced expression to indent")) - (goto-char start) - (setq end (c-safe (scan-sexps (point) 1))) - (if (not end) - (unless shutup-p - (error "Cannot find end of balanced expression to indent")) - (forward-line) - (if (< (point) end) - (c-indent-region (point) end))))) - (goto-char here) - (set-marker here nil)))) + (c-with-string-fences + (let ((here (point-marker)) + end) + (set-marker-insertion-type here t) + (unwind-protect + (let ((start (save-restriction + ;; Find the closest following open paren that + ;; ends on another line. + (narrow-to-region (point-min) (c-point 'eol)) + (let (beg (end (point))) + (while (and (setq beg (c-down-list-forward end)) + (setq end (c-up-list-forward beg)))) + (and beg + (eq (char-syntax (char-before beg)) ?\() + (1- beg)))))) + ;; sanity check + (if (not start) + (unless shutup-p + (error "Cannot find start of balanced expression to indent")) + (goto-char start) + (setq end (c-safe (scan-sexps (point) 1))) + (if (not end) + (unless shutup-p + (error "Cannot find end of balanced expression to indent")) + (forward-line) + (if (< (point) end) + (c-indent-region (point) end))))) + (goto-char here) + (set-marker here nil))))) (defun c-indent-defun () "Indent the current top-level declaration or macro syntactically. In the macro case this also has the effect of realigning any line continuation backslashes, unless `c-auto-align-backslashes' is nil." (interactive "*") - (let ((here (point-marker)) decl-limits case-fold-search) - (unwind-protect - (progn - (c-save-buffer-state nil - ;; We try to be line oriented, unless there are several - ;; declarations on the same line. - (if (looking-at c-syntactic-eol) - (c-backward-token-2 1 nil (c-point 'bol)) - (c-forward-token-2 0 nil (c-point 'eol))) - (setq decl-limits (c-declaration-limits nil))) - (if decl-limits - (c-indent-region (car decl-limits) - (cdr decl-limits)))) - (goto-char here) - (set-marker here nil)))) + (c-with-string-fences + (let ((here (point-marker)) decl-limits case-fold-search) + (unwind-protect + (progn + (c-save-buffer-state nil + ;; We try to be line oriented, unless there are several + ;; declarations on the same line. + (if (looking-at c-syntactic-eol) + (c-backward-token-2 1 nil (c-point 'bol)) + (c-forward-token-2 0 nil (c-point 'eol))) + (setq decl-limits (c-declaration-limits nil))) + (if decl-limits + (c-indent-region (car decl-limits) + (cdr decl-limits)))) + (goto-char here) + (set-marker here nil))))) (defun c-indent-region (start end &optional quiet) "Indent syntactically lines whose first char is between START and END inclusive. @@ -3731,9 +3761,10 @@ starting on the current line. Otherwise reindent just the current line." (interactive (list current-prefix-arg (c-region-is-active-p))) - (if region - (c-indent-region (region-beginning) (region-end)) - (c-indent-command arg))) + (c-with-string-fences + (if region + (c-indent-region (region-beginning) (region-end)) + (c-indent-command arg)))) ;; for progress reporting (defvar c-progress-info nil) @@ -4820,15 +4851,16 @@ If point is in any other situation, i.e. in normal code, do nothing. Optional prefix ARG means justify paragraph as well." (interactive "*P") - (let ((fill-paragraph-function - ;; Avoid infinite recursion. - (if (not (eq fill-paragraph-function 'c-fill-paragraph)) - fill-paragraph-function))) - (c-mask-paragraph t nil 'fill-paragraph arg)) - ;; Always return t. This has the effect that if filling isn't done - ;; above, it isn't done at all, and it's therefore effectively - ;; disabled in normal code. - t) + (c-with-string-fences + (let ((fill-paragraph-function + ;; Avoid infinite recursion. + (if (not (eq fill-paragraph-function 'c-fill-paragraph)) + fill-paragraph-function))) + (c-mask-paragraph t nil 'fill-paragraph arg)) + ;; Always return t. This has the effect that if filling isn't done + ;; above, it isn't done at all, and it's therefore effectively + ;; disabled in normal code. + t)) (defun c-do-auto-fill () ;; Do automatic filling if not inside a context where it should be @@ -4860,181 +4892,170 @@ If a fill prefix is specified, it overrides all the above." ;; used from auto-fill itself, that's normally disabled to avoid ;; unnecessary recursion. (interactive) - (let ((fill-prefix fill-prefix) - (do-line-break - (lambda () - (delete-horizontal-space) - (if soft - (insert-and-inherit ?\n) - (newline (if allow-auto-fill nil 1))))) - ;; Already know the literal type and limits when called from - ;; c-context-line-break. - (c-lit-limits c-lit-limits) - (c-lit-type c-lit-type) - (c-macro-start c-macro-start)) - - (c-save-buffer-state () - (when (not (eq c-auto-fill-prefix t)) - ;; Called from do-auto-fill. - (unless c-lit-limits - (setq c-lit-limits (c-literal-limits nil nil t))) - (unless c-lit-type - (setq c-lit-type (c-literal-type c-lit-limits))) - (if (memq (cond ((c-query-and-set-macro-start) 'cpp) - ((null c-lit-type) 'code) - (t c-lit-type)) - c-ignore-auto-fill) - (setq fill-prefix t) ; Used as flag in the cond. - (if (and (null c-auto-fill-prefix) - (eq c-lit-type 'c) - (<= (c-point 'bol) (car c-lit-limits))) - ;; The adaptive fill function has generated a prefix, but - ;; we're on the first line in a block comment so it'll be - ;; wrong. Ignore it to guess a better one below. - (setq fill-prefix nil) - (when (and (eq c-lit-type 'c++) - (not (string-match (concat "\\`[ \t]*" - c-line-comment-starter) - (or fill-prefix "")))) - ;; Kludge: If the function that adapted the fill prefix - ;; doesn't produce the required comment starter for line - ;; comments, then we ignore it. - (setq fill-prefix nil))) - ))) - - (cond ((eq fill-prefix t) - ;; A call from do-auto-fill which should be ignored. - ) - (fill-prefix - ;; A fill-prefix overrides anything. - (funcall do-line-break) - (insert-and-inherit fill-prefix)) - ((c-save-buffer-state () - (unless c-lit-limits - (setq c-lit-limits (c-literal-limits))) - (unless c-lit-type - (setq c-lit-type (c-literal-type c-lit-limits))) - (memq c-lit-type '(c c++))) - ;; Some sort of comment. - (if (or comment-multi-line - (save-excursion - (goto-char (car c-lit-limits)) - (end-of-line) - (< (point) (cdr c-lit-limits)))) - ;; Inside a comment that should be continued. - (let ((fill (c-save-buffer-state nil - (c-guess-fill-prefix - (setq c-lit-limits - (c-collect-line-comments c-lit-limits)) - c-lit-type))) - (pos (point)) - (comment-text-end - (or (and (eq c-lit-type 'c) - (save-excursion - (goto-char (- (cdr c-lit-limits) 2)) - (if (looking-at "\\*/") (point)))) - (cdr c-lit-limits)))) - ;; Skip forward past the fill prefix in case - ;; we're standing in it. - ;; - ;; FIXME: This doesn't work well in cases like - ;; - ;; /* Bla bla bla bla bla - ;; bla bla - ;; - ;; If point is on the 'B' then the line will be - ;; broken after "Bla b". - ;; - ;; If we have an empty comment, /* */, the next - ;; lot of code pushes point to the */. We fix - ;; this by never allowing point to end up to the - ;; right of where it started. - (while (and (< (current-column) (cdr fill)) - (not (eolp))) - (forward-char 1)) - (if (and (> (point) comment-text-end) - (> (c-point 'bol) (car c-lit-limits))) - (progn - ;; The skip takes us out of the (block) - ;; comment; insert the fill prefix at bol - ;; instead and keep the position. - (setq pos (copy-marker pos t)) - (beginning-of-line) - (insert-and-inherit (car fill)) - (if soft (insert-and-inherit ?\n) (newline 1)) - (goto-char pos) - (set-marker pos nil)) - ;; Don't break in the middle of a comment starter - ;; or ender. - (cond ((> (point) comment-text-end) - (goto-char comment-text-end)) - ((< (point) (+ (car c-lit-limits) 2)) - (goto-char (+ (car c-lit-limits) 2)))) - (funcall do-line-break) - (insert-and-inherit (car fill)) - (if (and (looking-at c-block-comment-ender-regexp) - (memq (char-before) '(?\ ?\t))) - (backward-char)))) ; can this hit the - ; middle of a TAB? - ;; Inside a comment that should be broken. - (let ((comment-start comment-start) - (comment-end comment-end) - col) - (if (eq c-lit-type 'c) - (unless (string-match "[ \t]*/\\*" comment-start) - (setq comment-start "/* " comment-end " */")) - (unless (string-match "[ \t]*//" comment-start) - (setq comment-start "// " comment-end ""))) - (setq col (save-excursion - (back-to-indentation) - (current-column))) - (funcall do-line-break) - (when (and comment-end (not (equal comment-end ""))) - (forward-char -1) - (insert-and-inherit comment-end) - (forward-char 1)) - ;; c-comment-indent may look at the current - ;; indentation, so let's start out with the same - ;; indentation as the previous one. - (indent-to col) - (insert-and-inherit comment-start) - (indent-for-comment)))) - ((c-query-and-set-macro-start) - ;; In a macro. - (unless (looking-at "[ \t]*\\\\$") - ;; Do not clobber the alignment of the line continuation - ;; slash; c-backslash-region might look at it. - (delete-horizontal-space)) - ;; Got an asymmetry here: In normal code this command - ;; doesn't indent the next line syntactically, and otoh a - ;; normal syntactically indenting newline doesn't continue - ;; the macro. - (c-newline-and-indent (if allow-auto-fill nil 1))) - (t - ;; Somewhere else in the code. - (let ((col (save-excursion + (c-with-string-fences + (let ((fill-prefix fill-prefix) + (do-line-break + (lambda () + (delete-horizontal-space) + (if soft + (insert-and-inherit ?\n) + (newline (if allow-auto-fill nil 1))))) + ;; Already know the literal type and limits when called from + ;; c-context-line-break. + (c-lit-limits c-lit-limits) + (c-lit-type c-lit-type) + (c-macro-start c-macro-start)) + + (c-save-buffer-state () + (when (not (eq c-auto-fill-prefix t)) + ;; Called from do-auto-fill. + (unless c-lit-limits + (setq c-lit-limits (c-literal-limits nil nil t))) + (unless c-lit-type + (setq c-lit-type (c-literal-type c-lit-limits))) + (if (memq (cond ((c-query-and-set-macro-start) 'cpp) + ((null c-lit-type) 'code) + (t c-lit-type)) + c-ignore-auto-fill) + (setq fill-prefix t) ; Used as flag in the cond. + (if (and (null c-auto-fill-prefix) + (eq c-lit-type 'c) + (<= (c-point 'bol) (car c-lit-limits))) + ;; The adaptive fill function has generated a prefix, but + ;; we're on the first line in a block comment so it'll be + ;; wrong. Ignore it to guess a better one below. + (setq fill-prefix nil) + (when (and (eq c-lit-type 'c++) + (not (string-match (concat "\\`[ \t]*" + c-line-comment-starter) + (or fill-prefix "")))) + ;; Kludge: If the function that adapted the fill prefix + ;; doesn't produce the required comment starter for line + ;; comments, then we ignore it. + (setq fill-prefix nil))) + ))) + + (cond ((eq fill-prefix t) + ;; A call from do-auto-fill which should be ignored. + ) + (fill-prefix + ;; A fill-prefix overrides anything. + (funcall do-line-break) + (insert-and-inherit fill-prefix)) + ((c-save-buffer-state () + (unless c-lit-limits + (setq c-lit-limits (c-literal-limits))) + (unless c-lit-type + (setq c-lit-type (c-literal-type c-lit-limits))) + (memq c-lit-type '(c c++))) + ;; Some sort of comment. + (if (or comment-multi-line + (save-excursion + (goto-char (car c-lit-limits)) + (end-of-line) + (< (point) (cdr c-lit-limits)))) + ;; Inside a comment that should be continued. + (let ((fill (c-save-buffer-state nil + (c-guess-fill-prefix + (setq c-lit-limits + (c-collect-line-comments c-lit-limits)) + c-lit-type))) + (pos (point)) + (comment-text-end + (or (and (eq c-lit-type 'c) + (save-excursion + (goto-char (- (cdr c-lit-limits) 2)) + (if (looking-at "\\*/") (point)))) + (cdr c-lit-limits)))) + ;; Skip forward past the fill prefix in case + ;; we're standing in it. + ;; + ;; FIXME: This doesn't work well in cases like + ;; + ;; /* Bla bla bla bla bla + ;; bla bla + ;; + ;; If point is on the 'B' then the line will be + ;; broken after "Bla b". + ;; + ;; If we have an empty comment, /* */, the next + ;; lot of code pushes point to the */. We fix + ;; this by never allowing point to end up to the + ;; right of where it started. + (while (and (< (current-column) (cdr fill)) + (not (eolp))) + (forward-char 1)) + (if (and (> (point) comment-text-end) + (> (c-point 'bol) (car c-lit-limits))) + (progn + ;; The skip takes us out of the (block) + ;; comment; insert the fill prefix at bol + ;; instead and keep the position. + (setq pos (copy-marker pos t)) (beginning-of-line) - (while (and (looking-at "[ \t]*\\\\?$") - (= (forward-line -1) 0))) - (current-indentation)))) - (funcall do-line-break) - (indent-to col)))))) + (insert-and-inherit (car fill)) + (if soft (insert-and-inherit ?\n) (newline 1)) + (goto-char pos) + (set-marker pos nil)) + ;; Don't break in the middle of a comment starter + ;; or ender. + (cond ((> (point) comment-text-end) + (goto-char comment-text-end)) + ((< (point) (+ (car c-lit-limits) 2)) + (goto-char (+ (car c-lit-limits) 2)))) + (funcall do-line-break) + (insert-and-inherit (car fill)) + (if (and (looking-at c-block-comment-ender-regexp) + (memq (char-before) '(?\ ?\t))) + (backward-char)))) ; can this hit the + ; middle of a TAB? + ;; Inside a comment that should be broken. + (let ((comment-start comment-start) + (comment-end comment-end) + col) + (if (eq c-lit-type 'c) + (unless (string-match "[ \t]*/\\*" comment-start) + (setq comment-start "/* " comment-end " */")) + (unless (string-match "[ \t]*//" comment-start) + (setq comment-start "// " comment-end ""))) + (setq col (save-excursion + (back-to-indentation) + (current-column))) + (funcall do-line-break) + (when (and comment-end (not (equal comment-end ""))) + (forward-char -1) + (insert-and-inherit comment-end) + (forward-char 1)) + ;; c-comment-indent may look at the current + ;; indentation, so let's start out with the same + ;; indentation as the previous one. + (indent-to col) + (insert-and-inherit comment-start) + (indent-for-comment)))) + ((c-query-and-set-macro-start) + ;; In a macro. + (unless (looking-at "[ \t]*\\\\$") + ;; Do not clobber the alignment of the line continuation + ;; slash; c-backslash-region might look at it. + (delete-horizontal-space)) + ;; Got an asymmetry here: In normal code this command + ;; doesn't indent the next line syntactically, and otoh a + ;; normal syntactically indenting newline doesn't continue + ;; the macro. + (c-newline-and-indent (if allow-auto-fill nil 1))) + (t + ;; Somewhere else in the code. + (let ((col (save-excursion + (beginning-of-line) + (while (and (looking-at "[ \t]*\\\\?$") + (= (forward-line -1) 0))) + (current-indentation)))) + (funcall do-line-break) + (indent-to col))))))) (defalias 'c-comment-line-break-function 'c-indent-new-comment-line) (make-obsolete 'c-comment-line-break-function 'c-indent-new-comment-line "21.1") -;; Advice for Emacsen older than 21.1 (!), released 2001/10 -(unless (boundp 'comment-line-break-function) - (defvar c-inside-line-break-advice nil) - (defadvice indent-new-comment-line (around c-line-break-advice - activate preactivate) - "Call `c-indent-new-comment-line' if in CC Mode." - (if (or c-inside-line-break-advice - (not c-buffer-is-cc-mode)) - ad-do-it - (let ((c-inside-line-break-advice t)) - (c-indent-new-comment-line (ad-get-arg 0)))))) - (defun c-context-line-break () "Do a line break suitable to the context. @@ -5057,58 +5078,59 @@ When point is inside a string, only insert a backslash when it is also inside a preprocessor directive." (interactive "*") - (let* (c-lit-limits c-lit-type - (c-macro-start c-macro-start) - case-fold-search) - - (c-save-buffer-state () - (setq c-lit-limits (c-literal-limits nil nil t) - c-lit-type (c-literal-type c-lit-limits)) - (when (eq c-lit-type 'c++) - (setq c-lit-limits (c-collect-line-comments c-lit-limits))) - (c-query-and-set-macro-start)) - - (cond - ((or (eq c-lit-type 'c) - (and (eq c-lit-type 'c++) ; C++ comment, but not at the very end of it. - (< (save-excursion - (skip-chars-forward " \t") - (point)) - (1- (cdr c-lit-limits)))) - (and (numberp c-macro-start) ; Macro, but not at the very end of + (c-with-string-fences + (let* (c-lit-limits c-lit-type + (c-macro-start c-macro-start) + case-fold-search) + + (c-save-buffer-state () + (setq c-lit-limits (c-literal-limits nil nil t) + c-lit-type (c-literal-type c-lit-limits)) + (when (eq c-lit-type 'c++) + (setq c-lit-limits (c-collect-line-comments c-lit-limits))) + (c-query-and-set-macro-start)) + + (cond + ((or (eq c-lit-type 'c) + (and (eq c-lit-type 'c++) ; C++ comment, but not at the very end of it. + (< (save-excursion + (skip-chars-forward " \t") + (point)) + (1- (cdr c-lit-limits)))) + (and (numberp c-macro-start) ; Macro, but not at the very end of ; it, not in a string, and not in the ; cpp keyword. - (not (eq c-lit-type 'string)) - (or (not (looking-at "\\s *$")) - (eq (char-before) ?\\)) - (<= (save-excursion - (goto-char c-macro-start) - (if (looking-at c-opt-cpp-start) - (goto-char (match-end 0))) - (point)) - (point)))) - (let ((comment-multi-line t) - (fill-prefix nil)) - (c-indent-new-comment-line nil t))) - - ((eq c-lit-type 'string) - (if (and (numberp c-macro-start) - (not (eq (char-before) ?\\))) - (insert ?\\)) - (newline)) - - (t (delete-horizontal-space) - (newline) - ;; c-indent-line may look at the current indentation, so let's - ;; start out with the same indentation as the previous line. - (let ((col (save-excursion - (backward-char) - (forward-line 0) - (while (and (looking-at "[ \t]*\\\\?$") - (= (forward-line -1) 0))) - (current-indentation)))) - (indent-to col)) - (indent-according-to-mode))))) + (not (eq c-lit-type 'string)) + (or (not (looking-at "\\s *$")) + (eq (char-before) ?\\)) + (<= (save-excursion + (goto-char c-macro-start) + (if (looking-at c-opt-cpp-start) + (goto-char (match-end 0))) + (point)) + (point)))) + (let ((comment-multi-line t) + (fill-prefix nil)) + (c-indent-new-comment-line nil t))) + + ((eq c-lit-type 'string) + (if (and (numberp c-macro-start) + (not (eq (char-before) ?\\))) + (insert ?\\)) + (newline)) + + (t (delete-horizontal-space) + (newline) + ;; c-indent-line may look at the current indentation, so let's + ;; start out with the same indentation as the previous line. + (let ((col (save-excursion + (backward-char) + (forward-line 0) + (while (and (looking-at "[ \t]*\\\\?$") + (= (forward-line -1) 0))) + (current-indentation)))) + (indent-to col)) + (indent-according-to-mode)))))) (defun c-context-open-line () "Insert a line break suitable to the context and leave point before it. diff --git a/lisp/progmodes/cc-defs.el b/lisp/progmodes/cc-defs.el index a1270243550..9edaf465346 100644 --- a/lisp/progmodes/cc-defs.el +++ b/lisp/progmodes/cc-defs.el @@ -1563,6 +1563,28 @@ with value CHAR in the region [FROM to)." (forward-char))))) +;; Miscellaneous macro(s) +(defvar c-string-fences-set-flag nil) +;; Non-nil when we have set string fences with `c-restore-string-fences'. +(defmacro c-with-string-fences (&rest forms) + ;; Restore the string fences, evaluate FORMS, then remove them again. It + ;; should only be used at the top level of "boundary" functions in CC Mode, + ;; i.e. those called from outside CC Mode which directly or indirectly need + ;; unbalanced string markers to have their string-fence syntax-table text + ;; properties. This includes all calls to `c-parse-state'. This macro will + ;; be invoked recursively; however the `c-string-fences-set-flag' mechanism + ;; should ensure consistency, when this happens. + (declare (debug t)) + `(unwind-protect + (progn + (unless c-string-fences-set-flag + (c-restore-string-fences)) + (let ((c-string-fences-set-flag t)) + ,@forms)) + (unless c-string-fences-set-flag + (c-clear-string-fences)))) + + ;; Macros to put overlays (Emacs) or extents (XEmacs) on buffer text. ;; For our purposes, these are characterized by being possible to ;; remove again without affecting the other text properties in the diff --git a/lisp/progmodes/cc-engine.el b/lisp/progmodes/cc-engine.el index 3068c41a57e..8794a527f88 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. @@ -3418,7 +3422,9 @@ initializing CC Mode. Currently (2020-06) these are `js-mode' and ;; Return a good pos (in the sense of `c-state-cache-good-pos') at the ;; lowest[*] position between POS and HERE which is syntactically equivalent ;; to HERE. This position may be HERE itself. POS is before HERE in the - ;; buffer. + ;; buffer. If POS and HERE are both in the same literal, return the start + ;; of the literal. STATE is the parsing state at POS. + ;; ;; [*] We don't actually always determine this exact position, since this ;; would require a disproportionate amount of work, given that this function ;; deals only with a corner condition, and POS and HERE are typically on @@ -3434,7 +3440,7 @@ initializing CC Mode. Currently (2020-06) these are `js-mode' and (setq pos (point) state s))) (if (eq (point) here) ; HERE is in the same literal as POS - pos + (nth 8 state) ; A valid good pos cannot be in a literal. (setq s (parse-partial-sexp pos here (1+ (car state)) nil state nil)) (cond ((> (car s) (car state)) ; Moved into a paren between POS and HERE @@ -3880,7 +3886,10 @@ initializing CC Mode. Currently (2020-06) these are `js-mode' and (cons (if (and ce (< bra ce) (> ce here)) ; {..} straddling HERE? bra (point-min)) - (min here from))))))))) + (progn + (goto-char (min here from)) + (c-beginning-of-macro) + (point)))))))))) (defsubst c-state-push-any-brace-pair (bra+1 macro-start-or-here) ;; If BRA+1 is nil, do nothing. Otherwise, BRA+1 is the buffer position @@ -6135,7 +6144,7 @@ comment at the start of cc-engine.el for more info." (setq s (cons -1 (cdr s)))) ((and (equal match ",") (eq (car s) -1))) ; at "," in "class foo : bar, ..." - ((member match '(";" "*" "," "(")) + ((member match '(";" "*" "," ")")) (when (and s (cdr s) (<= (car s) 0)) (setq s (cdr s)))) ((c-keyword-member kwd-sym 'c-flat-decl-block-kwds) @@ -6808,26 +6817,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 identifier. + ;; + ;; 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 +8240,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 +8469,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 +9199,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 @@ -9906,6 +9942,10 @@ This function might do hidden buffer changes." ;; Set when we have encountered a keyword (e.g. "extern") which ;; causes the following declaration to be treated as though top-level. make-top + ;; A list of found types in this declaration. This is an association + ;; list, the car being the buffer position, the cdr being the + ;; identifier. + found-type-list ;; Save `c-record-type-identifiers' and ;; `c-record-ref-identifiers' since ranges are recorded ;; speculatively and should be thrown away if it turns out @@ -9975,10 +10015,17 @@ This function might do hidden buffer changes." ;; If the previous identifier is a found type we ;; record it as a real one; it might be some sort of ;; alias for a prefix like "unsigned". - (save-excursion - (goto-char type-start) - (let ((c-promote-possible-types t)) - (c-forward-type)))) + ;; We postpone entering the new found type into c-found-types + ;; until we are sure of it, thus preventing rapid alternation + ;; of the fontification of the token throughout the buffer. + (push (cons type-start + (buffer-substring-no-properties + type-start + (save-excursion + (goto-char type-start) + (c-end-of-token) + (point)))) + found-type-list)) ;; Signal a type declaration for "struct foo {". (when (and backup-at-type-decl @@ -10224,13 +10271,10 @@ This function might do hidden buffer changes." (when (eq at-type 'found) ;; Remove the ostensible type from the found types list. (when type-start - (c-unfind-type - (buffer-substring-no-properties - type-start - (save-excursion - (goto-char type-start) - (c-end-of-token) - (point))))) + (let ((discard-t (assq type-start found-type-list))) + (when discard-t + (setq found-type-list + (remq discard-t found-type-list))))) t)) ;; The token which we assumed to be a type is actually the ;; identifier, and we have no explicit type. @@ -10844,6 +10888,14 @@ This function might do hidden buffer changes." ;; interactive refontification. (c-put-c-type-property (point) 'c-decl-arg-start)) + ;; Enter all the found types into `c-found-types'. + (when found-type-list + (save-excursion + (let ((c-promote-possible-types t)) + (dolist (ft found-type-list) + (goto-char (car ft)) + (c-forward-type))))) + ;; Record the type's coordinates in `c-record-type-identifiers' for ;; later fontification. (when (and c-record-type-identifiers at-type ;; (not (eq at-type t)) @@ -12092,7 +12144,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 +14071,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 63df267b43f..15e3beb8377 100644 --- a/lisp/progmodes/cc-fonts.el +++ b/lisp/progmodes/cc-fonts.el @@ -97,6 +97,7 @@ (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-font-lock-fontify-region) ;; Note that font-lock in XEmacs doesn't expand face names as @@ -919,13 +920,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) @@ -2255,6 +2249,49 @@ 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 (buffer start end) + ;; Force redisplay immediately. This assumes `font-lock-support-mode' is + ;; 'jit-lock-mode. Set the variable `c-re-redisplay-timer' to nil. + (with-current-buffer buffer + (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 + (current-buffer) + (match-beginning 0) (match-end 0))))))))))) + ;;; C. diff --git a/lisp/progmodes/cc-guess.el b/lisp/progmodes/cc-guess.el index ea5dd48986c..584db86539e 100644 --- a/lisp/progmodes/cc-guess.el +++ b/lisp/progmodes/cc-guess.el @@ -76,6 +76,8 @@ (cc-require 'cc-engine) (cc-require 'cc-styles) +(cc-bytecomp-defun c-restore-string-fences) +(cc-bytecomp-defun c-clear-string-fences) (defcustom c-guess-offset-threshold 10 @@ -225,11 +227,12 @@ guess is made from scratch. Note that the larger the region to guess in, the slower the guessing. So you can limit the region with `c-guess-region-max'." (interactive "r\nP") - (let ((accumulator (when accumulate c-guess-accumulator))) - (setq c-guess-accumulator (c-guess-examine start end accumulator)) - (let ((pair (c-guess-guess c-guess-accumulator))) - (setq c-guess-guessed-basic-offset (car pair) - c-guess-guessed-offsets-alist (cdr pair))))) + (c-with-string-fences + (let ((accumulator (when accumulate c-guess-accumulator))) + (setq c-guess-accumulator (c-guess-examine start end accumulator)) + (let ((pair (c-guess-guess c-guess-accumulator))) + (setq c-guess-guessed-basic-offset (car pair) + c-guess-guessed-offsets-alist (cdr pair)))))) (defun c-guess-examine (start end accumulator) diff --git a/lisp/progmodes/cc-mode.el b/lisp/progmodes/cc-mode.el index 0aef94a4f2d..ae96cdbd2fe 100644 --- a/lisp/progmodes/cc-mode.el +++ b/lisp/progmodes/cc-mode.el @@ -179,6 +179,15 @@ (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))) (c-save-buffer-state () (c-clear-char-properties (point-min) (point-max) 'category) (c-clear-char-properties (point-min) (point-max) 'syntax-table) @@ -745,6 +754,8 @@ 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) + (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 @@ -787,43 +798,44 @@ MODE is the symbol for the mode to initialize, like `c-mode'. See `c-basic-common-init' for details. It's only optional to be compatible with old code; callers should always specify it." - (unless mode - ;; Called from an old third party package. The fallback is to - ;; initialize for C. - (c-init-language-vars-for 'c-mode)) + (let (case-fold-search) + (unless mode + ;; Called from an old third party package. The fallback is to + ;; initialize for C. + (c-init-language-vars-for 'c-mode)) - (c-basic-common-init mode c-default-style) - (when mode - ;; Only initialize font locking if we aren't called from an old package. - (c-font-lock-init)) + (c-basic-common-init mode c-default-style) + (when mode + ;; Only initialize font locking if we aren't called from an old package. + (c-font-lock-init)) - ;; Starting a mode is a sort of "change". So call the change functions... - (save-restriction - (widen) - (setq c-new-BEG (point-min)) - (setq c-new-END (point-max)) - (save-excursion - (let (before-change-functions after-change-functions) - (mapc (lambda (fn) - (funcall fn (point-min) (point-max))) - c-get-state-before-change-functions) - (mapc (lambda (fn) - (funcall fn (point-min) (point-max) - (- (point-max) (point-min)))) - c-before-font-lock-functions)))) - - (set (make-local-variable 'outline-regexp) "[^#\n\^M]") - (set (make-local-variable 'outline-level) 'c-outline-level) - (set (make-local-variable 'add-log-current-defun-function) - (lambda () - (or (c-cpp-define-name) (car (c-defun-name-and-limits nil))))) - (let ((rfn (assq mode c-require-final-newline))) - (when rfn - (if (boundp 'mode-require-final-newline) - (and (cdr rfn) - (set (make-local-variable 'require-final-newline) - mode-require-final-newline)) - (set (make-local-variable 'require-final-newline) (cdr rfn)))))) + ;; Starting a mode is a sort of "change". So call the change functions... + (save-restriction + (widen) + (setq c-new-BEG (point-min)) + (setq c-new-END (point-max)) + (save-excursion + (let (before-change-functions after-change-functions) + (mapc (lambda (fn) + (funcall fn (point-min) (point-max))) + c-get-state-before-change-functions) + (mapc (lambda (fn) + (funcall fn (point-min) (point-max) + (- (point-max) (point-min)))) + c-before-font-lock-functions)))) + + (set (make-local-variable 'outline-regexp) "[^#\n\^M]") + (set (make-local-variable 'outline-level) 'c-outline-level) + (set (make-local-variable 'add-log-current-defun-function) + (lambda () + (or (c-cpp-define-name) (car (c-defun-name-and-limits nil))))) + (let ((rfn (assq mode c-require-final-newline))) + (when rfn + (if (boundp 'mode-require-final-newline) + (and (cdr rfn) + (set (make-local-variable 'require-final-newline) + mode-require-final-newline)) + (set (make-local-variable 'require-final-newline) (cdr rfn))))))) (defun c-count-cfss (lv-alist) ;; LV-ALIST is an alist like `file-local-variables-alist'. Count how many @@ -985,7 +997,8 @@ Note that the style variables are always made local to the buffer." ;; `c-before/after-change', frame 3 is the primitive invoking the change ;; hook. (memq (cadr (backtrace-frame 3)) - '(put-text-property remove-list-of-text-properties))) + '(put-text-property remove-text-properties + remove-list-of-text-properties))) (defun c-depropertize-CPP (beg end) ;; Remove the punctuation syntax-table text property from the CPP parts of @@ -1307,7 +1320,8 @@ Note that the style variables are always made local to the buffer." ;; balanced by another " is left with a '(1) syntax-table property. (when (and c-min-syn-tab-mkr c-max-syn-tab-mkr) - (let (s pos) + (c-save-buffer-state (s pos) ; Prevent text property stuff causing change + ; function invocation. (setq pos c-min-syn-tab-mkr) (while (and @@ -1330,7 +1344,8 @@ Note that the style variables are always made local to the buffer." (c-search-backward-char-property-with-value-on-char 'c-fl-syn-tab '(15) ?\" (max (- (point) 500) (point-min)))) - (not (equal (c-get-char-property (point) 'syntax-table) '(1)))) + (not (equal (c-get-char-property (point) 'syntax-table) + '(1)))) (setq pos (1+ pos)))) (while (< pos c-max-syn-tab-mkr) (setq pos @@ -1360,7 +1375,9 @@ Note that the style variables are always made local to the buffer." ;; Restore any syntax-table text properties which are "mirrored" by ;; c-fl-syn-tab text properties. (when (and c-min-syn-tab-mkr c-max-syn-tab-mkr) - (let ((pos c-min-syn-tab-mkr)) + (c-save-buffer-state ; Prevent text property stuff causing change function + ; invocation. + ((pos c-min-syn-tab-mkr)) (while (and (< pos c-max-syn-tab-mkr) @@ -1950,6 +1967,43 @@ 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-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 @@ -1967,115 +2021,116 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") ;; or a comment - "wrongly" removing a symbol from `c-found-types' ;; isn't critical. (unless (c-called-from-text-property-change-p) - (save-restriction - (widen) - (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. - (setq beg (point-min) - end (point-max) - c-just-done-before-change 'whole-buffer) - (setq c-just-done-before-change t)) - ;; (c-new-BEG c-new-END) will be the region to fontify. - (setq c-new-BEG beg c-new-END end) - (setq c-maybe-stale-found-type nil) - ;; A workaround for syntax-ppss's failure to notice syntax-table text - ;; property changes. - (when (fboundp 'syntax-ppss) - (setq c-syntax-table-hwm most-positive-fixnum)) - (save-match-data - (widen) - (unwind-protect - (progn - (c-restore-string-fences) - (save-excursion - ;; Are we inserting/deleting stuff in the middle of an - ;; identifier? - (c-unfind-enclosing-token beg) - (c-unfind-enclosing-token end) - ;; Are we coalescing two tokens together, e.g. "fo o" - ;; -> "foo"? - (when (< beg end) - (c-unfind-coalesced-tokens beg end)) - (c-invalidate-sws-region-before beg end) - ;; Are we (potentially) disrupting the syntactic - ;; context which makes a type a type? E.g. by - ;; inserting stuff after "foo" in "foo bar;", or - ;; before "foo" in "typedef foo *bar;"? - ;; - ;; We search for appropriate c-type properties "near" - ;; the change. First, find an appropriate boundary - ;; for this property search. - (let (lim lim-2 - type type-pos - marked-id term-pos - (end1 - (or (and (eq (get-text-property end 'face) - 'font-lock-comment-face) - (previous-single-property-change end 'face)) - end))) - (when (>= end1 beg) ; Don't hassle about changes entirely in + (c-with-string-fences + (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. + (setq beg (point-min) + end (point-max) + c-just-done-before-change 'whole-buffer) + (setq c-just-done-before-change t)) + ;; (c-new-BEG c-new-END) will be the region to fontify. + (setq c-new-BEG beg c-new-END end) + (setq c-maybe-stale-found-type nil) + ;; A workaround for syntax-ppss's failure to notice syntax-table text + ;; property changes. + (when (fboundp 'syntax-ppss) + (setq c-syntax-table-hwm most-positive-fixnum)) + (save-match-data + (save-excursion + ;; Are we inserting/deleting stuff in the middle of an + ;; identifier? + (c-unfind-enclosing-token beg) + (c-unfind-enclosing-token end) + ;; Are we coalescing two tokens together, e.g. "fo o" + ;; -> "foo"? + (when (< beg end) + (c-unfind-coalesced-tokens beg end)) + (c-invalidate-sws-region-before beg end) + ;; Are we (potentially) disrupting the syntactic + ;; context which makes a type a type? E.g. by + ;; inserting stuff after "foo" in "foo bar;", or + ;; before "foo" in "typedef foo *bar;"? + ;; + ;; We search for appropriate c-type properties "near" + ;; the change. First, find an appropriate boundary + ;; for this property search. + (let (lim lim-2 + type type-pos + marked-id term-pos + (end1 + (or (and (eq (get-text-property end 'face) + 'font-lock-comment-face) + (previous-single-property-change end 'face)) + end))) + (when (>= end1 beg) ; Don't hassle about changes entirely in ; comments. - ;; Find a limit for the search for a `c-type' property - ;; Point is currently undefined. A `goto-char' somewhere is needed. (2020-12-06). - (setq lim-2 (c-determine-limit 1000 (point) ; that is wrong. FIXME!!! (2020-12-06) - )) - (while - (and (/= (skip-chars-backward "^;{}" lim-2) 0) - (> (point) (point-min)) - (memq (c-get-char-property (1- (point)) 'face) - '(font-lock-comment-face font-lock-string-face)))) - (setq lim (max (point-min) (1- (point)))) - - ;; Look for the latest `c-type' property before end1 - (when (and (> end1 (point-min)) - (setq type-pos - (if (get-text-property (1- end1) 'c-type) - end1 - (previous-single-property-change end1 'c-type - nil lim)))) - (setq type (get-text-property (max (1- type-pos) lim) 'c-type)) - - (when (memq type '(c-decl-id-start c-decl-type-start)) - ;; Get the identifier, if any, that the property is on. - (goto-char (1- type-pos)) - (setq marked-id - (when (looking-at "\\(\\sw\\|\\s_\\)") - (c-beginning-of-current-token) - (buffer-substring-no-properties (point) type-pos))) - - (goto-char end1) - (setq lim-2 (c-determine-+ve-limit 1000)) - (skip-chars-forward "^;{}" lim-2) ; FIXME!!! loop for + ;; Find a limit for the search for a `c-type' property + ;; Point is currently undefined. A `goto-char' somewhere is needed. (2020-12-06). + (setq lim-2 (c-determine-limit 1000 (point) ; that is wrong. FIXME!!! (2020-12-06) + )) + (while + (and (/= (skip-chars-backward "^;{}" lim-2) 0) + (> (point) (point-min)) + (memq (c-get-char-property (1- (point)) 'face) + '(font-lock-comment-face font-lock-string-face)))) + (setq lim (max (point-min) (1- (point)))) + + ;; Look for the latest `c-type' property before end1 + (when (and (> end1 (point-min)) + (setq type-pos + (if (get-text-property (1- end1) 'c-type) + end1 + (previous-single-property-change end1 'c-type + nil lim)))) + (setq type (get-text-property (max (1- type-pos) lim) 'c-type)) + + (when (memq type '(c-decl-id-start c-decl-type-start)) + ;; Get the identifier, if any, that the property is on. + (goto-char (1- type-pos)) + (setq marked-id + (when (looking-at "\\(\\sw\\|\\s_\\)") + (c-beginning-of-current-token) + (buffer-substring-no-properties (point) type-pos))) + + (goto-char end1) + (setq lim-2 (c-determine-+ve-limit 1000)) + (skip-chars-forward "^;{}" lim-2) ; FIXME!!! loop for ; comment, maybe - (setq lim (point)) - (setq term-pos - (or (c-next-single-property-change end 'c-type nil lim) lim)) - (setq c-maybe-stale-found-type - (list type marked-id - type-pos term-pos - (buffer-substring-no-properties type-pos - term-pos) - (buffer-substring-no-properties beg end))))))) - - (if c-get-state-before-change-functions - (mapc (lambda (fn) - (funcall fn beg end)) - c-get-state-before-change-functions)) - - (c-laomib-invalidate-cache beg end))) - (c-clear-string-fences)))) - (c-truncate-lit-pos-cache beg) - ;; The following must be done here rather than in `c-after-change' - ;; because newly inserted parens would foul up the invalidation - ;; algorithm. - (c-invalidate-state-cache beg) - ;; The following must happen after the previous, which likely alters - ;; the macro cache. - (when c-opt-cpp-symbol - (c-invalidate-macro-cache beg end)))) + (setq lim (point)) + (setq term-pos + (or (c-next-single-property-change end 'c-type nil lim) lim)) + (setq c-maybe-stale-found-type + (list type marked-id + type-pos term-pos + (buffer-substring-no-properties type-pos + term-pos) + (buffer-substring-no-properties beg end))))))) + + (if c-get-state-before-change-functions + (mapc (lambda (fn) + (funcall fn beg end)) + c-get-state-before-change-functions)) + + (c-laomib-invalidate-cache beg end)))) + (c-truncate-lit-pos-cache beg) + ;; The following must be done here rather than in `c-after-change' + ;; because newly inserted parens would foul up the invalidation + ;; algorithm. + (c-invalidate-state-cache beg) + ;; The following must happen after the previous, which likely alters + ;; the macro cache. + (when c-opt-cpp-symbol + (c-invalidate-macro-cache beg end))))) (defvar c-in-after-change-fontification nil) (make-variable-buffer-local 'c-in-after-change-fontification) @@ -2127,50 +2182,48 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") (save-restriction (save-match-data ; c-recognize-<>-arglists changes match-data (widen) - (unwind-protect - (progn - (c-restore-string-fences) - (when (> end (point-max)) - ;; Some emacsen might return positions past the end. This - ;; has been observed in Emacs 20.7 when rereading a buffer - ;; changed on disk (haven't been able to minimize it, but - ;; Emacs 21.3 appears to work). - (setq end (point-max)) - (when (> beg end) - (setq beg end))) - - ;; C-y is capable of spuriously converting category - ;; properties c-</>-as-paren-syntax and - ;; c-cpp-delimiter into hard syntax-table properties. - ;; Remove these when it happens. - (when (eval-when-compile (memq 'category-properties c-emacs-features)) - (c-save-buffer-state () - (c-clear-char-property-with-value beg end 'syntax-table - c-<-as-paren-syntax) - (c-clear-char-property-with-value beg end 'syntax-table - c->-as-paren-syntax) - (c-clear-char-property-with-value beg end 'syntax-table nil))) - - (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) - ;; (c-invalidate-state-cache beg) ; moved to - ;; `c-before-change'. - (c-invalidate-find-decl-cache beg) - - (when c-recognize-<>-arglists - (c-after-change-check-<>-operators beg end)) - - (setq c-in-after-change-fontification t) - (save-excursion - (mapc (lambda (fn) - (funcall fn beg end old-len)) - c-before-font-lock-functions))) - (c-clear-string-fences)))))) + (c-with-string-fences + (when (> end (point-max)) + ;; Some emacsen might return positions past the end. This + ;; has been observed in Emacs 20.7 when rereading a buffer + ;; changed on disk (haven't been able to minimize it, but + ;; Emacs 21.3 appears to work). + (setq end (point-max)) + (when (> beg end) + (setq beg end))) + + ;; C-y is capable of spuriously converting category + ;; properties c-</>-as-paren-syntax and + ;; c-cpp-delimiter into hard syntax-table properties. + ;; Remove these when it happens. + (when (eval-when-compile (memq 'category-properties c-emacs-features)) + (c-save-buffer-state () + (c-clear-char-property-with-value beg end 'syntax-table + c-<-as-paren-syntax) + (c-clear-char-property-with-value beg end 'syntax-table + 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) + ;; (c-invalidate-state-cache beg) ; moved to + ;; `c-before-change'. + (c-invalidate-find-decl-cache beg) + + (when c-recognize-<>-arglists + (c-after-change-check-<>-operators beg end)) + + (setq c-in-after-change-fontification t) + (save-excursion + (mapc (lambda (fn) + (funcall fn beg end old-len)) + c-before-font-lock-functions))))) ;; A workaround for syntax-ppss's failure to notice syntax-table text ;; property changes. - (when (fboundp 'syntax-ppss) - (syntax-ppss-flush-cache c-syntax-table-hwm))) + (when (fboundp 'syntax-ppss) + (syntax-ppss-flush-cache c-syntax-table-hwm))))) (defun c-doc-fl-decl-start (pos) ;; If the line containing POS is in a doc comment continued line (as defined @@ -2402,46 +2455,42 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") (widen) (let (new-beg new-end new-region case-fold-search) (c-save-buffer-state nil - ;; Temporarily reapply the string fence syntax-table properties. - (unwind-protect - (progn - (c-restore-string-fences) - (if (and c-in-after-change-fontification - (< beg c-new-END) (> end c-new-BEG)) - ;; Region and the latest after-change fontification region overlap. - ;; Determine the upper and lower bounds of our adjusted region - ;; separately. - (progn - (if (<= beg c-new-BEG) - (setq c-in-after-change-fontification nil)) - (setq new-beg - (if (and (>= beg (c-point 'bol c-new-BEG)) - (<= beg c-new-BEG)) - ;; Either jit-lock has accepted `c-new-BEG', or has - ;; (probably) extended the change region spuriously - ;; to BOL, which position likely has a - ;; syntactically different position. To ensure - ;; correct fontification, we start at `c-new-BEG', - ;; assuming any characters to the left of - ;; `c-new-BEG' on the line do not require - ;; fontification. - c-new-BEG - (setq new-region (c-before-context-fl-expand-region beg end) - new-end (cdr new-region)) - (car new-region))) - (setq new-end - (if (and (>= end (c-point 'bol c-new-END)) - (<= end c-new-END)) - c-new-END - (or new-end - (cdr (c-before-context-fl-expand-region beg end)))))) - ;; Context (etc.) fontification. - (setq new-region (c-before-context-fl-expand-region beg end) - new-beg (car new-region) new-end (cdr new-region))) - ;; Finally invoke font lock's functionality. - (funcall (default-value 'font-lock-fontify-region-function) - new-beg new-end verbose)) - (c-clear-string-fences)))))) + (c-with-string-fences + (if (and c-in-after-change-fontification + (< beg c-new-END) (> end c-new-BEG)) + ;; Region and the latest after-change fontification region overlap. + ;; Determine the upper and lower bounds of our adjusted region + ;; separately. + (progn + (if (<= beg c-new-BEG) + (setq c-in-after-change-fontification nil)) + (setq new-beg + (if (and (>= beg (c-point 'bol c-new-BEG)) + (<= beg c-new-BEG)) + ;; Either jit-lock has accepted `c-new-BEG', or has + ;; (probably) extended the change region spuriously + ;; to BOL, which position likely has a + ;; syntactically different position. To ensure + ;; correct fontification, we start at `c-new-BEG', + ;; assuming any characters to the left of + ;; `c-new-BEG' on the line do not require + ;; fontification. + c-new-BEG + (setq new-region (c-before-context-fl-expand-region beg end) + new-end (cdr new-region)) + (car new-region))) + (setq new-end + (if (and (>= end (c-point 'bol c-new-END)) + (<= end c-new-END)) + c-new-END + (or new-end + (cdr (c-before-context-fl-expand-region beg end)))))) + ;; Context (etc.) fontification. + (setq new-region (c-before-context-fl-expand-region beg end) + new-beg (car new-region) new-end (cdr new-region))) + ;; Finally invoke font lock's functionality. + (funcall (default-value 'font-lock-fontify-region-function) + new-beg new-end verbose)))))) (defun c-after-font-lock-init () ;; Put on `font-lock-mode-hook'. This function ensures our after-change @@ -2549,17 +2598,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 a66f91e0eb3..1cf14d52d55 100644 --- a/lisp/progmodes/cc-styles.el +++ b/lisp/progmodes/cc-styles.el @@ -180,6 +180,7 @@ (inclass . +) (inline-open . 0)))) ("linux" + (indent-tabs-mode . t) (c-basic-offset . 8) (c-comment-only-line-offset . 0) (c-hanging-braces-alist . ((brace-list-open) @@ -444,17 +445,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 45521d50218..e0f5a7ee021 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 diff --git a/lisp/progmodes/cfengine.el b/lisp/progmodes/cfengine.el index 6fc898d95be..00348ac0bb9 100644 --- a/lisp/progmodes/cfengine.el +++ b/lisp/progmodes/cfengine.el @@ -989,13 +989,7 @@ Intended as the value of `indent-line-function'." (defun cfengine-fill-paragraph (&optional justify) "Fill `paragraphs' in Cfengine code." (interactive "P") - (or (if (fboundp 'fill-comment-paragraph) - (fill-comment-paragraph justify) - ;; else do nothing in a comment - (nth 4 (parse-partial-sexp (save-excursion - (beginning-of-defun) - (point)) - (point)))) + (or (fill-comment-paragraph justify) (let ((paragraph-start ;; Include start of parenthesized block. "\f\\|[ \t]*$\\|.*(") diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el index 7d4a8ffc6fc..d28fce9dbd7 100644 --- a/lisp/progmodes/compile.el +++ b/lisp/progmodes/compile.el @@ -82,6 +82,25 @@ after `call-process' inserts the grep output into the buffer.") "Position of the start of the text inserted by `compilation-filter'. This is bound before running `compilation-filter-hook'.") +(defcustom compilation-hidden-output nil + "Regexp to match output from the compilation that should be hidden. +This can also be a list of regexps. + +The text matched by this variable will be made invisible, which +means that it'll still be present in the buffer, so that +navigation commands (for instance, `next-error') can still make +use of the hidden text to determine the current directory and the +like. + +For instance, to hide the verbose output from recursive +makefiles, you can say something like: + + (setq compilation-hidden-output + \\='(\"^make[^\n]+\n\"))" + :type '(choice regexp + (repeat regexp)) + :version "29.1") + (defvar compilation-first-column 1 "This is how compilers number the first column, usually 1 or 0. If this is buffer-local in the destination buffer, Emacs obeys @@ -346,12 +365,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 @@ -954,7 +970,10 @@ Faces `compilation-error-face', `compilation-warning-face', (defcustom compilation-auto-jump-to-first-error nil "If non-nil, automatically jump to the first error during compilation." - :type 'boolean + :type '(choice (const :tag "Never" nil) + (const :tag "Always" t) + (const :tag "If location known" if-location-known) + (const :tag "First known location" first-known)) :version "23.1") (defvar-local compilation-auto-jump-to-next nil @@ -1185,14 +1204,39 @@ POS and RES.") l2 (setcdr l1 (cons (list ,key) l2))))))) +(defun compilation--file-known-p () + "Say whether the file under point can be found." + (when-let* ((msg (get-text-property (point) 'compilation-message)) + (loc (compilation--message->loc msg)) + (elem (compilation-find-file-1 + (point-marker) + (caar (compilation--loc->file-struct loc)) + (cadr (car (compilation--loc->file-struct loc))) + (compilation--file-struct->formats + (compilation--loc->file-struct loc))))) + (car elem))) + (defun compilation-auto-jump (buffer pos) (when (buffer-live-p buffer) (with-current-buffer buffer (goto-char pos) (let ((win (get-buffer-window buffer 0))) (if win (set-window-point win pos))) - (if compilation-auto-jump-to-first-error - (compile-goto-error))))) + (when compilation-auto-jump-to-first-error + (cl-case compilation-auto-jump-to-first-error + ('if-location-known + (when (compilation--file-known-p) + (compile-goto-error))) + ('first-known + (let (match) + (while (and (not (compilation--file-known-p)) + (setq match (text-property-search-forward + 'compilation-message nil nil t))) + (goto-char (prop-match-beginning match)))) + (when (compilation--file-known-p) + (compile-goto-error))) + (otherwise + (compile-goto-error))))))) ;; This function is the central driver, called when font-locking to gather ;; all information needed to later jump to corresponding source code. @@ -1523,7 +1567,8 @@ to `compilation-error-regexp-alist' if RULES is nil." ;; FIXME-omake: Doing it here seems wrong, at least it should depend on ;; whether or not omake's own error messages are recognized. (cond - ((not omake-included) nil) + ((or (not omake-included) (not pat)) + nil) ((string-match "\\`\\([^^]\\|\\^\\( \\*\\|\\[\\)\\)" pat) nil) ;; Not anchored or anchored but already allows empty spaces. (t (setq pat (concat "^\\(?: \\)?" (substring pat 1))))) @@ -1542,7 +1587,7 @@ to `compilation-error-regexp-alist' if RULES is nil." (error "HYPERLINK should be an integer: %s" (nth 5 item))) (goto-char start) - (while (re-search-forward pat end t) + (while (and pat (re-search-forward pat end t)) (when (setq props (compilation-error-properties file line end-line col end-col (or type 2) fmt rule)) @@ -1755,13 +1800,21 @@ If nil, ask to kill it." :type 'boolean :version "24.3") +(defcustom compilation-max-output-line-length 400 + "Output lines that are longer than this value will be hidden. +If nil, don't hide anything." + :type '(choice (const :tag "Hide nothing" nil) + integer) + :version "29.1") + (defun compilation--update-in-progress-mode-line () ;; `compilation-in-progress' affects the mode-line of all ;; buffers when it changes from nil to non-nil or vice-versa. (unless compilation-in-progress (force-mode-line-update t))) ;;;###autoload -(defun compilation-start (command &optional mode name-function highlight-regexp) +(defun compilation-start (command &optional mode name-function highlight-regexp + continue) "Run compilation command COMMAND (low level interface). If COMMAND starts with a cd command, that becomes the `default-directory'. The rest of the arguments are optional; for them, nil means use the default. @@ -1778,6 +1831,12 @@ If HIGHLIGHT-REGEXP is non-nil, `next-error' will temporarily highlight the matching section of the visited source line; the default is to use the global value of `compilation-highlight-regexp'. +If CONTINUE is non-nil, the buffer won't be emptied before +compilation is started. This can be useful if you wish to +combine the output from several compilation commands in the same +buffer. The new output will be at the end of the buffer, and +point is not changed. + Returns the compilation buffer created." (or mode (setq mode 'compilation-mode)) (let* ((name-of-mode @@ -1841,7 +1900,12 @@ Returns the compilation buffer created." (if (= (length expanded-dir) 1) (car expanded-dir) substituted-dir))))) - (erase-buffer) + (if continue + (progn + ;; Save the point so we can restore it. + (setq continue (point)) + (goto-char (point-max))) + (erase-buffer)) ;; Select the desired mode. (if (not (eq mode t)) (progn @@ -1867,12 +1931,13 @@ Returns the compilation buffer created." (if (or compilation-auto-jump-to-first-error (eq compilation-scroll-output 'first-error)) (setq-local compilation-auto-jump-to-next t)) - ;; Output a mode setter, for saving and later reloading this buffer. - (insert "-*- mode: " name-of-mode - "; default-directory: " - (prin1-to-string (abbreviate-file-name default-directory)) - " -*-\n" - (format "%s started at %s\n\n" + (when (zerop (buffer-size)) + ;; Output a mode setter, for saving and later reloading this buffer. + (insert "-*- mode: " name-of-mode + "; default-directory: " + (prin1-to-string (abbreviate-file-name default-directory)) + " -*-\n")) + (insert (format "%s started at %s\n\n" mode-name (substring (current-time-string) 0 19)) command "\n") @@ -1891,28 +1956,33 @@ Returns the compilation buffer created." (and (derived-mode-p 'comint-mode) (comint-term-environment)) (list (format "INSIDE_EMACS=%s,compile" emacs-version)) + ;; Some external programs (like "git grep") use a pager; + ;; defeat that. + (list "PAGER=") (copy-sequence process-environment)))) (setq-local compilation-arguments (list command mode name-function highlight-regexp)) (setq-local revert-buffer-function 'compilation-revert-buffer) - (and outwin - ;; Forcing the window-start overrides the usual redisplay - ;; feature of bringing point into view, so setting the - ;; window-start to top of the buffer risks losing the - ;; effect of moving point to EOB below, per - ;; compilation-scroll-output, if the command is long - ;; enough to push point outside of the window. This - ;; could happen, e.g., in `rgrep'. - (not compilation-scroll-output) - (set-window-start outwin (point-min))) + (when (and outwin + (not continue) + ;; Forcing the window-start overrides the usual redisplay + ;; feature of bringing point into view, so setting the + ;; window-start to top of the buffer risks losing the + ;; effect of moving point to EOB below, per + ;; compilation-scroll-output, if the command is long + ;; enough to push point outside of the window. This + ;; could happen, e.g., in `rgrep'. + (not compilation-scroll-output)) + (set-window-start outwin (point-min))) ;; Position point as the user will see it. (let ((desired-visible-point - ;; Put it at the end if `compilation-scroll-output' is set. - (if compilation-scroll-output - (point-max) - ;; Normally put it at the top. - (point-min)))) + (cond + (continue continue) + ;; Put it at the end if `compilation-scroll-output' is set. + (compilation-scroll-output (point-max)) + ;; Normally put it at the top. + (t (point-min))))) (goto-char desired-visible-point) (when (and outwin (not (eq outwin (selected-window)))) (set-window-point outwin desired-visible-point))) @@ -2228,6 +2298,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 @@ -2407,8 +2478,8 @@ commands of Compilation major mode are available. See (defun compilation-filter (proc string) "Process filter for compilation buffers. -Just inserts the text, -handles carriage motion (see `comint-inhibit-carriage-motion'), +Just inserts the text, handles carriage motion (see +`comint-inhibit-carriage-motion'), `compilation-hidden-output', and runs `compilation-filter-hook'." (when (buffer-live-p (process-buffer proc)) (with-current-buffer (process-buffer proc) @@ -2428,13 +2499,18 @@ and runs `compilation-filter-hook'." ;; We used to use `insert-before-markers', so that windows with ;; point at `process-mark' scroll along with the output, but we ;; now use window-point-insertion-type instead. - (insert string) + (if (not compilation-max-output-line-length) + (insert string) + (dolist (line (string-lines string nil t)) + (compilation--insert-abbreviated-line + line compilation-max-output-line-length))) + (when compilation-hidden-output + (compilation--hide-output compilation-filter-start)) (unless comint-inhibit-carriage-motion (comint-carriage-motion (process-mark proc) (point))) (set-marker (process-mark proc) (point)) ;; Update the number of errors in compilation-mode-line-errors (compilation--ensure-parse (point)) - ;; (setq-local compilation-buffer-modtime (current-time)) (run-hooks 'compilation-filter-hook)) (goto-char pos) (narrow-to-region min max) @@ -2442,6 +2518,58 @@ and runs `compilation-filter-hook'." (set-marker min nil) (set-marker max nil)))))) +(defun compilation--hide-output (start) + (save-excursion + (goto-char start) + (beginning-of-line) + ;; Apply the match to each line, but wait until we have a complete + ;; line. + (let ((start (point))) + (while (search-forward "\n" nil t) + (save-restriction + (narrow-to-region start (point)) + (dolist (regexp (ensure-list compilation-hidden-output)) + (goto-char start) + (while (re-search-forward regexp nil t) + (add-text-properties (match-beginning 0) (match-end 0) + '( invisible t + rear-nonsticky t)))) + (goto-char (point-max))))))) + +(defun compilation--insert-abbreviated-line (string width) + (if (and (> (current-column) 0) + (get-text-property (1- (point)) 'button)) + ;; We already have an abbreviation; just add the string to it. + (let ((beg (point))) + (insert string) + (add-text-properties + beg + ;; Don't make the final newline invisible. + (if (= (aref string (1- (length string))) ?\n) + (1- (point)) + (point)) + (text-properties-at (1- beg)))) + (insert string) + ;; If we exceeded the limit, hide the last portion of the line. + (when (> (current-column) width) + (let ((start (save-excursion + (move-to-column width) + (point)))) + (buttonize-region + start (point) + (lambda (start) + (let ((inhibit-read-only t)) + (remove-text-properties start (save-excursion + (goto-char start) + (line-end-position)) + (text-properties-at start))))) + (put-text-property + start (if (= (aref string (1- (length string))) ?\n) + ;; Don't hide the final newline. + (1- (point)) + (point)) + 'display (if (char-displayable-p ?…) "[…]" "[...]")))))) + (defsubst compilation-buffer-internal-p () "Test if inside a compilation buffer." (local-variable-p 'compilation-locs)) @@ -2931,19 +3059,7 @@ and overlay is highlighted between MK and END-MK." (remove-hook 'pre-command-hook #'compilation-goto-locus-delete-o)) -(defun compilation-find-file (marker filename directory &rest formats) - "Find a buffer for file FILENAME. -If FILENAME is not found at all, ask the user where to find it. -Pop up the buffer containing MARKER and scroll to MARKER if we ask -the user where to find the file. -Search the directories in `compilation-search-path'. -A nil in `compilation-search-path' means to try the -\"current\" directory, which is passed in DIRECTORY. -If DIRECTORY is relative, it is combined with `default-directory'. -If DIRECTORY is nil, that means use `default-directory'. -FORMATS, if given, is a list of formats to reformat FILENAME when -looking for it: for each element FMT in FORMATS, this function -attempts to find a file whose name is produced by (format FMT FILENAME)." +(defun compilation-find-file-1 (marker filename directory &optional formats) (or formats (setq formats '("%s"))) (let ((dirs compilation-search-path) (spec-dir (if directory @@ -2992,6 +3108,23 @@ attempts to find a file whose name is produced by (format FMT FILENAME)." (find-file-noselect name)) fmts (cdr fmts))) (setq dirs (cdr dirs)))) + (list buffer spec-dir))) + +(defun compilation-find-file (marker filename directory &rest formats) + "Find a buffer for file FILENAME. +If FILENAME is not found at all, ask the user where to find it. +Pop up the buffer containing MARKER and scroll to MARKER if we ask +the user where to find the file. +Search the directories in `compilation-search-path'. +A nil in `compilation-search-path' means to try the +\"current\" directory, which is passed in DIRECTORY. +If DIRECTORY is relative, it is combined with `default-directory'. +If DIRECTORY is nil, that means use `default-directory'. +FORMATS, if given, is a list of formats to reformat FILENAME when +looking for it: for each element FMT in FORMATS, this function +attempts to find a file whose name is produced by (format FMT FILENAME)." + (pcase-let ((`(,buffer ,spec-dir) + (compilation-find-file-1 marker filename directory formats))) (while (null buffer) ;Repeat until the user selects an existing file. ;; The file doesn't exist. Ask the user where to find it. (save-excursion ;This save-excursion is probably not right. diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el index ae36789af82..e571cee83c6 100644 --- a/lisp/progmodes/cperl-mode.el +++ b/lisp/progmodes/cperl-mode.el @@ -64,7 +64,7 @@ ;; This mode supports font-lock, imenu and mode-compile. In the ;; hairy version font-lock is on, but you should activate imenu ;; yourself (note that mode-compile is not standard yet). Well, you -;; can use imenu from keyboard anyway (M-x imenu), but it is better +;; can use imenu from keyboard anyway (M-g i), but it is better ;; to bind it like that: ;; (define-key global-map [M-S-down-mouse-3] 'imenu) @@ -558,6 +558,20 @@ This way enabling/disabling of menu items is more correct." :type 'boolean :group 'cperl-speed) +(defcustom cperl-file-style nil + "Indentation style to use in cperl-mode." + :type '(choice (const "CPerl") + (const "PBP") + (const "PerlStyle") + (const "GNU") + (const "C++") + (const "K&R") + (const "BSD") + (const "Whitesmith") + (const :tag "Default" nil)) + :version "29.1") +;;;###autoload(put 'cperl-file-style 'safe-local-variable 'stringp) + (defcustom cperl-ps-print-face-properties '((font-lock-keyword-face nil nil bold shadow) (font-lock-variable-name-face nil nil bold) @@ -1019,15 +1033,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.") @@ -1083,7 +1091,7 @@ Unless KEEP, removes the old indentation." ["Debugger" cperl-db t] "----" ("Tools" - ["Imenu" imenu (fboundp 'imenu)] + ["Imenu" imenu] ["Imenu on Perl Info" cperl-imenu-on-info (featurep 'imenu)] "----" ["Ispell PODs" cperl-pod-spell @@ -1666,9 +1674,11 @@ Settings for classic indent-styles: K&R BSD=C++ GNU PBP PerlStyle=Whitesmith `cperl-continued-statement-offset' 5 4 2 4 4 CPerl knows several indentation styles, and may bulk set the -corresponding variables. Use \\[cperl-set-style] to do this. Use -\\[cperl-set-style-back] to restore the memorized preexisting values -\(both available from menu). See examples in `cperl-style-examples'. +corresponding variables. Use \\[cperl-set-style] to do this or +set the `cperl-file-style' user option. Use +\\[cperl-set-style-back] to restore the memorized preexisting +values \(both available from menu). See examples in +`cperl-style-examples'. Part of the indentation style is how different parts of if/elsif/else statements are broken into lines; in CPerl, this is reflected on how @@ -1801,8 +1811,15 @@ or as help on variables `cperl-tips', `cperl-problems', (when (and cperl-pod-here-scan (not cperl-syntaxify-by-font-lock)) (cperl-find-pods-heres)) + (when cperl-file-style + (cperl-set-style cperl-file-style)) + (add-hook 'hack-local-variables-hook #'cperl--set-file-style nil t) ;; Setup Flymake (add-hook 'flymake-diagnostic-functions #'perl-flymake nil t)) + +(defun cperl--set-file-style () + (when cperl-file-style + (cperl-set-style cperl-file-style))) ;; Fix for perldb - make default reasonable (defun cperl-db () @@ -3840,7 +3857,7 @@ recursive calls in starting lines of here-documents." "\\<" cperl-sub-regexp "\\>" ; sub with proto/attr "\\(" cperl-white-and-comment-rex - (rx (group (eval cperl--normal-identifier-rx))) + (rx (opt (group (eval cperl--normal-identifier-rx)))) "\\)" "\\(" cperl-maybe-white-and-comment-rex @@ -5951,7 +5968,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))) @@ -6319,7 +6336,7 @@ else ) ("Current")) "List of variables to set to get a particular indentation style. -Should be used via `cperl-set-style' or via Perl menu. +Should be used via `cperl-set-style', `cperl-file-style' or via Perl menu. See examples in `cperl-style-examples'.") @@ -6365,7 +6382,8 @@ side-effect of memorizing only. Examples in `cperl-style-examples'." (eval '(mode-compile)))) ; Avoid a warning (declare-function Info-find-node "info" - (filename nodename &optional no-going-back strict-case)) + (filename nodename &optional no-going-back strict-case + noerror)) (defun cperl-info-buffer (type) ;; Return buffer with documentation. Creates if missing. @@ -7062,9 +7080,7 @@ One may build such TAGS files from CPerl mode menu." (error "No items found")) (setq update ;; (imenu-choose-buffer-index "Packages: " (nth 2 cperl-hierarchy)) - (if (if (fboundp 'display-popup-menus-p) - (display-popup-menus-p) - window-system) + (if (display-popup-menus-p) (x-popup-menu t (nth 2 cperl-hierarchy)) (require 'tmm) (tmm-prompt (nth 2 cperl-hierarchy)))) diff --git a/lisp/progmodes/cpp.el b/lisp/progmodes/cpp.el index 5cdcd7d32e3..f4584b63113 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 dacb2a5f011..16069f75aeb 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) @@ -4050,23 +4050,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) @@ -4087,17 +4091,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 101c323b132..77bf3f1ed18 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." @@ -239,6 +237,26 @@ Comments in the form will be lost." (if (bolp) (delete-char -1)) (indent-region start (point))))) +(defun elisp-mode-syntax-propertize (start end) + (goto-char start) + (let ((case-fold-search nil)) + (funcall + (syntax-propertize-rules + ;; Empty symbol. + ("##" (0 (unless (nth 8 (syntax-ppss)) + (string-to-syntax "_")))) + ;; Unicode character names. (The longest name is 88 characters + ;; long.) + ("\\?\\\\N{[-A-Za-z0-9 ]\\{,100\\}}" + (0 (unless (nth 8 (syntax-ppss)) + (string-to-syntax "_")))) + ((rx "#" (or (seq (group-n 1 "&" (+ digit)) ?\") ; Bool-vector. + (seq (group-n 1 "s") "(") ; Record. + (seq (group-n 1 (+ "^")) "["))) ; Char-table. + (1 (unless (save-excursion (nth 8 (syntax-ppss (match-beginning 0)))) + (string-to-syntax "'"))))) + start end))) + (defcustom emacs-lisp-mode-hook nil "Hook run when entering Emacs Lisp mode." :options '(eldoc-mode imenu-add-menubar-index checkdoc-minor-mode) @@ -270,10 +288,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 @@ -314,6 +330,7 @@ be used instead. #'elisp-eldoc-var-docstring nil t) (add-hook 'xref-backend-functions #'elisp--xref-backend nil t) (setq-local project-vc-external-roots-function #'elisp-load-path-roots) + (setq-local syntax-propertize-function #'elisp-mode-syntax-propertize) (add-hook 'completion-at-point-functions #'elisp-completion-at-point nil 'local) (add-hook 'flymake-diagnostic-functions #'elisp-flymake-checkdoc nil t) @@ -610,13 +627,13 @@ functions are annotated with \"<f>\" via the ;; t if in function position. (funpos (eq (char-before beg) ?\()) (quoted (elisp--form-quoted-p beg)) - (fun-sym (condition-case nil - (save-excursion - (up-list -1) - (forward-char 1) - (and (memq (char-syntax (char-after)) '(?w ?_)) - (read (current-buffer)))) - (error nil)))) + (is-ignore-error + (condition-case nil + (save-excursion + (up-list -1) + (forward-char 1) + (looking-at-p "ignore-error\\>")) + (error nil)))) (when (and end (or (not (nth 8 (syntax-ppss))) (memq (char-before beg) '(?` ?‘)))) (let ((table-etc @@ -625,7 +642,7 @@ functions are annotated with \"<f>\" via the ;; FIXME: We could look at the first element of ;; the current form and use it to provide a more ;; specific completion table in more cases. - ((eq fun-sym 'ignore-error) + (is-ignore-error (list t (elisp--completion-local-symbols) :predicate (lambda (sym) (get sym 'error-conditions)))) @@ -636,7 +653,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 +670,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 +686,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 +734,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,14 +765,19 @@ 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)) ;;; Xref backend -(declare-function xref-make "xref" (summary location)) -(declare-function xref-item-location "xref" (this)) +(declare-function xref-make "progmodes/xref" (summary location)) +(declare-function xref-item-location "progmodes/xref" (this)) (defun elisp--xref-backend () 'elisp) @@ -773,7 +800,7 @@ functions are annotated with \"<f>\" via the (defun elisp--xref-make-xref (type symbol file &optional summary) "Return an xref for TYPE SYMBOL in FILE. TYPE must be a type in `find-function-regexp-alist' (use nil for -'defun). If SUMMARY is non-nil, use it for the summary; +`defun'). If SUMMARY is non-nil, use it for the summary; otherwise build the summary from TYPE and SYMBOL." (xref-make (or summary (format elisp--xref-format (or type 'defun) symbol)) @@ -1190,16 +1217,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." @@ -1610,8 +1635,6 @@ Return the result of evaluation." ;; printing, not while evaluating. (defvar elisp--eval-defun-result) (let ((debug-on-error eval-expression-debug-on-error) - (print-length eval-expression-print-length) - (print-level eval-expression-print-level) elisp--eval-defun-result) (save-excursion ;; Arrange for eval-region to "read" the (possibly) altered form. @@ -1626,10 +1649,17 @@ Return the result of evaluation." (setq beg (point)) (setq form (funcall load-read-function (current-buffer))) (setq end (point))) - ;; Alter the form if necessary. - (let ((form (eval-sexp-add-defvars - (elisp--eval-defun-1 - (macroexpand form))))) + ;; Alter the form if necessary. We bind `print-level' (etc.) + ;; in the form itself, because we want evalling the form to + ;; use the original values, while we want the printing to use + ;; `eval-expression-print-length' (etc.). + (let ((form `(let ((print-level ,print-level) + (print-length ,print-length)) + ,(eval-sexp-add-defvars + (elisp--eval-defun-1 + (macroexpand form))))) + (print-length eval-expression-print-length) + (print-level eval-expression-print-level)) (eval-region beg end standard-output (lambda (_ignore) ;; Skipping to the end of the specified region @@ -1733,7 +1763,8 @@ Intended for `eldoc-documentation-functions' (which see)." (defun elisp-eldoc-var-docstring (callback &rest _ignored) "Document variable at point. -Intended for `eldoc-documentation-functions' (which see)." +Intended for `eldoc-documentation-functions' (which see). +Also see `elisp-eldoc-var-docstring-with-value'." (let* ((sym (elisp--current-symbol)) (docstring (and sym (elisp-get-var-docstring sym)))) (when docstring @@ -1741,6 +1772,33 @@ Intended for `eldoc-documentation-functions' (which see)." :thing sym :face 'font-lock-variable-name-face)))) +(defun elisp-eldoc-var-docstring-with-value (callback &rest _) + "Document variable at point. +Intended for `eldoc-documentation-functions' (which see). +Compared to `elisp-eldoc-var-docstring', this also includes the +current variable value and a bigger chunk of the docstring." + (when-let ((cs (elisp--current-symbol))) + (when (and (boundp cs) + ;; nil and t are boundp! + (not (null cs)) + (not (eq cs t))) + (funcall callback + (format "%.100S %s" + (symbol-value cs) + (let* ((doc (documentation-property + cs 'variable-documentation t)) + (more (- (length doc) 1000))) + (concat (propertize + (string-limit (if (string= doc "nil") + "Undocumented." + doc) + 1000) + 'face 'font-lock-doc-face) + (when (> more 0) + (format "[%sc more]" more))))) + :thing cs + :face 'font-lock-variable-name-face)))) + (defun elisp-get-fnsym-args-string (sym &optional index) "Return a string containing the parameter list of the function SYM. If SYM is a subr and no arglist is obtainable from the docstring @@ -2058,7 +2116,9 @@ current buffer state and calls REPORT-FN when done." (when (process-live-p elisp-flymake--byte-compile-process) (kill-process elisp-flymake--byte-compile-process))) (let ((temp-file (make-temp-file "elisp-flymake-byte-compile")) - (source-buffer (current-buffer))) + (source-buffer (current-buffer)) + (coding-system-for-write 'utf-8-unix) + (coding-system-for-read 'utf-8)) (save-restriction (widen) (write-region (point-min) (point-max) temp-file nil 'nomessage)) @@ -2079,7 +2139,7 @@ current buffer state and calls REPORT-FN when done." :connection-type 'pipe :sentinel (lambda (proc _event) - (when (eq (process-status proc) 'exit) + (unless (process-live-p proc) (unwind-protect (cond ((not (and (buffer-live-p source-buffer) @@ -2108,6 +2168,8 @@ Runs in a batch-mode Emacs. Interactively use variable (interactive (list buffer-file-name)) (let* ((file (or file (car command-line-args-left))) + (coding-system-for-read 'utf-8-unix) + (coding-system-for-write 'utf-8) (byte-compile-log-buffer (generate-new-buffer " *dummy-byte-compile-log-buffer*")) (byte-compile-dest-file-function #'ignore) diff --git a/lisp/progmodes/erts-mode.el b/lisp/progmodes/erts-mode.el new file mode 100644 index 00000000000..13da1d478d6 --- /dev/null +++ b/lisp/progmodes/erts-mode.el @@ -0,0 +1,223 @@ +;;; erts-mode.el --- major mode to edit erts files -*- lexical-binding: t; -*- + +;; Copyright (C) 2021-2022 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 specification values." + :group 'erts-mode) + +(defface erts-mode-start-test + '((t :inherit font-lock-keyword-face)) + "Face used for displaying specification test start markers." + :group 'erts-mode) + +(defface erts-mode-end-test + '((t :inherit font-lock-comment-face)) + "Face used for displaying specification test start markers." + :group 'erts-mode) + +(defvar-keymap erts-mode-map + :parent prog-mode-map + "C-c C-r" #'erts-tag-region + "C-c C-c" #'erts-run-test) + +(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 124817ffda4..7766694edff 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 @@ -1995,7 +1998,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/executable.el b/lisp/progmodes/executable.el index d7c093444ed..670b6e7e898 100644 --- a/lisp/progmodes/executable.el +++ b/lisp/progmodes/executable.el @@ -240,12 +240,13 @@ executable." (not (string= argument (buffer-substring (point) (match-end 1)))) (if (or (not executable-query) no-query-flag - (save-window-excursion - ;; Make buffer visible before question. - (switch-to-buffer (current-buffer)) - (y-or-n-p (format-message - "Replace magic number by `#!%s'? " - argument)))) + (save-match-data + (save-window-excursion + ;; Make buffer visible before question. + (switch-to-buffer (current-buffer)) + (y-or-n-p (format-message + "Replace magic number by `#!%s'? " + argument))))) (progn (replace-match argument t t nil 1) (message "Magic number changed to `#!%s'" argument)))) diff --git a/lisp/progmodes/f90.el b/lisp/progmodes/f90.el index 526865e6f61..dcd74f0369c 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'.") @@ -599,6 +600,7 @@ and variable-name parts, respectively." (append f90-font-lock-keywords-1 (list + '("\\(&\\)[ \t]*\\(!\\|$\\)" (1 font-lock-keyword-face)) ;; Variable declarations (avoid the real function call). ;; NB by accident (?), this correctly fontifies the "integer" in: ;; integer () function foo () @@ -610,8 +612,8 @@ and variable-name parts, respectively." '("^[ \t0-9]*\\(?:pure\\|elemental\\)?[ \t]*\ \\(real\\|integer\\|c\\(haracter\\|omplex\\)\\|\ enumerator\\|generic\\|procedure\\|logical\\|double[ \t]*precision\\)\ -\\(.*::\\|[ \t]*(.*)\\)?\\([^&!\n]*\\)" - (1 font-lock-type-face t) (4 font-lock-variable-name-face t)) +\\(.*::\\|[ \t]*(.*)\\)?\\([^&!\n]*\\(?:&\n[^&!\n]*\\)*\\)" + (1 font-lock-type-face t) (4 font-lock-variable-name-face append)) ;; Derived type/class variables. ;; TODO ? If we just highlighted the "type" part, rather than ;; "type(...)", this could be in the previous expression. And this @@ -646,18 +648,19 @@ 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)) '("\\_<\\(namelist\\|common\\)[ \t]*/\\(\\(?:\\sw\\|\\s_\\)+\\)?/" (1 font-lock-keyword-face) (2 font-lock-constant-face nil t)) "\\_<else\\([ \t]*if\\|where\\)?\\_>" - '("\\(&\\)[ \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) @@ -822,9 +825,7 @@ Can be overridden by the value of `font-lock-maximum-decoration'.") :style toggle :help "Expand abbreviations while typing in this buffer"] ["Add Imenu Menu" f90-add-imenu-menu :active (not (lookup-key (current-local-map) [menu-bar index])) - :included (fboundp 'imenu-add-to-menubar) - :help "Add an index menu to the menu-bar" - ])) + :help "Add an index menu to the menu-bar"])) map) "Keymap used in F90 mode.") diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el index 83d7bc8641c..0b7958e52fb 100644 --- a/lisp/progmodes/flymake.el +++ b/lisp/progmodes/flymake.el @@ -303,7 +303,7 @@ generated it." (defun flymake-error (text &rest args) "Format TEXT with ARGS and signal an error for Flymake." (let ((msg (apply #'format-message text args))) - (flymake-log :error msg) + (flymake-log :error "%s" msg) (error (concat "[Flymake] " msg)))) (cl-defstruct (flymake--diag @@ -1102,6 +1102,13 @@ The commands `flymake-goto-next-error' and `flymake-goto-prev-error' can be used to navigate among Flymake diagnostics annotated in the buffer. +By default, `flymake-mode' doesn't override the \\[next-error] command, but +if you're using Flymake a lot (and don't use the regular compilation +mechanisms that often), it can be useful to put something like +the following in your init file: + + (setq next-error-function \\='flymake-goto-next-error) + The visual appearance of each type of diagnostic can be changed by setting properties `flymake-overlay-control', `flymake-bitmap' and `flymake-severity' on the symbols of diagnostic types (like @@ -1358,6 +1365,11 @@ This is a suitable place for placing the `flymake-error-counter', Separating each of these with space is not necessary." :type '(repeat (choice string symbol))) +(defcustom flymake-mode-line-lighter "Flymake" + "The string to use in the Flymake mode line." + :type 'string + :version "29.1") + (defvar flymake-mode-line-title '(:eval (flymake--mode-line-title)) "Mode-line construct to show Flymake's mode name and menu.") @@ -1386,7 +1398,7 @@ correctly.") (defun flymake--mode-line-title () `(:propertize - "Flymake" + ,flymake-mode-line-lighter mouse-face mode-line-highlight help-echo ,(lambda (&rest _) @@ -1637,6 +1649,8 @@ buffer." (defun flymake-show-buffer-diagnostics () "Show a list of Flymake diagnostics for current buffer." (interactive) + (unless flymake-mode + (user-error "Flymake mode is not enabled in the current buffer")) (let* ((name (flymake--diagnostics-buffer-name)) (source (current-buffer)) (target (or (get-buffer name) diff --git a/lisp/progmodes/fortran.el b/lisp/progmodes/fortran.el index 86f0be7320e..786c5ae8042 100644 --- a/lisp/progmodes/fortran.el +++ b/lisp/progmodes/fortran.el @@ -2213,7 +2213,6 @@ arg DO-SPACE prevents stripping the whitespace." :style toggle :help "Expand abbreviations while typing in this buffer"] ["Add Imenu Menu" imenu-add-menubar-index :active (not (lookup-key (current-local-map) [menu-bar index])) - :included (fboundp 'imenu-add-to-menubar) :help "Add an index menu to the menu-bar"])) (provide 'fortran) diff --git a/lisp/progmodes/gdb-mi.el b/lisp/progmodes/gdb-mi.el index 66fc4b1a4ce..2319e638543 100644 --- a/lisp/progmodes/gdb-mi.el +++ b/lisp/progmodes/gdb-mi.el @@ -90,6 +90,7 @@ (require 'gud) (require 'cl-lib) (require 'cl-seq) +(require 'bindat) (eval-when-compile (require 'pcase)) (declare-function speedbar-change-initial-expansion-list @@ -104,6 +105,7 @@ ;; at toplevel, so the compiler doesn't know under which circumstances ;; they're defined. (declare-function gud-until "gud" (arg)) +(declare-function gud-go "gud" (arg)) (declare-function gud-print "gud" (arg)) (declare-function gud-down "gud" (arg)) (declare-function gud-up "gud" (arg)) @@ -283,8 +285,8 @@ Possible values are: :type '(choice (const :tag "Always restore" t) (const :tag "Don't restore" nil) - (const :tag "Depends on `gdb-show-main'" 'if-gdb-show-main) - (const :tag "Depends on `gdb-many-windows'" 'if-gdb-many-windows)) + (const :tag "Depends on `gdb-show-main'" if-gdb-show-main) + (const :tag "Depends on `gdb-many-windows'" if-gdb-many-windows)) :group 'gdb :version "28.1") @@ -954,12 +956,16 @@ detailed description of this mode. (forward-char 2) (gud-call "-exec-until *%a" arg))) "\C-u" "Continue to current line or address.") - ;; TODO Why arg here? (gud-def - gud-go (gud-call (if gdb-active-process - (gdb-gud-context-command "-exec-continue") - "-exec-run") arg) - nil "Start or continue execution.") + gud-go (progn + (when arg + (gud-call (concat "-exec-arguments " + (read-string "Arguments to exec-run: ")))) + (gud-call + (if gdb-active-process + (gdb-gud-context-command "-exec-continue") + "-exec-run"))) + "C-v" "Start or continue execution. Use a prefix to specify arguments.") ;; For debugging Emacs only. (gud-def gud-pp @@ -1138,7 +1144,8 @@ no input, and GDB is waiting for input." (setq name (nth 1 (split-string define "[( ]"))) (push (cons name define) gdb-define-alist)))) -(declare-function tooltip-show "tooltip" (text &optional use-echo-area)) +(declare-function tooltip-show "tooltip" (text &optional use-echo-area + text-face default-face)) (defconst gdb--string-regexp (rx "\"" (* (or (seq "\\" nonl) @@ -1266,7 +1273,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)) @@ -1580,7 +1587,7 @@ Buffer mode and name are selected according to buffer type. If buffer has trigger associated with it in `gdb-buffer-rules', this trigger is subscribed to `gdb-buf-publisher' and called with -'update argument." +`update' argument." (or (gdb-get-buffer buffer-type thread) (let ((rules (assoc buffer-type gdb-buffer-rules)) (new (generate-new-buffer "limbo"))) @@ -1612,6 +1619,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 +3020,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 +3041,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 +3065,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 +3484,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 +3500,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 +3556,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 +3725,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 +3754,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 +3824,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 +3849,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) @@ -4277,7 +4295,7 @@ member." ;; uses "-stack-list-locals --simple-values". Needs GDB 6.1 onwards. (def-gdb-trigger-and-handler gdb-invalidate-locals - (concat (gdb-current-context-command "-stack-list-locals") + (concat (gdb-current-context-command "-stack-list-variables") " --simple-values") gdb-locals-handler gdb-locals-handler-custom '(start update)) @@ -4288,6 +4306,48 @@ member." 'gdb-locals-mode 'gdb-invalidate-locals) + +;; Retrieve the values of all variables before invalidating locals. +(def-gdb-trigger-and-handler + gdb-locals-values + (concat (gdb-current-context-command "-stack-list-variables") + " --all-values") + gdb-locals-values-handler gdb-locals-values-handler-custom + '(start update)) + +(gdb-set-buffer-rules + 'gdb-locals-values-buffer + 'gdb-locals-values-buffer-name + 'gdb-locals-mode + 'gdb-locals-values) + +(defun gdb-locals-values-buffer-name () + (gdb-current-context-buffer-name + (concat "local values of " (gdb-get-target-string)))) + +(defcustom gdb-locals-simple-values-only nil + "Only display simple values in the Locals buffer." + :type 'boolean + :group 'gud + :version "29.1") + +(defcustom gdb-locals-value-limit 100 + "Maximum length the value of a local variable is allowed to be." + :type 'integer + :group 'gud + :version "29.1") + +(defvar gdb-locals-values-table (make-hash-table :test #'equal) + "Mapping of local variable names to a string with their value.") + +(defun gdb-locals-values-handler-custom () + "Store the values of local variables in `gdb-locals-value-map'." + (let ((locals-list (bindat-get-field (gdb-mi--partial-output) 'variables))) + (dolist (local locals-list) + (let ((name (bindat-get-field local 'name)) + (value (bindat-get-field local 'value))) + (puthash name value gdb-locals-values-table))))) + (defvar gdb-locals-watch-map (let ((map (make-sparse-keymap))) (suppress-keymap map) @@ -4304,6 +4364,15 @@ member." map) "Keymap to edit value of a simple data type local variable.") +(defun gdb-locals-value-filter (value) + "Filter function for the local variable VALUE." + (let* ((no-nl (replace-regexp-in-string "\n" " " value)) + (str (replace-regexp-in-string "[[:space:]]+" " " no-nl)) + (limit gdb-locals-value-limit)) + (if (>= (length str) limit) + (concat (substring str 0 limit) "...") + str))) + (defun gdb-edit-locals-value (&optional event) "Assign a value to a variable displayed in the locals buffer." (interactive (list last-input-event)) @@ -4316,17 +4385,22 @@ member." (gud-basic-call (concat "-gdb-set variable " var " = " value))))) -;; Don't display values of arrays or structures. -;; These can be expanded using gud-watch. +;; Complex data types are looked up in `gdb-locals-values-table'. (defun gdb-locals-handler-custom () - (let ((locals-list (gdb-mi--field (gdb-mi--partial-output) 'locals)) + "Handler to rebuild the local variables table buffer." + (let ((locals-list (bindat-get-field (gdb-mi--partial-output) 'variables)) (table (make-gdb-table))) (dolist (local locals-list) (let ((name (gdb-mi--field local 'name)) (value (gdb-mi--field local 'value)) (type (gdb-mi--field local 'type))) (when (not value) - (setq value "<complex data type>")) + (setq value + (if gdb-locals-simple-values-only + "<complex data type>" + (gethash name gdb-locals-values-table "<unavailable>")))) + (setq value (gdb-locals-value-filter value)) + (if (or (not value) (string-match "0x" value)) (add-text-properties 0 (length name) @@ -4849,6 +4923,8 @@ file\" where the GDB session starts (see `gdb-main-file')." (expand-file-name gdb-default-window-configuration-file gdb-window-configuration-directory))) ;; Create default layout as before. + ;; Make sure that local values are updated before locals. + (gdb-get-buffer-create 'gdb-locals-values-buffer) (gdb-get-buffer-create 'gdb-locals-buffer) (gdb-get-buffer-create 'gdb-stack-buffer) (gdb-get-buffer-create 'gdb-breakpoints-buffer) diff --git a/lisp/progmodes/grep.el b/lisp/progmodes/grep.el index bbcb644b73f..a8d743b87a8 100644 --- a/lisp/progmodes/grep.el +++ b/lisp/progmodes/grep.el @@ -48,8 +48,8 @@ to avoid computing them again.") "Set SYMBOL to VALUE, and update `grep-host-defaults-alist'. SYMBOL should be one of `grep-command', `grep-template', `grep-use-null-device', `grep-find-command' `grep-find-template', -`grep-find-use-xargs', `grep-use-null-filename-separator', or -`grep-highlight-matches'." +`grep-find-use-xargs', `grep-use-null-filename-separator', +`grep-highlight-matches', or `grep-quoting-style'." (when grep-host-defaults-alist (let* ((host-id (intern (or (file-remote-p default-directory) "localhost"))) @@ -202,6 +202,9 @@ by `grep-compute-defaults'; to change the default value, use :set #'grep-apply-setting :version "22.1") +(defvar grep-quoting-style nil + "Whether to use POSIX-like shell argument quoting.") + (defcustom grep-files-aliases '(("all" . "* .*") ("el" . "*.el") @@ -212,6 +215,7 @@ by `grep-compute-defaults'; to change the default value, use ("hh" . "*.hxx *.hpp *.[Hh] *.HH *.h++") ("h" . "*.h") ("l" . "[Cc]hange[Ll]og*") + ("am" . "Makefile.am GNUmakefile *.mk") ("m" . "[Mm]akefile*") ("tex" . "*.tex") ("texi" . "*.texi") @@ -269,16 +273,16 @@ See `compilation-error-screen-columns'." (defvar grep-mode-map (let ((map (make-sparse-keymap))) (set-keymap-parent map compilation-minor-mode-map) - (define-key map " " 'scroll-up-command) - (define-key map [?\S-\ ] 'scroll-down-command) - (define-key map "\^?" 'scroll-down-command) - (define-key map "\C-c\C-f" 'next-error-follow-minor-mode) - - (define-key map "\r" 'compile-goto-error) ;; ? - (define-key map "{" 'compilation-previous-file) - (define-key map "}" 'compilation-next-file) - (define-key map "\t" 'compilation-next-error) - (define-key map [backtab] 'compilation-previous-error) + (define-key map " " #'scroll-up-command) + (define-key map [?\S-\ ] #'scroll-down-command) + (define-key map "\^?" #'scroll-down-command) + (define-key map "\C-c\C-f" #'next-error-follow-minor-mode) + + (define-key map "\r" #'compile-goto-error) ;; ? + (define-key map "{" #'compilation-previous-file) + (define-key map "}" #'compilation-next-file) + (define-key map "\t" #'compilation-next-error) + (define-key map [backtab] #'compilation-previous-error) map) "Keymap for grep buffers. `compilation-minor-mode-map' is a cdr of this.") @@ -322,24 +326,24 @@ See `compilation-error-screen-columns'." ;; FIXME: Nowadays the last button is not "help" but "search"! (help (last tool-bar-map))) ;; Keep Help last in tool bar (tool-bar-local-item - "left-arrow" 'previous-error-no-select 'previous-error-no-select map + "left-arrow" #'previous-error-no-select #'previous-error-no-select map :rtl "right-arrow" :help "Goto previous match") (tool-bar-local-item - "right-arrow" 'next-error-no-select 'next-error-no-select map + "right-arrow" #'next-error-no-select #'next-error-no-select map :rtl "left-arrow" :help "Goto next match") (tool-bar-local-item - "cancel" 'kill-compilation 'kill-compilation map + "cancel" #'kill-compilation #'kill-compilation map :enable '(let ((buffer (compilation-find-buffer))) (get-buffer-process buffer)) :help "Stop grep") (tool-bar-local-item - "refresh" 'recompile 'recompile map + "refresh" #'recompile #'recompile map :help "Restart grep") (append map help)))) -(defalias 'kill-grep 'kill-compilation) +(defalias 'kill-grep #'kill-compilation) ;; override compilation-last-buffer (defvar grep-last-buffer nil @@ -443,9 +447,9 @@ buffer `default-directory'." (defvar grep-find-abbreviate-properties (let ((ellipsis (if (char-displayable-p ?…) "[…]" "[...]")) (map (make-sparse-keymap))) - (define-key map [down-mouse-2] 'mouse-set-point) - (define-key map [mouse-2] 'grep-find-toggle-abbreviation) - (define-key map "\C-m" 'grep-find-toggle-abbreviation) + (define-key map [down-mouse-2] #'mouse-set-point) + (define-key map [mouse-2] #'grep-find-toggle-abbreviation) + (define-key map "\C-m" #'grep-find-toggle-abbreviation) `(face nil display ,ellipsis mouse-face highlight help-echo "RET, mouse-2: show unabbreviated command" keymap ,map abbreviated-command t)) @@ -453,7 +457,7 @@ buffer `default-directory'." (defvar grep-mode-font-lock-keywords '(;; Command output lines. - (": \\(.+\\): \\(?:Permission denied\\|No such \\(?:file or directory\\|device or address\\)\\)$" + (": \\(.\\{,200\\}\\): \\(?:Permission denied\\|No such \\(?:file or directory\\|device or address\\)\\)$" 1 grep-error-face) ;; remove match from grep-regexp-alist before fontifying ("^Grep[/a-zA-Z]* started.*" @@ -616,8 +620,8 @@ This function is called from `compilation-filter-hook'." "Compute the defaults for the `grep' command. The value depends on `grep-command', `grep-template', `grep-use-null-device', `grep-find-command', `grep-find-template', -`grep-use-null-filename-separator', `grep-find-use-xargs' and -`grep-highlight-matches'." +`grep-use-null-filename-separator', `grep-find-use-xargs', +`grep-highlight-matches', and `grep-quoting-style'." ;; Keep default values. (unless grep-host-defaults-alist (add-to-list @@ -631,13 +635,14 @@ The value depends on `grep-command', `grep-template', (grep-use-null-filename-separator ,grep-use-null-filename-separator) (grep-find-use-xargs ,grep-find-use-xargs) - (grep-highlight-matches ,grep-highlight-matches))))) - (let* ((host-id - (intern (or (file-remote-p default-directory) "localhost"))) + (grep-highlight-matches ,grep-highlight-matches) + (grep-quoting-style ,grep-quoting-style))))) + (let* ((remote (file-remote-p default-directory)) + (host-id (intern (or remote "localhost"))) (host-defaults (assq host-id grep-host-defaults-alist)) (defaults (assq nil grep-host-defaults-alist)) - (quot-braces (shell-quote-argument "{}")) - (quot-scolon (shell-quote-argument ";"))) + (quot-braces (shell-quote-argument "{}" remote)) + (quot-scolon (shell-quote-argument ";" remote))) ;; There are different defaults on different hosts. They must be ;; computed for every host once. (dolist (setting '(grep-command grep-template @@ -791,8 +796,11 @@ The value depends on `grep-command', `grep-template', find-program gcmd null quot-braces)) (t (format "%s -H <D> <X> -type f <F> -print | \"%s\" %s" - find-program xargs-program gcmd)))))))) - ;; Save defaults for this host. + find-program xargs-program gcmd)))))) + + (setq grep-quoting-style (and remote 'posix)))) + + ;; Save defaults for this host. (setq grep-host-defaults-alist (delete (assq host-id grep-host-defaults-alist) grep-host-defaults-alist)) @@ -807,7 +815,8 @@ The value depends on `grep-command', `grep-template', (grep-use-null-filename-separator ,grep-use-null-filename-separator) (grep-find-use-xargs ,grep-find-use-xargs) - (grep-highlight-matches ,grep-highlight-matches)))))) + (grep-highlight-matches ,grep-highlight-matches) + (grep-quoting-style ,grep-quoting-style)))))) (defun grep-tag-default () (or (and transient-mark-mode mark-active @@ -820,7 +829,8 @@ The value depends on `grep-command', `grep-template', (defun grep-default-command () "Compute the default grep command for \\[universal-argument] \\[grep] to offer." - (let ((tag-default (shell-quote-argument (grep-tag-default))) + (let ((tag-default + (shell-quote-argument (grep-tag-default) grep-quoting-style)) ;; This a regexp to match single shell arguments. ;; Could someone please add comments explaining it? (sh-arg-re @@ -952,8 +962,7 @@ easily repeat a find command." (grep command-args)))) ;;;###autoload -(defalias 'find-grep 'grep-find) - +(defalias 'find-grep #'grep-find) ;; User-friendly interactive API. @@ -963,7 +972,7 @@ easily repeat a find command." ("<F>" . files) ("<N>" . (null-device)) ("<X>" . excl) - ("<R>" . (shell-quote-argument (or regexp "")))) + ("<R>" . (shell-quote-argument (or regexp "") grep-quoting-style))) "List of substitutions performed by `grep-expand-template'. If car of an element matches, the cdr is evalled in order to get the substitution string. @@ -1010,7 +1019,7 @@ these include `opts', `dir', `files', `null-device', `excl' and ;; Instead of a `grep-read-files-function' variable, we used to lookup ;; mode-specific functions in the major mode's symbol properties, so preserve ;; this behavior for backward compatibility. - (let ((old-function (get major-mode 'grep-read-files))) ;Obsolete since 28.1 + (let ((old-function (get major-mode #'grep-read-files))) ;Obsolete since 28.1 (if old-function (funcall old-function) (let ((file-name-at-point @@ -1057,11 +1066,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 @@ -1114,6 +1121,9 @@ command before it's run." (when (and (stringp regexp) (> (length regexp) 0)) (unless (and dir (file-accessible-directory-p dir)) (setq dir default-directory)) + (unless (string-equal (file-remote-p dir) (file-remote-p default-directory)) + (let ((default-directory dir)) + (grep-compute-defaults))) (let ((command regexp)) (if (null files) (if (string= command grep-command) @@ -1136,11 +1146,13 @@ command before it's run." (mapconcat (lambda (ignore) (cond ((stringp ignore) - (shell-quote-argument ignore)) + (shell-quote-argument + ignore grep-quoting-style)) ((consp ignore) (and (funcall (car ignore) dir) (shell-quote-argument - (cdr ignore)))))) + (cdr ignore) + grep-quoting-style))))) grep-find-ignored-files " --exclude="))) (and (eq grep-use-directories-skip t) @@ -1160,7 +1172,7 @@ command before it's run." (if (and grep-use-null-device null-device (null-device)) (concat command " " (null-device)) command) - 'grep-mode)) + #'grep-mode)) ;; Set default-directory if we started lgrep in the *grep* buffer. (if (eq next-error-last-buffer (current-buffer)) (setq default-directory dir)))))) @@ -1212,11 +1224,14 @@ command before it's run." (when (and (stringp regexp) (> (length regexp) 0)) (unless (and dir (file-accessible-directory-p dir)) (setq dir default-directory)) + (unless (string-equal (file-remote-p dir) (file-remote-p default-directory)) + (let ((default-directory dir)) + (grep-compute-defaults))) (if (null files) (if (not (string= regexp (if (consp grep-find-command) (car grep-find-command) grep-find-command))) - (compilation-start regexp 'grep-mode)) + (compilation-start regexp #'grep-mode)) (setq dir (file-name-as-directory (expand-file-name dir))) (let ((command (rgrep-default-command regexp files nil))) (when command @@ -1227,7 +1242,7 @@ command before it's run." (add-to-history 'grep-find-history command)) (grep--save-buffers) (let ((default-directory dir)) - (compilation-start command 'grep-mode)) + (compilation-start command #'grep-mode)) ;; Set default-directory if we started rgrep in the *grep* buffer. (if (eq next-error-last-buffer (current-buffer)) (setq default-directory dir))))))) @@ -1247,44 +1262,46 @@ command before it's run." (grep-expand-template grep-find-template regexp - (concat (shell-quote-argument "(") + (concat (shell-quote-argument "(" grep-quoting-style) " " find-name-arg " " (mapconcat - #'shell-quote-argument + (lambda (x) (shell-quote-argument x grep-quoting-style)) (split-string files) (concat " -o " find-name-arg " ")) " " - (shell-quote-argument ")")) + (shell-quote-argument ")" grep-quoting-style)) dir (concat (and grep-find-ignored-directories (concat "-type d " - (shell-quote-argument "(") + (shell-quote-argument "(" grep-quoting-style) ;; we should use shell-quote-argument here " -path " - (mapconcat (lambda (d) (shell-quote-argument (concat "*/" d))) - (rgrep-find-ignored-directories dir) - " -o -path ") + (mapconcat + (lambda (d) + (shell-quote-argument (concat "*/" d) grep-quoting-style)) + (rgrep-find-ignored-directories dir) + " -o -path ") " " - (shell-quote-argument ")") + (shell-quote-argument ")" grep-quoting-style) " -prune -o ")) (and grep-find-ignored-files - (concat (shell-quote-argument "!") " -type d " - (shell-quote-argument "(") + (concat (shell-quote-argument "!" grep-quoting-style) " -type d " + (shell-quote-argument "(" grep-quoting-style) ;; we should use shell-quote-argument here " -name " (mapconcat (lambda (ignore) (cond ((stringp ignore) - (shell-quote-argument ignore)) + (shell-quote-argument ignore grep-quoting-style)) ((consp ignore) (and (funcall (car ignore) dir) (shell-quote-argument - (cdr ignore)))))) + (cdr ignore) grep-quoting-style))))) grep-find-ignored-files " -o -name ") " " - (shell-quote-argument ")") + (shell-quote-argument ")" grep-quoting-style) " -prune -o "))))) (defun grep-find-toggle-abbreviation () @@ -1354,7 +1371,7 @@ The returned file name is relative." (caar (compilation--loc->file-struct loc)))) ;;;###autoload -(defalias 'rzgrep 'zrgrep) +(defalias 'rzgrep #'zrgrep) (provide 'grep) diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el index 085cd9b7e66..213ebef92f5 100644 --- a/lisp/progmodes/gud.el +++ b/lisp/progmodes/gud.el @@ -54,8 +54,8 @@ (declare-function gdb-tooltip-print-1 "gdb-mi" (expr)) (declare-function gud-pp "gdb-mi" (arg)) (declare-function gdb-var-delete "gdb-mi" ()) -(declare-function speedbar-toggle-line-expansion "gud" ()) -(declare-function speedbar-edit-line "gud" ()) +(declare-function speedbar-toggle-line-expansion "speedbar" ()) +(declare-function speedbar-edit-line "speedbar" ()) ;; FIXME: The declares below are necessary because we don't call `gud-def' ;; at toplevel, so the compiler doesn't know under which circumstances ;; they're defined. @@ -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 @@ -742,10 +744,10 @@ The option \"--fullname\" must be included in this value." output)) -(easy-mmode-defmap gud-minibuffer-local-map - '(("\C-i" . comint-dynamic-complete-filename)) - "Keymap for minibuffer prompting of gud startup command." - :inherit minibuffer-local-map) +(defvar-keymap gud-minibuffer-local-map + :doc "Keymap for minibuffer prompting of gud startup command." + :parent minibuffer-local-map + "C-i" #'comint-dynamic-complete-filename) (defun gud-query-cmdline (minor-mode &optional init) (let* ((hist-sym (gud-symbol 'history nil minor-mode)) @@ -757,13 +759,18 @@ The option \"--fullname\" must be included in this value." (concat (or cmd-name (symbol-name minor-mode)) " " (or init - (let ((file nil)) - (dolist (f (directory-files default-directory) file) - (if (and (file-executable-p f) - (not (file-directory-p f)) - (or (not file) - (file-newer-than-file-p f file))) - (setq file f))))))) + (let ((file nil) + (files (directory-files default-directory))) + ;; On remote systems, this may be slow, so avoid it. + (when (or (not (file-remote-p default-directory)) + (length< files 50)) + (dolist (f files) + (if (and (file-executable-p f) + (not (file-directory-p f)) + (or (not file) + (file-newer-than-file-p f file))) + (setq file f))) + file))))) gud-minibuffer-local-map nil hist-sym))) @@ -867,7 +874,8 @@ the buffer in which this command was invoked." COMMAND is the prefix for which we seek completion. CONTEXT is the text before COMMAND on the line." (let* ((complete-list - (gud-gdb-run-command-fetch-lines (concat "complete " context command) + (gud-gdb-run-command-fetch-lines (concat "server complete " + context command) (current-buffer) ;; From string-match above. (length context)))) @@ -3539,8 +3547,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 68b085d42f4..ba2c5737480 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/icon.el b/lisp/progmodes/icon.el index e1ee9efc54b..ec281f3a496 100644 --- a/lisp/progmodes/icon.el +++ b/lisp/progmodes/icon.el @@ -31,17 +31,16 @@ "Abbrev table in use in Icon-mode buffers.") (define-abbrev-table 'icon-mode-abbrev-table ()) -(defvar icon-mode-map - (let ((map (make-sparse-keymap "Icon"))) - (define-key map "{" 'electric-icon-brace) - (define-key map "}" 'electric-icon-brace) - (define-key map "\e\C-h" 'mark-icon-function) - (define-key map "\e\C-a" 'beginning-of-icon-defun) - (define-key map "\e\C-e" 'end-of-icon-defun) - (define-key map "\e\C-q" 'indent-icon-exp) - (define-key map "\177" 'backward-delete-char-untabify) - map) - "Keymap used in Icon mode.") +(defvar-keymap icon-mode-map + :doc "Keymap used in Icon mode." + :name "Icon" + "{" #'electric-icon-brace + "}" #'electric-icon-brace + "C-M-h" #'mark-icon-function + "C-M-a" #'beginning-of-icon-defun + "C-M-e" #'end-of-icon-defun + "C-M-q" #'indent-icon-exp + "DEL" #'backward-delete-char-untabify) (easy-menu-define icon-mode-menu icon-mode-map "Menu for Icon mode." diff --git a/lisp/progmodes/idlw-shell.el b/lisp/progmodes/idlw-shell.el index af09cab1258..b6063521365 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/idlwave.el b/lisp/progmodes/idlwave.el index e3985db64ab..edb53793e64 100644 --- a/lisp/progmodes/idlwave.el +++ b/lisp/progmodes/idlwave.el @@ -1353,7 +1353,7 @@ the leftover unidentified statements containing an equal sign.") ;; Note that this is documented in the v18 manuals as being a string ;; of length one rather than a single character. ;; The code in this file accepts either format for compatibility. -(defvar idlwave-comment-indent-char ?\ +(defvar idlwave-comment-indent-char ?\s "Character to be inserted for IDL comment indentation. Normally a space.") diff --git a/lisp/progmodes/inf-lisp.el b/lisp/progmodes/inf-lisp.el index c952e449810..b9042e66c6b 100644 --- a/lisp/progmodes/inf-lisp.el +++ b/lisp/progmodes/inf-lisp.el @@ -308,7 +308,7 @@ quoted using shell quote syntax. "inferior-lisp" (car cmdlist) nil (cdr cmdlist))) (inferior-lisp-mode))) (setq inferior-lisp-buffer "*inferior-lisp*") - (pop-to-buffer-same-window "*inferior-lisp*")) + (pop-to-buffer "*inferior-lisp*" display-comint-buffer-action)) ;;;###autoload (defalias 'run-lisp 'inferior-lisp) diff --git a/lisp/progmodes/js.el b/lisp/progmodes/js.el index 812b3b98e3c..eb2a1e4fccc 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. @@ -667,24 +660,11 @@ This variable is like `sgml-attribute-offset'." :type 'integer :safe 'integerp) -;;; KeyMap - -(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'.") +;;; Keymap + +(defvar-keymap js-mode-map + :doc "Keymap for `js-mode'." + "M-." #'js-find-symbol) ;;; Syntax table and parsing @@ -932,9 +912,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 +951,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 +1231,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 +1242,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 +3296,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 +3304,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 +3316,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/m4-mode.el b/lisp/progmodes/m4-mode.el index b9fcd033bbb..a18c8bcce44 100644 --- a/lisp/progmodes/m4-mode.el +++ b/lisp/progmodes/m4-mode.el @@ -121,13 +121,11 @@ If m4 is not in your PATH, set this to an absolute file name." ("#" (0 (when (m4--quoted-p (match-beginning 0)) (string-to-syntax ".")))))) -(defvar m4-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\C-c\C-b" 'm4-m4-buffer) - (define-key map "\C-c\C-r" 'm4-m4-region) - (define-key map "\C-c\C-c" 'comment-region) - map) - "Keymap for M4 Mode.") +(defvar-keymap m4-mode-map + :doc "Keymap for M4 Mode." + "C-c C-b" #'m4-m4-buffer + "C-c C-r" #'m4-m4-region + "C-c C-c" #'comment-region) (easy-menu-define m4-mode-menu m4-mode-map "Menu for M4 Mode." diff --git a/lisp/progmodes/make-mode.el b/lisp/progmodes/make-mode.el index 9f08f39e1c0..91307f6c09f 100644 --- a/lisp/progmodes/make-mode.el +++ b/lisp/progmodes/make-mode.el @@ -542,8 +542,8 @@ not be enclosed in { } or ( )." This should identify a `make' command that can handle the `-q' option." :type 'string) -(defvaralias 'makefile-query-one-target-method - 'makefile-query-one-target-method-function) +(define-obsolete-variable-alias 'makefile-query-one-target-method + 'makefile-query-one-target-method-function "29.1") (defcustom makefile-query-one-target-method-function 'makefile-query-by-make-minus-q diff --git a/lisp/progmodes/mixal-mode.el b/lisp/progmodes/mixal-mode.el index 97a218fcfa3..9d1ceaa55a8 100644 --- a/lisp/progmodes/mixal-mode.el +++ b/lisp/progmodes/mixal-mode.el @@ -78,16 +78,13 @@ ;;; Code: (defvar compile-command) -;;; Key map -(defvar mixal-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\C-c\C-c" 'compile) - (define-key map "\C-c\C-r" 'mixal-run) - (define-key map "\C-c\C-d" 'mixal-debug) - (define-key map "\C-h\C-o" 'mixal-describe-operation-code) - map) - "Keymap for `mixal-mode'.") -;; (makunbound 'mixal-mode-map) +;;; Keymap +(defvar-keymap mixal-mode-map + :doc "Keymap for `mixal-mode'." + "C-c C-c" #'compile + "C-c C-r" #'mixal-run + "C-c C-d" #'mixal-debug + "C-h C-o" #'mixal-describe-operation-code) ;;; Syntax table (defvar mixal-mode-syntax-table diff --git a/lisp/progmodes/octave.el b/lisp/progmodes/octave.el index a45909537ad..7b7c675873b 100644 --- a/lisp/progmodes/octave.el +++ b/lisp/progmodes/octave.el @@ -879,7 +879,8 @@ startup file, `~/.emacs-octave'." (set-process-filter proc 'comint-output-filter) ;; Just in case, to be sure a cd in the startup file won't have ;; detrimental effects. - (with-demoted-errors (inferior-octave-resync-dirs)) + (with-demoted-errors "Octave resync error: %S" + (inferior-octave-resync-dirs)) ;; Generate a proper prompt, which is critical to ;; `comint-history-isearch-backward-regexp'. Bug#14433. (comint-send-string proc "\n"))) @@ -1814,18 +1815,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 +1841,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 422ee9bb6bd..351ea6e3a99 100644 --- a/lisp/progmodes/pascal.el +++ b/lisp/progmodes/pascal.el @@ -47,8 +47,8 @@ ;; "reset" "rewrite" "write" "writeln") ;; pascal-separator-keywords '("downto" "else" "mod" "div" "then")) -;; KNOWN BUGS / BUGREPORTS -;; ======================= +;; KNOWN BUGS / BUG REPORTS +;; ======================== ;; As far as I know, there are no bugs in the current version of this ;; package. This may not be true however, since I never use this mode ;; myself and therefore would never notice them anyway. If you do @@ -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))) @@ -1384,8 +1382,6 @@ The default is a name found in the buffer around point." ;;; (defvar pascal-outline-map (let ((map (make-sparse-keymap))) - (if (fboundp 'set-keymap-name) - (set-keymap-name map 'pascal-outline-map)) (define-key map "\M-\C-a" 'pascal-outline-prev-defun) (define-key map "\M-\C-e" 'pascal-outline-next-defun) (define-key map "\C-c\C-d" 'pascal-outline-goto-defun) diff --git a/lisp/progmodes/perl-mode.el b/lisp/progmodes/perl-mode.el index 6f468192a90..92b47ce88f6 100644 --- a/lisp/progmodes/perl-mode.el +++ b/lisp/progmodes/perl-mode.el @@ -191,7 +191,9 @@ ,(concat "\\<" (regexp-opt '("if" "until" "while" "elsif" "else" "unless" "do" "dump" "for" "foreach" "exit" "die" - "BEGIN" "END" "return" "exec" "eval") t) + "BEGIN" "END" "return" "exec" "eval" + "when" "given" "default") + t) "\\>") ;; ;; Fontify declarators and prefixes as types. @@ -212,7 +214,7 @@ (eval-and-compile (defconst perl--syntax-exp-intro-keywords - '("split" "if" "unless" "until" "while" "print" + '("split" "if" "unless" "until" "while" "print" "printf" "grep" "map" "not" "or" "and" "for" "foreach" "return")) (defconst perl--syntax-exp-intro-regexp diff --git a/lisp/progmodes/prog-mode.el b/lisp/progmodes/prog-mode.el index 20685354890..7738de6a745 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 07093d61474..859ad2e047b 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2015-2022 Free Software Foundation, Inc. ;; Version: 0.8.1 -;; Package-Requires: ((emacs "26.1") (xref "1.0.2")) +;; Package-Requires: ((emacs "26.1") (xref "1.4.0")) ;; This is a GNU ELPA :core package. Avoid using functionality that ;; not compatible with the version of Emacs recorded above. @@ -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))) @@ -374,6 +382,12 @@ you might have to restart Emacs to see the effect." :package-version '(project . "0.2.0") :safe #'booleanp) +(defcustom project-vc-include-untracked t + "When non-nil, the VC project backend includes untracked files." + :type 'boolean + :version "29.1" + :safe #'booleanp) + ;; FIXME: Using the current approach, major modes are supposed to set ;; this variable to a buffer-local value. So we don't have access to ;; the "external roots" of language A from buffers of language B, which @@ -410,30 +424,33 @@ The directory names should be absolute. Used in the VC project backend implementation of `project-external-roots'.") (defun project-try-vc (dir) - (let* ((backend - ;; FIXME: This is slow. Cache it. - (ignore-errors (vc-responsible-backend dir))) - (root - (pcase backend - ('Git - ;; Don't stop at submodule boundary. - ;; FIXME: Cache for a shorter time. - (or (vc-file-getprop dir 'project-git-root) - (let ((root (vc-call-backend backend 'root dir))) - (vc-file-setprop - dir 'project-git-root - (if (and - ;; FIXME: Invalidate the cache when the value - ;; of this variable changes. - (project--vc-merge-submodules-p root) - (project--submodule-p root)) - (let* ((parent (file-name-directory - (directory-file-name root)))) - (vc-call-backend backend 'root parent)) - root))))) - ('nil nil) - (_ (ignore-errors (vc-call-backend backend 'root dir)))))) - (and root (cons 'vc root)))) + (or (vc-file-getprop dir 'project-vc) + (let* ((backend (ignore-errors (vc-responsible-backend dir))) + (root + (pcase backend + ('Git + ;; Don't stop at submodule boundary. + (or (vc-file-getprop dir 'project-git-root) + (let ((root (vc-call-backend backend 'root dir))) + (vc-file-setprop + dir 'project-git-root + (if (and + ;; FIXME: Invalidate the cache when the value + ;; of this variable changes. + (project--vc-merge-submodules-p root) + (project--submodule-p root)) + (let* ((parent (file-name-directory + (directory-file-name root)))) + (vc-call-backend backend 'root parent)) + root))))) + ('nil nil) + (_ (ignore-errors (vc-call-backend backend 'root dir))))) + project) + (when root + (setq project (list 'vc backend root)) + ;; FIXME: Cache for a shorter time. + (vc-file-setprop dir 'project-vc project) + project)))) (defun project--submodule-p (root) ;; XXX: We only support Git submodules for now. @@ -459,7 +476,7 @@ backend implementation of `project-external-roots'.") (t nil)))) (cl-defmethod project-root ((project (head vc))) - (cdr project)) + (nth 2 project)) (cl-defmethod project-external-roots ((project (head vc))) (project-subtract-directories @@ -474,8 +491,8 @@ backend implementation of `project-external-roots'.") (lambda (dir) (let ((ignores (project--value-in-dir 'project-vc-ignores dir)) backend) - (if (and (file-equal-p dir (cdr project)) - (setq backend (vc-responsible-backend dir)) + (if (and (file-equal-p dir (nth 2 project)) + (setq backend (cadr project)) (cond ((eq backend 'Hg)) ((and (eq backend 'Git) @@ -501,8 +518,9 @@ backend implementation of `project-external-roots'.") (args '("-z")) (vc-git-use-literal-pathspecs nil) files) - ;; Include unregistered. - (setq args (append args '("-c" "-o" "--exclude-standard"))) + (setq args (append args + '("-c" "--exclude-standard") + (and project-vc-include-untracked '("-o")))) (when extra-ignores (setq args (append args (cons "--" @@ -554,9 +572,9 @@ backend implementation of `project-external-roots'.") (delete-consecutive-dups files))) (`Hg (let ((default-directory (expand-file-name (file-name-as-directory dir))) - args) - ;; Include unregistered. - (setq args (nconc args '("-mcardu" "--no-status" "-0"))) + (args (list (concat "-mcard" (and project-vc-include-untracked "u")) + "--no-status" + "-0"))) (when extra-ignores (setq args (nconc args (mapcan @@ -587,11 +605,11 @@ backend implementation of `project-external-roots'.") (file-missing nil))) (cl-defmethod project-ignores ((project (head vc)) dir) - (let* ((root (cdr project)) + (let* ((root (nth 2 project)) backend) (append (when (file-equal-p dir root) - (setq backend (vc-responsible-backend root)) + (setq backend (cadr project)) (delq nil (mapcar @@ -768,7 +786,6 @@ The following commands are available: (define-key tab-prefix-map "p" #'project-other-tab-command)) (declare-function grep-read-files "grep") -(declare-function xref--show-xrefs "xref") (declare-function xref--find-ignores-arguments "xref") ;;;###autoload @@ -794,7 +811,7 @@ requires quoting, e.g. `\\[quoted-insert]<space>'." (project--files-in-directory dir nil (grep-read-files regexp)))))) - (xref--show-xrefs + (xref-show-xrefs (apply-partially #'project--find-regexp-in-files regexp files) nil))) @@ -822,7 +839,7 @@ pattern to search for." (project-files pr (cons (project-root pr) (project-external-roots pr))))) - (xref--show-xrefs + (xref-show-xrefs (apply-partially #'project--find-regexp-in-files regexp files) nil))) @@ -842,28 +859,40 @@ 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))) + (root (project-root pr)) + (dirs (list root))) + (project-find-file-in + (or (thing-at-point 'filename) + (and buffer-file-name (file-relative-name buffer-file-name root))) + 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. @@ -916,15 +945,28 @@ 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 + "Find file" all-files nil 'file-name-history suggested-filename))) (if (string= file "") (user-error "You didn't specify the file") @@ -961,7 +1003,7 @@ is used as part of \"future history\"." "Dired" ;; Some completion UIs show duplicates. (delete-dups all-dirs) - nil nil))) + nil 'file-name-history))) (dired dir))) ;;;###autoload @@ -976,6 +1018,8 @@ is used as part of \"future history\"." (interactive) (vc-dir (project-root (project-current t)))) +(declare-function comint-check-proc "comint") + ;;;###autoload (defun project-shell () "Start an inferior shell in the current project's root directory. @@ -984,11 +1028,14 @@ switch to it. Otherwise, create a new shell buffer. With \\[universal-argument] prefix arg, create a new inferior shell buffer even if one already exists." (interactive) + (require 'comint) (let* ((default-directory (project-root (project-current t))) (default-project-shell-name (project-prefixed-buffer-name "shell")) (shell-buffer (get-buffer default-project-shell-name))) (if (and shell-buffer (not current-prefix-arg)) - (pop-to-buffer-same-window shell-buffer) + (if (comint-check-proc shell-buffer) + (pop-to-buffer shell-buffer (bound-and-true-p display-comint-buffer-action)) + (shell shell-buffer)) (shell (generate-new-buffer-name default-project-shell-name))))) ;;;###autoload @@ -1004,7 +1051,7 @@ if one already exists." (eshell-buffer-name (project-prefixed-buffer-name "eshell")) (eshell-buffer (get-buffer eshell-buffer-name))) (if (and eshell-buffer (not current-prefix-arg)) - (pop-to-buffer-same-window eshell-buffer) + (pop-to-buffer eshell-buffer (bound-and-true-p display-comint-buffer-action)) (eshell t)))) ;;;###autoload @@ -1047,11 +1094,17 @@ type \\[help-command] at that time. If you exit the `query-replace', you can later continue the `query-replace' loop using the command \\[fileloop-continue]." (interactive - (pcase-let ((`(,from ,to) - (query-replace-read-args "Query replace (regexp)" t t))) - (list from to))) + (let ((query-replace-read-from-regexp-default 'find-tag-default-as-regexp)) + (pcase-let ((`(,from ,to) + (query-replace-read-args "Query replace (regexp)" t t))) + (list from to)))) (fileloop-initialize-replace - from to (project-files (project-current t)) 'default) + from to + ;; XXX: Filter out Git submodules, which are not regular files. + ;; `project-files' can return those, which is arguably suboptimal, + ;; but removing them eagerly has performance cost. + (cl-delete-if-not #'file-regular-p (project-files (project-current t))) + 'default) (fileloop-continue)) (defvar compilation-read-command) @@ -1087,6 +1140,29 @@ If non-nil, it overrides `compilation-buffer-name-function' for compilation-buffer-name-function))) (call-interactively #'compile))) +(defcustom project-ignore-buffer-conditions nil + "List of conditions to filter the buffers to be switched to. +If any of these conditions are satisfied for a buffer in the +current project, `project-switch-to-buffer', +`project-display-buffer' and `project-display-buffer-other-frame' +ignore it. +See the doc string of `project-kill-buffer-conditions' for the +general form of conditions." + :type '(repeat (choice regexp function symbol + (cons :tag "Major mode" + (const major-mode) symbol) + (cons :tag "Derived mode" + (const derived-mode) symbol) + (cons :tag "Negation" + (const not) sexp) + (cons :tag "Conjunction" + (const and) sexp) + (cons :tag "Disjunction" + (const or) sexp))) + :version "29.1" + :group 'project + :package-version '(project . "0.8.2")) + (defun project--read-project-buffer () (let* ((pr (project-current t)) (current-buffer (current-buffer)) @@ -1096,7 +1172,10 @@ If non-nil, it overrides `compilation-buffer-name-function' for (predicate (lambda (buffer) ;; BUFFER is an entry (BUF-NAME . BUF-OBJ) of Vbuffer_alist. - (memq (cdr buffer) buffers)))) + (and (memq (cdr buffer) buffers) + (not + (project--buffer-check + (cdr buffer) project-ignore-buffer-conditions)))))) (read-buffer "Switch to buffer: " (when (funcall predicate (cons other-name other-buffer)) @@ -1142,15 +1221,22 @@ displayed." (display-buffer-other-frame buffer-or-name)) (defcustom project-kill-buffer-conditions - '(buffer-file-name ; All file-visiting buffers are included. + `(buffer-file-name ; All file-visiting buffers are included. ;; Most of the temp buffers in the background: - (major-mode . fundamental-mode) + ,(lambda (buf) + (not (eq (buffer-local-value 'major-mode buf) + 'fundamental-mode))) ;; non-text buffer such as xref, occur, vc, log, ... - (and (derived-mode . special-mode) - (not (major-mode . help-mode))) - (derived-mode . compilation-mode) - (derived-mode . dired-mode) - (derived-mode . diff-mode)) + (and (major-mode . special-mode) + ,(lambda (buf) + (not (eq (buffer-local-value 'major-mode buf) + 'help-mode)))) + (major-mode . compilation-mode) + (major-mode . dired-mode) + (major-mode . diff-mode) + (major-mode . comint-mode) + (major-mode . eshell-mode) + (major-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: @@ -1160,10 +1246,11 @@ Each condition is either: - a cons-cell, where the car describes how to interpret the cdr. The car can be one of the following: * `major-mode': the buffer is killed if the buffer's major - mode is eq to the cons-cell's cdr - * `derived-mode': the buffer is killed if the buffer's major mode is derived from the major mode denoted by the cons-cell's - cdr + cdr. + * `derived-mode': the buffer is killed if the buffer's major + mode is eq to the cons-cell's cdr (this is deprecated and will + result in a warning if used). * `not': the cdr is interpreted as a negation of a condition. * `and': the cdr is a list of recursive conditions, that all have to be met. @@ -1183,9 +1270,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." @@ -1202,34 +1298,38 @@ current project, it will be killed." (push buf bufs))) (nreverse bufs))) -(defun project--kill-buffer-check (buf conditions) +(defun project--buffer-check (buf conditions) "Check if buffer BUF matches any element of the list CONDITIONS. -See `project-kill-buffer-conditions' for more details on the form -of CONDITIONS." - (catch 'kill +See `project-kill-buffer-conditions' or +`project-ignore-buffer-conditions' for more details on the +form of CONDITIONS." + (catch 'match (dolist (c conditions) (when (cond ((stringp c) (string-match-p c (buffer-name buf))) ((symbolp c) (funcall c buf)) - ((eq (car-safe c) 'major-mode) - (eq (buffer-local-value 'major-mode buf) - (cdr c))) ((eq (car-safe c) 'derived-mode) + (warn "The use of `derived-mode' in \ +`project--buffer-check' is deprecated.") + (provided-mode-derived-p + (buffer-local-value 'major-mode buf) + (cdr c))) + ((eq (car-safe c) 'major-mode) (provided-mode-derived-p (buffer-local-value 'major-mode buf) (cdr c))) ((eq (car-safe c) 'not) - (not (project--kill-buffer-check buf (cdr c)))) + (not (project--buffer-check buf (cdr c)))) ((eq (car-safe c) 'or) - (project--kill-buffer-check buf (cdr c))) + (project--buffer-check buf (cdr c))) ((eq (car-safe c) 'and) (seq-every-p - (apply-partially #'project--kill-buffer-check + (apply-partially #'project--buffer-check buf) (mapcar #'list (cdr c))))) - (throw 'kill t))))) + (throw 'match t))))) (defun project--buffers-to-kill (pr) "Return list of buffers in project PR to kill. @@ -1237,7 +1337,7 @@ What buffers should or should not be killed is described in `project-kill-buffer-conditions'." (let (bufs) (dolist (buf (project-buffers pr)) - (when (project--kill-buffer-check buf project-kill-buffer-conditions) + (when (project--buffer-check buf project-kill-buffer-conditions) (push buf bufs))) bufs)) @@ -1250,17 +1350,40 @@ identical. Only the buffers that match a condition in `project-kill-buffer-conditions' will be killed. If NO-CONFIRM is non-nil, the command will not ask the user for confirmation. NO-CONFIRM is always nil when the command is invoked -interactively." +interactively. + +Also see the `project-kill-buffers-display-buffer-list' variable." (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 6bc7ee408d5..8382c4bd099 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 f7f1784b172..c2483436fe9 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 @@ -92,7 +92,7 @@ ;; Operating Systems' pipe buffering (e.g. CPython 3.3.4 in Windows 7. ;; See URL `https://debbugs.gnu.org/cgi/bugreport.cgi?bug=17304'). To ;; avoid this, the `python-shell-unbuffered' defaults to non-nil and -;; controls whether `python-shell-calculate-process-environment' +;; controls whether `python-shell--calculate-process-environment' ;; should set the "PYTHONUNBUFFERED" environment variable on startup: ;; See URL `https://docs.python.org/3/using/cmdline.html#cmdoption-u'. @@ -149,7 +149,7 @@ ;; (setq python-shell-process-environment ;; (list ;; (format "PATH=%s" (mapconcat -;; 'identity +;; #'identity ;; (reverse ;; (cons (getenv "PATH") ;; '("/path/to/env/bin/"))) @@ -245,7 +245,7 @@ (require 'ansi-color) (require 'cl-lib) (require 'comint) -(require 'tramp-sh) +(eval-when-compile (require 'subr-x)) ;For `string-empty-p'. ;; Avoid compiler warnings (defvar view-return-to-alist) @@ -273,39 +273,39 @@ (defvar python-mode-map (let ((map (make-sparse-keymap))) ;; Movement - (define-key map [remap backward-sentence] 'python-nav-backward-block) - (define-key map [remap forward-sentence] 'python-nav-forward-block) - (define-key map [remap backward-up-list] 'python-nav-backward-up-list) - (define-key map [remap mark-defun] 'python-mark-defun) - (define-key map "\C-c\C-j" 'imenu) + (define-key map [remap backward-sentence] #'python-nav-backward-block) + (define-key map [remap forward-sentence] #'python-nav-forward-block) + (define-key map [remap backward-up-list] #'python-nav-backward-up-list) + (define-key map [remap mark-defun] #'python-mark-defun) + (define-key map "\C-c\C-j" #'imenu) ;; Indent specific - (define-key map "\177" 'python-indent-dedent-line-backspace) - (define-key map (kbd "<backtab>") 'python-indent-dedent-line) - (define-key map "\C-c<" 'python-indent-shift-left) - (define-key map "\C-c>" 'python-indent-shift-right) + (define-key map "\177" #'python-indent-dedent-line-backspace) + (define-key map (kbd "<backtab>") #'python-indent-dedent-line) + (define-key map "\C-c<" #'python-indent-shift-left) + (define-key map "\C-c>" #'python-indent-shift-right) ;; Skeletons - (define-key map "\C-c\C-tc" 'python-skeleton-class) - (define-key map "\C-c\C-td" 'python-skeleton-def) - (define-key map "\C-c\C-tf" 'python-skeleton-for) - (define-key map "\C-c\C-ti" 'python-skeleton-if) - (define-key map "\C-c\C-tm" 'python-skeleton-import) - (define-key map "\C-c\C-tt" 'python-skeleton-try) - (define-key map "\C-c\C-tw" 'python-skeleton-while) + (define-key map "\C-c\C-tc" #'python-skeleton-class) + (define-key map "\C-c\C-td" #'python-skeleton-def) + (define-key map "\C-c\C-tf" #'python-skeleton-for) + (define-key map "\C-c\C-ti" #'python-skeleton-if) + (define-key map "\C-c\C-tm" #'python-skeleton-import) + (define-key map "\C-c\C-tt" #'python-skeleton-try) + (define-key map "\C-c\C-tw" #'python-skeleton-while) ;; Shell interaction - (define-key map "\C-c\C-p" 'run-python) - (define-key map "\C-c\C-s" 'python-shell-send-string) - (define-key map "\C-c\C-e" 'python-shell-send-statement) - (define-key map "\C-c\C-r" 'python-shell-send-region) - (define-key map "\C-\M-x" 'python-shell-send-defun) - (define-key map "\C-c\C-c" 'python-shell-send-buffer) - (define-key map "\C-c\C-l" 'python-shell-send-file) - (define-key map "\C-c\C-z" 'python-shell-switch-to-shell) + (define-key map "\C-c\C-p" #'run-python) + (define-key map "\C-c\C-s" #'python-shell-send-string) + (define-key map "\C-c\C-e" #'python-shell-send-statement) + (define-key map "\C-c\C-r" #'python-shell-send-region) + (define-key map "\C-\M-x" #'python-shell-send-defun) + (define-key map "\C-c\C-c" #'python-shell-send-buffer) + (define-key map "\C-c\C-l" #'python-shell-send-file) + (define-key map "\C-c\C-z" #'python-shell-switch-to-shell) ;; Some util commands - (define-key map "\C-c\C-v" 'python-check) - (define-key map "\C-c\C-f" 'python-eldoc-at-point) - (define-key map "\C-c\C-d" 'python-describe-at-point) + (define-key map "\C-c\C-v" #'python-check) + (define-key map "\C-c\C-f" #'python-eldoc-at-point) + (define-key map "\C-c\C-d" #'python-describe-at-point) ;; Utilities - (substitute-key-definition 'complete-symbol 'completion-at-point + (substitute-key-definition #'complete-symbol #'completion-at-point map global-map) (easy-menu-define python-menu map "Python Mode menu" '("Python" @@ -359,9 +359,12 @@ (defmacro python-rx (&rest regexps) "Python mode specialized rx macro. This variant of `rx' supports common Python named REGEXPS." - `(rx-let ((block-start (seq symbol-start + `(rx-let ((sp-bsnl (or space (and ?\\ ?\n))) + (block-start (seq symbol-start (or "def" "class" "if" "elif" "else" "try" "except" "finally" "for" "while" "with" + ;; Python 3.10+ PEP634 + "match" "case" ;; Python 3.5+ PEP492 (and "async" (+ space) (or "def" "for" "with"))) @@ -394,7 +397,7 @@ This variant of `rx' supports common Python named REGEXPS." (open-paren (or "{" "[" "(")) (close-paren (or "}" "]" ")")) (simple-operator (any ?+ ?- ?/ ?& ?^ ?~ ?| ?* ?< ?> ?= ?%)) - (not-simple-operator (not simple-operator)) + (not-simple-operator (not (or simple-operator ?\n))) (operator (or "==" ">=" "is" "not" "**" "//" "<<" ">>" "<=" "!=" "+" "-" "/" "&" "^" "~" "|" "*" "<" ">" @@ -538,9 +541,9 @@ the {...} holes that appear within f-strings." (setq ppss (syntax-ppss)))))) (defvar python-font-lock-keywords-level-1 - `((,(rx symbol-start "def" (1+ space) (group (1+ (or word ?_)))) + `((,(python-rx symbol-start "def" (1+ space) (group symbol-name)) (1 font-lock-function-name-face)) - (,(rx symbol-start "class" (1+ space) (group (1+ (or word ?_)))) + (,(python-rx symbol-start "class" (1+ space) (group symbol-name)) (1 font-lock-type-face))) "Font lock keywords to use in `python-mode' for level 1 decoration. @@ -563,6 +566,8 @@ class declarations.") ;; Python 3.5+ PEP492 (and "async" (+ space) (or "def" "for" "with")) "await" + ;; Python 3.10+ + "match" "case" ;; Extra: "self") symbol-end) @@ -601,15 +606,18 @@ builtins.") (defun python-font-lock-assignment-matcher (regexp) "Font lock matcher for assignments based on REGEXP. -Return nil if REGEXP matched within a `paren' context (to avoid, -e.g., default values for arguments or passing arguments by name -being treated as assignments) or is followed by an '=' sign (to -avoid '==' being treated as an assignment." +Search for next occurrence if REGEXP matched within a `paren' +context (to avoid, e.g., default values for arguments or passing +arguments by name being treated as assignments) or is followed by +an '=' sign (to avoid '==' being treated as an assignment. Set +point to the position one character before the end of the +occurrence found so that subsequent searches can detect the '=' +sign in chained assignment." (lambda (limit) - (let ((res (re-search-forward regexp limit t))) - (unless (or (python-syntax-context 'paren) - (equal (char-after (point)) ?=)) - res)))) + (cl-loop while (re-search-forward regexp limit t) + unless (or (python-syntax-context 'paren) + (equal (char-after) ?=)) + return (progn (backward-char) t)))) (defvar python-font-lock-keywords-maximum-decoration `((python--font-lock-f-strings) @@ -671,7 +679,7 @@ avoid '==' being treated as an assignment." ;; and variants thereof ;; the cases ;; (a) = 5 - ;; [a] = 5 + ;; [a] = 5, ;; [*a] = 5, 6 ;; are handled separately below (,(python-font-lock-assignment-matcher @@ -701,10 +709,11 @@ avoid '==' being treated as an assignment." (1 font-lock-variable-name-face)) ;; special cases ;; (a) = 5 - ;; [a] = 5 + ;; [a] = 5, ;; [*a] = 5, 6 (,(python-font-lock-assignment-matcher - (python-rx (or "[" "(") (* space) + (python-rx (or line-start ?\; ?=) (* space) + (or "[" "(") (* space) grouped-assignment-target (* space) (or ")" "]") (* space) assignment-operator)) @@ -825,7 +834,6 @@ It makes underscores and dots word constituent chars.") (defcustom python-indent-offset 4 "Default indentation offset for Python." - :group 'python :type 'integer :safe 'integerp) @@ -835,21 +843,18 @@ It makes underscores and dots word constituent chars.") (defcustom python-indent-guess-indent-offset t "Non-nil tells Python mode to guess `python-indent-offset' value." :type 'boolean - :group 'python :safe 'booleanp) (defcustom python-indent-guess-indent-offset-verbose t "Non-nil means to emit a warning when indentation guessing fails." :version "25.1" :type 'boolean - :group 'python :safe' booleanp) (defcustom python-indent-trigger-commands '(indent-for-tab-command yas-expand yas/expand) "Commands that might trigger a `python-indent-line' call." - :type '(repeat symbol) - :group 'python) + :type '(repeat symbol)) (defcustom python-indent-def-block-scale 2 "Multiplier applied to indentation inside multi-line def blocks." @@ -1298,7 +1303,7 @@ Called from a program, START and END specify the region to indent." ;; Don't mess with strings, unless it's the ;; enclosing set of quotes or a docstring. (or (not (python-syntax-context 'string)) - (eq + (equal (syntax-after (+ (1- (point)) (current-indentation) @@ -1427,8 +1432,15 @@ 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)) + (python-rx line-start (* space) defun (+ sp-bsnl) (group symbol-name)) "Regexp matching class or function definition. The name of the defun should be grouped so it can be retrieved via `match-string'.") @@ -1518,7 +1530,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. @@ -2018,7 +2033,6 @@ position, else returns nil." (defcustom python-shell-buffer-name "Python" "Default buffer name for Python interpreter." :type 'string - :group 'python :safe 'stringp) (defcustom python-shell-interpreter @@ -2032,19 +2046,16 @@ Some Python interpreters also require changes to `python-shell-interpreter' to \"ipython3\" requires setting `python-shell-interpreter-args' to \"--simple-prompt\"." :version "28.1" - :type 'string - :group 'python) + :type 'string) (defcustom python-shell-internal-buffer-name "Python Internal" "Default buffer name for the Internal Python interpreter." :type 'string - :group 'python :safe 'stringp) (defcustom python-shell-interpreter-args "-i" "Default arguments for the Python interpreter." - :type 'string - :group 'python) + :type 'string) (defcustom python-shell-interpreter-interactive-arg "-i" "Interpreter argument to force it to run interactively." @@ -2109,7 +2120,6 @@ It should not contain a caret (^) at the beginning." "Should syntax highlighting be enabled in the Python shell buffer? Restart the Python shell after changing this variable for it to take effect." :type 'boolean - :group 'python :safe 'booleanp) (defcustom python-shell-unbuffered t @@ -2117,7 +2127,6 @@ Restart the Python shell after changing this variable for it to take effect." When non-nil, this may prevent delayed and missing output in the Python shell. See commentary for details." :type 'boolean - :group 'python :safe 'booleanp) (defcustom python-shell-process-environment nil @@ -2127,8 +2136,7 @@ When this variable is non-nil, values are exported into the process environment before starting it. Any variables already present in the current environment are superseded by variables set here." - :type '(repeat string) - :group 'python) + :type '(repeat string)) (defcustom python-shell-extra-pythonpaths nil "List of extra pythonpaths for Python shell. @@ -2137,8 +2145,7 @@ the PYTHONPATH before starting processes. Any values present here that already exists in PYTHONPATH are moved to the beginning of the list so that they are prioritized when looking for modules." - :type '(repeat string) - :group 'python) + :type '(repeat string)) (defcustom python-shell-exec-path nil "List of paths for searching executables. @@ -2146,8 +2153,7 @@ When this variable is non-nil, values added at the beginning of the PATH before starting processes. Any values present here that already exists in PATH are moved to the beginning of the list so that they are prioritized when looking for executables." - :type '(repeat string) - :group 'python) + :type '(repeat string)) (defcustom python-shell-remote-exec-path nil "List of paths to be ensured remotely for searching executables. @@ -2158,8 +2164,7 @@ here. Normally you won't use this variable directly unless you plan to ensure a particular set of paths to all Python shell executed through tramp connections." :version "25.1" - :type '(repeat string) - :group 'python) + :type '(repeat string)) (define-obsolete-variable-alias 'python-shell-virtualenv-path 'python-shell-virtualenv-root "25.1") @@ -2169,13 +2174,11 @@ executed through tramp connections." This variable, when set to a string, makes the environment to be modified such that shells are started within the specified virtualenv." - :type '(choice (const nil) directory) - :group 'python) + :type '(choice (const nil) directory)) (defcustom python-shell-setup-codes nil "List of code run by `python-shell-send-setup-code'." - :type '(repeat symbol) - :group 'python) + :type '(repeat symbol)) (defcustom python-shell-compilation-regexp-alist `((,(rx line-start (1+ (any " \t")) "File \"" @@ -2189,8 +2192,7 @@ virtualenv." "(" (group (1+ digit)) ")" (1+ (not (any "("))) "()") 1 2)) "`compilation-error-regexp-alist' for inferior Python." - :type '(alist regexp) - :group 'python) + :type '(alist regexp)) (defvar python-shell-output-filter-in-progress nil) (defvar python-shell-output-filter-buffer nil) @@ -2208,33 +2210,34 @@ virtualenv." (or (getenv "PYTHONPATH") "") path-separator 'omit))) (python-shell--add-to-path-with-priority pythonpath python-shell-extra-pythonpaths) - (mapconcat 'identity pythonpath path-separator))) + (mapconcat #'identity pythonpath path-separator))) (defun python-shell-calculate-process-environment () - "Calculate `process-environment' or `tramp-remote-process-environment'. + (declare (obsolete python-shell--calculate-process-environment "29.1")) + (defvar tramp-remote-process-environment) + (let* ((remote-p (file-remote-p default-directory))) + (append (python-shell--calculate-process-environment) + (if remote-p + tramp-remote-process-environment + process-environment)))) + +(defun python-shell--calculate-process-environment () + "Return a list of entries to add to the `process-environment'. Prepends `python-shell-process-environment', sets extra pythonpaths from `python-shell-extra-pythonpaths' and sets a few -virtualenv related vars. If `default-directory' points to a -remote host, the returned value is intended for -`tramp-remote-process-environment'." - (let* ((remote-p (file-remote-p default-directory)) - (process-environment (if remote-p - tramp-remote-process-environment - process-environment)) - (virtualenv (when python-shell-virtualenv-root - (directory-file-name python-shell-virtualenv-root)))) - (dolist (env python-shell-process-environment) - (pcase-let ((`(,key ,value) (split-string env "="))) - (setenv key value))) +virtualenv related vars." + (let* ((virtualenv (when python-shell-virtualenv-root + (directory-file-name python-shell-virtualenv-root))) + (res python-shell-process-environment)) (when python-shell-unbuffered - (setenv "PYTHONUNBUFFERED" "1")) + (push "PYTHONUNBUFFERED=1" res)) (when python-shell-extra-pythonpaths - (setenv "PYTHONPATH" (python-shell-calculate-pythonpath))) + (push (concat "PYTHONPATH=" (python-shell-calculate-pythonpath)) res)) (if (not virtualenv) - process-environment - (setenv "PYTHONHOME" nil) - (setenv "VIRTUAL_ENV" virtualenv)) - process-environment)) + nil + (push "PYTHONHOME" res) + (push (concat "VIRTUAL_ENV=" virtualenv) res)) + res)) (defun python-shell-calculate-exec-path () "Calculate `exec-path'. @@ -2262,14 +2265,26 @@ of `exec-path'." (defun python-shell-tramp-refresh-remote-path (vec paths) "Update VEC's remote-path giving PATHS priority." + (cl-assert (featurep 'tramp)) + (declare-function tramp-set-remote-path "tramp-sh") + (declare-function tramp-set-connection-property "tramp-cache") + (declare-function tramp-get-connection-property "tramp-cache") (let ((remote-path (tramp-get-connection-property vec "remote-path" nil))) (when remote-path + ;; FIXME: This part of the Tramp code still knows about Python! (python-shell--add-to-path-with-priority remote-path paths) (tramp-set-connection-property vec "remote-path" remote-path) (tramp-set-remote-path vec)))) + (defun python-shell-tramp-refresh-process-environment (vec env) "Update VEC's process environment with ENV." + (cl-assert (featurep 'tramp)) + (defvar tramp-end-of-heredoc) + (defvar tramp-end-of-output) + ;; Do we even know that `tramp-sh' is loaded at this point? + ;; What about files accessed via FTP, sudo, ...? + (declare-function tramp-send-command "tramp-sh") ;; Stolen from `tramp-open-connection-setup-interactive-shell'. (let ((env (append (when (fboundp 'tramp-get-remote-locale) ;; Emacs<24.4 compat. @@ -2282,7 +2297,7 @@ of `exec-path'." unset vars item) (while env (setq item (split-string (car env) "=" 'omit)) - (setcdr item (mapconcat 'identity (cdr item) "=")) + (setcdr item (mapconcat #'identity (cdr item) "=")) (if (and (stringp (cdr item)) (not (string-equal (cdr item) ""))) (push (format "%s %s" (car item) (cdr item)) vars) (push (car item) unset)) @@ -2292,12 +2307,12 @@ of `exec-path'." vec (format "while read var val; do export $var=$val; done <<'%s'\n%s\n%s" tramp-end-of-heredoc - (mapconcat 'identity vars "\n") + (mapconcat #'identity vars "\n") tramp-end-of-heredoc) t)) (when unset (tramp-send-command - vec (format "unset %s" (mapconcat 'identity unset " ")) t)))) + vec (format "unset %s" (mapconcat #'identity unset " ")) t)))) (defmacro python-shell-with-environment (&rest body) "Modify shell environment during execution of BODY. @@ -2306,41 +2321,49 @@ execution of body. If `default-directory' points to a remote machine then modifies `tramp-remote-process-environment' and `python-shell-remote-exec-path' instead." (declare (indent 0) (debug (body))) - (let ((vec (make-symbol "vec"))) - `(progn - (let* ((,vec - (when (file-remote-p default-directory) - (ignore-errors - (tramp-dissect-file-name default-directory 'noexpand)))) - (process-environment - (if ,vec - process-environment - (python-shell-calculate-process-environment))) - (exec-path - (if ,vec - exec-path - (python-shell-calculate-exec-path))) - (tramp-remote-process-environment - (if ,vec - (python-shell-calculate-process-environment) - tramp-remote-process-environment))) - (when (tramp-get-connection-process ,vec) - ;; For already existing connections, the new exec path must - ;; be re-set, otherwise it won't take effect. One example - ;; of such case is when remote dir-locals are read and - ;; *then* subprocesses are triggered within the same - ;; connection. - (python-shell-tramp-refresh-remote-path - ,vec (python-shell-calculate-exec-path)) - ;; The `tramp-remote-process-environment' variable is only - ;; effective when the started process is an interactive - ;; shell, otherwise (like in the case of processes started - ;; with `process-file') the environment is not changed. - ;; This makes environment modifications effective - ;; unconditionally. - (python-shell-tramp-refresh-process-environment - ,vec tramp-remote-process-environment)) - ,(macroexp-progn body))))) + `(python-shell--with-environment + (python-shell--calculate-process-environment) + (lambda () ,@body))) + +(defun python-shell--with-environment (extraenv bodyfun) + ;; FIXME: This is where the generic code delegates to Tramp. + (let* ((vec + (and (file-remote-p default-directory) + (fboundp 'tramp-dissect-file-name) + (ignore-errors + (tramp-dissect-file-name default-directory 'noexpand))))) + (if vec + (python-shell--tramp-with-environment vec extraenv bodyfun) + (let ((process-environment + (append extraenv process-environment)) + (exec-path + ;; FIXME: This is still Python-specific. + (python-shell-calculate-exec-path))) + (funcall bodyfun))))) + +(defun python-shell--tramp-with-environment (vec extraenv bodyfun) + (defvar tramp-remote-process-environment) + (declare-function tramp-get-connection-process "tramp" (vec)) + (let* ((tramp-remote-process-environment + (append extraenv tramp-remote-process-environment))) + (when (tramp-get-connection-process vec) + ;; For already existing connections, the new exec path must + ;; be re-set, otherwise it won't take effect. One example + ;; of such case is when remote dir-locals are read and + ;; *then* subprocesses are triggered within the same + ;; connection. + (python-shell-tramp-refresh-remote-path + ;; FIXME: This is still Python-specific. + vec (python-shell-calculate-exec-path)) + ;; The `tramp-remote-process-environment' variable is only + ;; effective when the started process is an interactive + ;; shell, otherwise (like in the case of processes started + ;; with `process-file') the environment is not changed. + ;; This makes environment modifications effective + ;; unconditionally. + (python-shell-tramp-refresh-process-environment + vec tramp-remote-process-environment)) + (funcall bodyfun))) (defvar python-shell--prompt-calculated-input-regexp nil "Calculated input prompt regexp for inferior python shell. @@ -2623,12 +2646,13 @@ banner and the initial prompt are received separately." (define-obsolete-function-alias 'python-comint-output-filter-function - 'ansi-color-filter-apply + #'ansi-color-filter-apply "25.1") (defun python-comint-postoutput-scroll-to-bottom (output) "Faster version of `comint-postoutput-scroll-to-bottom'. Avoids `recenter' calls until OUTPUT is completely sent." + (declare (obsolete nil "29.1")) ; Not used. (when (and (not (string= "" output)) (python-shell-comint-end-of-output-p (ansi-color-filter-apply output))) @@ -2721,20 +2745,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. @@ -2816,8 +2832,7 @@ current process to not hang while waiting. This is useful to safely attach setup code for long-running processes that eventually provide a shell." :version "25.1" - :type 'hook - :group 'python) + :type 'hook) (defconst python-shell-eval-setup-code "\ @@ -2943,15 +2958,15 @@ variable. (setq-local comint-output-filter-functions '(ansi-color-process-output python-shell-comint-watch-for-first-prompt-output-filter - python-comint-postoutput-scroll-to-bottom comint-watch-for-password-prompt)) (setq-local comint-highlight-input nil) (setq-local compilation-error-regexp-alist python-shell-compilation-regexp-alist) + (setq-local scroll-conservatively 1) (add-hook 'completion-at-point-functions #'python-shell-completion-at-point nil 'local) (define-key inferior-python-mode-map "\t" - 'python-shell-completion-complete-or-indent) + #'python-shell-completion-complete-or-indent) (make-local-variable 'python-shell-internal-last-output) (when python-shell-font-lock-enable (python-shell-font-lock-turn-on)) @@ -2977,7 +2992,8 @@ killed." (let* ((cmdlist (split-string-and-unquote cmd)) (interpreter (car cmdlist)) (args (cdr cmdlist)) - (buffer (apply #'make-comint-in-buffer proc-name proc-buffer-name + (buffer (apply #'make-comint-in-buffer proc-name + proc-buffer-name interpreter nil args)) (python-shell--parent-buffer (current-buffer)) (process (get-buffer-process buffer)) @@ -3126,7 +3142,7 @@ there for compatibility with CEDET.") (run-python-internal)))) (define-obsolete-function-alias - 'python-proc 'python-shell-internal-get-or-create-process "24.3") + 'python-proc #'python-shell-internal-get-or-create-process "24.3") (defun python-shell--save-temp-file (string) (let* ((temporary-file-directory @@ -3211,11 +3227,13 @@ detecting a prompt at the end of the buffer." (defun python-shell-send-string-no-output (string &optional process) "Send STRING to PROCESS and inhibit output. Return the output." - (let ((process (or process (python-shell-get-process-or-error))) - (comint-preoutput-filter-functions - '(python-shell-output-filter)) - (python-shell-output-filter-in-progress t) - (inhibit-quit t)) + (or process (setq process (python-shell-get-process-or-error))) + (cl-letf (((process-filter process) + (lambda (_proc str) + (with-current-buffer (process-buffer process) + (python-shell-output-filter str)))) + (python-shell-output-filter-in-progress t) + (inhibit-quit t)) (or (with-local-quit (python-shell-send-string string process) @@ -3243,10 +3261,10 @@ Returns the output. See `python-shell-send-string-no-output'." (python-shell-internal-get-or-create-process)))) (define-obsolete-function-alias - 'python-send-receive 'python-shell-internal-send-string "24.3") + 'python-send-receive #'python-shell-internal-send-string "24.3") (define-obsolete-function-alias - 'python-send-string 'python-shell-internal-send-string "24.3") + 'python-send-string #'python-shell-internal-send-string "24.3") (defun python-shell-buffer-substring (start end &optional nomain no-cookie) "Send buffer substring from START to END formatted for shell. @@ -3281,22 +3299,25 @@ the python shell: (goto-char start) (python-util-forward-comment 1) (current-indentation)))) - (fillstr (and (not no-cookie) - (not starts-at-point-min-p) - (concat - (format "# -*- coding: %s -*-\n" encoding) - (make-string - ;; Subtract 2 because of the coding cookie. - (- (line-number-at-pos start) 2) ?\n))))) + (fillstr (cond (starts-at-point-min-p + nil) + ((not no-cookie) + (concat + (format "# -*- coding: %s -*-\n" encoding) + (make-string + ;; Subtract 2 because of the coding cookie. + (- (line-number-at-pos start) 2) ?\n))) + (t + (make-string (- (line-number-at-pos start) 1) ?\n))))) (with-temp-buffer (python-mode) (when fillstr (insert fillstr)) - (insert substring) - (goto-char (point-min)) (when (not toplevel-p) - (insert "if True:") + (forward-line -1) + (insert "if True:\n") (delete-region (point) (line-end-position))) + (insert substring) (when nomain (let* ((if-name-main-start-end (and nomain @@ -3542,8 +3563,7 @@ def __PYTHON_EL_get_completions(text): completer.print_mode = True return completions" "Code used to setup completion in inferior Python processes." - :type 'string - :group 'python) + :type 'string) (define-obsolete-variable-alias 'python-shell-completion-module-string-code @@ -3760,7 +3780,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 () @@ -3807,7 +3828,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 @@ -3815,7 +3836,8 @@ With argument MSG show activation/deactivation message." ;; in use based on its args and uses `apply-partially' ;; to make it up for the 3 args case. (if (= (length - (help-function-arglist 'comint-redirect-filter)) 3) + (help-function-arglist 'comint-redirect-filter)) + 3) (set-process-filter process (apply-partially #'comint-redirect-filter original-filter-fn)) @@ -3924,7 +3946,7 @@ using that one instead of current buffer's process." (define-obsolete-function-alias 'python-shell-completion-complete-at-point - 'python-shell-completion-at-point + #'python-shell-completion-at-point "25.1") (defun python-shell-completion-complete-or-indent () @@ -3953,7 +3975,6 @@ considered over. The overlay arrow will be removed from the currently tracked buffer. Additionally, if `python-pdbtrack-kill-buffers' is non-nil, all files opened by pdbtracking will be killed." :type 'boolean - :group 'python :safe 'booleanp) (defcustom python-pdbtrack-stacktrace-info-regexp @@ -4162,7 +4183,7 @@ inferior Python process is updated properly." (define-obsolete-function-alias 'python-completion-complete-at-point - 'python-completion-at-point + #'python-completion-at-point "25.1") @@ -4172,29 +4193,25 @@ inferior Python process is updated properly." "Function to fill comments. This is the function used by `python-fill-paragraph' to fill comments." - :type 'symbol - :group 'python) + :type 'symbol) (defcustom python-fill-string-function 'python-fill-string "Function to fill strings. This is the function used by `python-fill-paragraph' to fill strings." - :type 'symbol - :group 'python) + :type 'symbol) (defcustom python-fill-decorator-function 'python-fill-decorator "Function to fill decorators. This is the function used by `python-fill-paragraph' to fill decorators." - :type 'symbol - :group 'python) + :type 'symbol) (defcustom python-fill-paren-function 'python-fill-paren "Function to fill parens. This is the function used by `python-fill-paragraph' to fill parens." - :type 'symbol - :group 'python) + :type 'symbol) (defcustom python-fill-docstring-style 'pep-257 "Style used to fill docstrings. @@ -4264,7 +4281,6 @@ value may result in one of the following docstring styles: (const :tag "PEP-257 with 2 newlines at end of string." pep-257) (const :tag "PEP-257 with 1 newline at end of string." pep-257-nn) (const :tag "Symmetric style." symmetric)) - :group 'python :safe (lambda (val) (memq val '(django onetwo pep-257 pep-257-nn symmetric nil)))) @@ -4423,7 +4439,6 @@ JUSTIFY should be used (if applicable) as in `fill-paragraph'." This happens when pressing \"if<SPACE>\", for example, to prompt for the if condition." :type 'boolean - :group 'python :safe 'booleanp) (defvar python-skeleton-available '() @@ -4548,7 +4563,7 @@ The skeleton will be bound to python-skeleton-NAME." (defun python-skeleton-add-menu-items () "Add menu items to Python->Skeletons menu." - (let ((skeletons (sort python-skeleton-available 'string<))) + (let ((skeletons (sort python-skeleton-available #'string<))) (dolist (skeleton skeletons) (easy-menu-add-item nil '("Python" "Skeletons") @@ -4578,8 +4593,7 @@ def __FFAP_get_module_path(objstr): except: return ''" "Python code to get a module path." - :type 'string - :group 'python) + :type 'string) (defun python-ffap-module-path (module) "Function for `ffap-alist' to return path for MODULE." @@ -4607,14 +4621,12 @@ def __FFAP_get_module_path(objstr): (executable-find "epylint") "install pyflakes, pylint or something else") "Command used to check a Python file." - :type 'string - :group 'python) + :type 'string) (defcustom python-check-buffer-name "*Python check: %s*" "Buffer name used for check commands." - :type 'string - :group 'python) + :type 'string) (defvar python-check-custom-command nil "Internal use.") @@ -4667,7 +4679,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 @@ -4678,8 +4693,7 @@ See `python-check-command' for the default." doc = '' return doc" "Python code to setup documentation retrieval." - :type 'string - :group 'python) + :type 'string) (defun python-eldoc--get-symbol-at-point () "Get the current symbol for eldoc. @@ -4726,14 +4740,13 @@ Set to nil by `python-eldoc-function' if (defcustom python-eldoc-function-timeout 1 "Timeout for `python-eldoc-function' in seconds." - :group 'python :type 'integer :version "25.1") (defcustom python-eldoc-function-timeout-permanent t - "Non-nil means that when `python-eldoc-function' times out -`python-eldoc-get-doc' will be set to nil." - :group 'python + "If non-nil, a timeout in Python-Eldoc will disable it permanently. +Python-Eldoc can be re-enabled manually by setting `python-eldoc-get-doc' +back to t in the affected buffer." :type 'boolean :version "25.1") @@ -4766,10 +4779,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) @@ -4921,7 +4938,7 @@ To this: (\"decorator.wrapped_f\" . 393))" ;; Inspired by imenu--flatten-index-alist removed in revno 21853. (apply - 'nconc + #'nconc (mapcar (lambda (item) (let ((name (if prefix @@ -5004,7 +5021,7 @@ since it returns nil if point is not inside a defun." (and (= (current-indentation) 0) (throw 'exit t)))) (and names (concat (and type (format "%s " type)) - (mapconcat 'identity names "."))))))) + (mapconcat #'identity names "."))))))) (defun python-info-current-symbol (&optional replace-self) "Return current symbol using dotty syntax. @@ -5025,9 +5042,10 @@ parent defun name." (replace-regexp-in-string (python-rx line-start word-start "self" word-end ?.) (concat - (mapconcat 'identity + (mapconcat #'identity (butlast (split-string current-defun "\\.")) - ".") ".") + ".") + ".") name))))))) (defun python-info-statement-starts-block-p () @@ -5069,7 +5087,7 @@ parent defun name." (define-obsolete-function-alias 'python-info-closing-block - 'python-info-dedenter-opening-block-position "24.4") + #'python-info-dedenter-opening-block-position "24.4") (defun python-info-dedenter-opening-block-position () "Return the point of the closest block the current line closes. @@ -5114,7 +5132,8 @@ likely an invalid python file." (let ((indentation (current-indentation))) (when (and (not (memq indentation collected-indentations)) (or (not collected-indentations) - (< indentation (apply #'min collected-indentations))) + (< indentation + (apply #'min collected-indentations))) ;; There must be no line with indentation ;; smaller than `indentation' (except for ;; blank lines) between the found opening @@ -5142,7 +5161,7 @@ likely an invalid python file." (define-obsolete-function-alias 'python-info-closing-block-message - 'python-info-dedenter-opening-block-message "24.4") + #'python-info-dedenter-opening-block-message "24.4") (defun python-info-dedenter-opening-block-message () "Message the first line of the block the current statement closes." @@ -5444,10 +5463,12 @@ allowed files." (let ((dir-name (file-name-as-directory dir))) (apply #'nconc (mapcar (lambda (file-name) - (let ((full-file-name (expand-file-name file-name dir-name))) + (let ((full-file-name + (expand-file-name file-name dir-name))) (when (and (not (member file-name '("." ".."))) - (funcall (or predicate #'identity) full-file-name)) + (funcall (or predicate #'identity) + full-file-name)) (list full-file-name)))) (directory-files dir-name))))) @@ -5515,7 +5536,6 @@ required arguments. Once launched it will receive the Python source to be checked as its standard input. To use `flake8' you would set this to (\"flake8\" \"-\")." :version "26.1" - :group 'python-flymake :type '(repeat string)) ;; The default regexp accommodates for older pyflakes, which did not @@ -5537,7 +5557,6 @@ If COLUMN or TYPE are nil or that index didn't match, that information is not present on the matched line and a default will be used." :version "26.1" - :group 'python-flymake :type '(list regexp (integer :tag "Line's index") (choice @@ -5562,19 +5581,9 @@ configuration could be: By default messages are considered errors." :version "26.1" - :group 'python-flymake :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" - :group 'python - :group 'python-flymake - :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/ruby-mode.el b/lisp/progmodes/ruby-mode.el index 72631a6557f..a1977246341 100644 --- a/lisp/progmodes/ruby-mode.el +++ b/lisp/progmodes/ruby-mode.el @@ -70,7 +70,7 @@ "Regexp to match modifiers.") (defconst ruby-block-mid-keywords - '("then" "else" "elsif" "when" "rescue" "ensure") + '("then" "else" "elsif" "when" "in" "rescue" "ensure") "Keywords where the indentation gets shallower in middle of block statements.") (defconst ruby-block-mid-re @@ -325,6 +325,13 @@ It is used when `ruby-encoding-magic-comment-style' is set to `custom'." "Use `ruby-encoding-map' to set encoding magic comment if this is non-nil." :type 'boolean :group 'ruby) +(defcustom ruby-toggle-block-space-before-parameters t + "When non-nil, ensure space between the \"toggled\" curly and parameters. +This only affects the output of the command `ruby-toggle-block'." + :type 'boolean + :safe 'booleanp + :version "29.1") + ;;; SMIE support (require 'smie) @@ -362,7 +369,9 @@ It is used when `ruby-encoding-magic-comment-style' is set to `custom'." (for-body (for-head ";" insts)) (for-head (id "in" exp)) (cases (exp "then" insts) - (cases "when" cases) (insts "else" insts)) + (cases "when" cases) + (cases "in" cases) + (insts "else" insts)) (expseq (exp) );;(expseq "," expseq) (hashvals (exp1 "=>" exp1) (hashvals "," hashvals)) (insts-rescue-insts (insts) @@ -373,7 +382,7 @@ It is used when `ruby-encoding-magic-comment-style' is set to `custom'." (if-body (ielsei) (if-body "elsif" if-body))) '((nonassoc "in") (assoc ";") (right " @ ") (assoc ",") (right "=")) - '((assoc "when")) + '((assoc "when" "in")) '((assoc "elsif")) '((assoc "rescue" "ensure")) '((assoc ","))) @@ -499,7 +508,7 @@ It is used when `ruby-encoding-magic-comment-style' is set to `custom'." ((member tok '("unless" "if" "while" "until")) (if (save-excursion (forward-word-strictly -1) (ruby-smie--bosp)) tok "iuwu-mod")) - ((string-match-p "\\`|[*&]?\\'" tok) + ((string-match-p "\\`|[*&]*\\'" tok) (forward-char (- 1 (length tok))) (setq tok "|") (cond @@ -552,7 +561,7 @@ It is used when `ruby-encoding-magic-comment-style' is set to `custom'." ((ruby-smie--closing-pipe-p) "closing-|") (t tok))) ((string-match-p "\\`[^|]+|\\'" tok) "closing-|") - ((string-match-p "\\`|[*&]\\'" tok) + ((string-match-p "\\`|[*&]*\\'" tok) (forward-char 1) (substring tok 1)) ((and (equal tok "") (eq ?\\ (char-before)) (looking-at "\n")) @@ -588,7 +597,7 @@ It is used when `ruby-encoding-magic-comment-style' is set to `custom'." (cond ((smie-rule-parent-p "def" "begin" "do" "class" "module" "for" "while" "until" "unless" - "if" "then" "elsif" "else" "when" + "if" "then" "elsif" "else" "when" "in" "rescue" "ensure" "{") (smie-rule-parent ruby-indent-level)) ;; For (invalid) code between switch and case. @@ -652,7 +661,7 @@ It is used when `ruby-encoding-magic-comment-style' is set to `custom'." ruby-indent-level)))) (`(:before . ,(or "else" "then" "elsif" "rescue" "ensure")) (smie-rule-parent)) - ('(:before . "when") + (`(:before . ,(or "when" "in")) ;; Align to the previous `when', but look up the virtual ;; indentation of `case'. (if (smie-rule-sibling-p) 0 (smie-rule-parent))) @@ -1722,13 +1731,14 @@ See `add-log-current-defun-function'." (insert "}") (goto-char orig) (delete-char 2) - ;; Maybe this should be customizable, let's see if anyone asks. - (insert "{ ") - (setq beg-marker (point-marker)) - (when (looking-at "\\s +|") - (delete-char (- (match-end 0) (match-beginning 0) 1)) - (forward-char) - (re-search-forward "|" (line-end-position) t)) + (insert "{") + (if (looking-at "\\s +|") + (progn + (just-one-space (if ruby-toggle-block-space-before-parameters 1 0)) + (setq beg-marker (point-marker)) + (forward-char) + (re-search-forward "|" (line-end-position) t)) + (setq beg-marker (point-marker))) (save-excursion (skip-chars-forward " \t\n\r") (setq beg-pos (point)) diff --git a/lisp/progmodes/scheme.el b/lisp/progmodes/scheme.el index a2689f17705..cf1d3949835 100644 --- a/lisp/progmodes/scheme.el +++ b/lisp/progmodes/scheme.el @@ -1,7 +1,6 @@ ;;; scheme.el --- Scheme (and DSSSL) editing mode -*- lexical-binding: t; -*- -;; Copyright (C) 1986-1988, 1997-1998, 2001-2022 Free Software -;; Foundation, Inc. +;; Copyright (C) 1986-2022 Free Software Foundation, Inc. ;; Author: Bill Rozas <jinx@martigny.ai.mit.edu> ;; Adapted-by: Dave Love <d.love@dl.ac.uk> @@ -115,12 +114,53 @@ (define-abbrev-table 'scheme-mode-abbrev-table ()) (defvar scheme-imenu-generic-expression - '((nil - "^(define\\(?:-\\(?:generic\\(?:-procedure\\)?\\|method\\)\\)?\\s-+(?\\(\\sw+\\)" 1) - ("Types" - "^(define-class\\s-+(?\\(\\sw+\\)" 1) - ("Macros" - "^(\\(defmacro\\|define-macro\\|define-syntax\\)\\s-+(?\\(\\sw+\\)" 2)) + `((nil + ,(rx bol "(define" + (zero-or-one "*") + (zero-or-one "-public") + (one-or-more space) + (zero-or-one "(") + (group (one-or-more (or word (syntax symbol))))) + 1) + ("Methods" + ,(rx bol "(define-" + (or "generic" "method" "accessor") + (one-or-more space) + (zero-or-one "(") + (group (one-or-more (or word (syntax symbol))))) + 1) + ("Classes" + ,(rx bol "(define-class" + (one-or-more space) + (zero-or-one "(") + (group (one-or-more (or word (syntax symbol))))) + 1) + ("Records" + ,(rx bol "(define-record-type" + (zero-or-one "*") + (one-or-more space) + (group (one-or-more (or word (syntax symbol))))) + 1) + ("Conditions" + ,(rx bol "(define-condition-type" + (one-or-more space) + (group (one-or-more (or word (syntax symbol))))) + 1) + ("Modules" + ,(rx bol "(define-module" + (one-or-more space) + (group "(" (one-or-more any) ")")) + 1) + ("Macros" + ,(rx bol "(" + (or (and "defmacro" + (zero-or-one "*") + (zero-or-one "-public")) + "define-macro" "define-syntax" "define-syntax-rule") + (one-or-more space) + (zero-or-one "(") + (group (one-or-more (or word (syntax symbol))))) + 1)) "Imenu generic expression for Scheme mode. See `imenu-generic-expression'.") (defun scheme-mode-variables () @@ -143,7 +183,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) @@ -161,12 +200,10 @@ (defvar scheme-mode-line-process "") -(defvar scheme-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map lisp-mode-shared-map) - map) - "Keymap for Scheme mode. -All commands in `lisp-mode-shared-map' are inherited by this map.") +(defvar-keymap scheme-mode-map + :doc "Keymap for Scheme mode. +All commands in `lisp-mode-shared-map' are inherited by this map." + :parent lisp-mode-shared-map) (easy-menu-define scheme-mode-menu scheme-mode-map "Menu for Scheme mode." @@ -522,10 +559,20 @@ indentation." (lisp-indent-specform 2 state indent-point normal-indent) (lisp-indent-specform 1 state indent-point normal-indent))) -;; (put 'begin 'scheme-indent-function 0), say, causes begin to be indented -;; like defun if the first form is placed on the next line, otherwise -;; it is indented like any other form (i.e. forms line up under first). - +;; See `scheme-indent-function' (the function) for what these do. +;; In a nutshell: +;; . for forms with no `scheme-indent-function' property the 2nd +;; and subsequent lines will be indented with one space; +;; . if the value of the property is zero, then when the first form +;; is on a separate line, the next lines will be indented with 2 +;; spaces instead of the default one space; +;; . if the value is a positive integer N, the first N lines after +;; the first one will be indented with 4 spaces, and the rest +;; will be indented with 2 spaces; +;; . if the value is `defun', the indentation is like for `defun'; +;; . if the value is a function, it will be called to produce the +;; required indentation. +;; See also http://community.schemewiki.org/?emacs-indentation. (put 'begin 'scheme-indent-function 0) (put 'case 'scheme-indent-function 1) (put 'delay 'scheme-indent-function 0) @@ -536,12 +583,16 @@ indentation." (put 'letrec 'scheme-indent-function 1) (put 'let-values 'scheme-indent-function 1) ; SRFI 11 (put 'let*-values 'scheme-indent-function 1) ; SRFI 11 +(put 'and-let* 'scheme-indent-function 1) ; SRFI 2 (put 'sequence 'scheme-indent-function 0) ; SICP, not r4rs (put 'let-syntax 'scheme-indent-function 1) (put 'letrec-syntax 'scheme-indent-function 1) (put 'syntax-rules 'scheme-indent-function 1) (put 'syntax-case 'scheme-indent-function 2) ; not r5rs +(put 'with-syntax 'scheme-indent-function 1) (put 'library 'scheme-indent-function 1) ; R6RS +;; Part of at least Guile, Chez Scheme, Chicken +(put 'eval-when 'scheme-indent-function 1) (put 'call-with-input-file 'scheme-indent-function 1) (put 'call-with-port 'scheme-indent-function 1) @@ -565,6 +616,14 @@ indentation." ;; SRFI-8 (put 'receive 'scheme-indent-function 2) +;; SRFI-204 (withdrawn, but provided in many implementations, see the SRFI text) +(put 'match 'scheme-indent-function 1) +(put 'match-lambda 'scheme-indent-function 0) +(put 'match-lambda* 'scheme-indent-function 0) +(put 'match-let 'scheme-indent-function 'scheme-let-indent) +(put 'match-let* 'scheme-indent-function 1) +(put 'match-letrec 'scheme-indent-function 1) + ;;;; MIT Scheme specific indentation. (if scheme-mit-dialect diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el index 966357c0970..4d2554c0870 100644 --- a/lisp/progmodes/sh-script.el +++ b/lisp/progmodes/sh-script.el @@ -402,45 +402,42 @@ This is buffer-local in every such buffer.") (rpm . (,sh-mode-syntax-table ?\' "."))) "Syntax-table used in Shell-Script mode. See `sh-feature'.") -(defvar sh-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\C-c(" 'sh-function) - (define-key map "\C-c\C-w" 'sh-while) - (define-key map "\C-c\C-u" 'sh-until) - (define-key map "\C-c\C-t" 'sh-tmp-file) - (define-key map "\C-c\C-s" 'sh-select) - (define-key map "\C-c\C-r" 'sh-repeat) - (define-key map "\C-c\C-o" 'sh-while-getopts) - (define-key map "\C-c\C-l" 'sh-indexed-loop) - (define-key map "\C-c\C-i" 'sh-if) - (define-key map "\C-c\C-f" 'sh-for) - (define-key map "\C-c\C-c" 'sh-case) - (define-key map "\C-c?" #'smie-config-show-indent) - (define-key map "\C-c=" #'smie-config-set-indent) - (define-key map "\C-c<" #'smie-config-set-indent) - (define-key map "\C-c>" #'smie-config-guess) - (define-key map "\C-c\C-\\" 'sh-backslash-region) - - (define-key map "\C-c+" 'sh-add) - (define-key map "\C-\M-x" 'sh-execute-region) - (define-key map "\C-c\C-x" 'executable-interpret) - (define-key map "\C-c\C-n" 'sh-send-line-or-region-and-step) - (define-key map "\C-c\C-d" 'sh-cd-here) - (define-key map "\C-c\C-z" 'sh-show-shell) - - (define-key map [remap delete-backward-char] - 'backward-delete-char-untabify) - (define-key map "\C-c:" 'sh-set-shell) - (define-key map [remap backward-sentence] 'sh-beginning-of-command) - (define-key map [remap forward-sentence] 'sh-end-of-command) - map) - "Keymap used in Shell-Script mode.") +(defvar-keymap sh-mode-map + :doc "Keymap used in Shell-Script mode." + "C-c (" #'sh-function + "C-c C-w" #'sh-while + "C-c C-u" #'sh-until + "C-c C-t" #'sh-tmp-file + "C-c C-s" #'sh-select + "C-c C-r" #'sh-repeat + "C-c C-o" #'sh-while-getopts + "C-c C-l" #'sh-indexed-loop + "C-c C-i" #'sh-if + "C-c C-f" #'sh-for + "C-c C-c" #'sh-case + "C-c ?" #'smie-config-show-indent + "C-c =" #'smie-config-set-indent + "C-c <" #'smie-config-set-indent + "C-c >" #'smie-config-guess + "C-c C-\\" #'sh-backslash-region + + "C-c +" #'sh-add + "C-M-x" #'sh-execute-region + "C-c C-x" #'executable-interpret + "C-c C-n" #'sh-send-line-or-region-and-step + "C-c C-d" #'sh-cd-here + "C-c C-z" #'sh-show-shell + "C-c :" #'sh-set-shell + + "<remap> <delete-backward-char>" #'backward-delete-char-untabify + "<remap> <backward-sentence>" #'sh-beginning-of-command + "<remap> <forward-sentence>" #'sh-end-of-command) (easy-menu-define sh-mode-menu sh-mode-map "Menu for Shell-Script mode." '("Sh-Script" ["Backslash region" sh-backslash-region - :help "Insert, align, or delete end-of-line backslashes on the lines in the region."] + :help "Insert, align, or delete end-of-line backslashes on the lines in the region"] ["Set shell type..." sh-set-shell :help "Set this buffer's shell to SHELL (a string)"] ["Execute script..." executable-interpret @@ -458,7 +455,7 @@ This is buffer-local in every such buffer.") ["Select Statement" sh-select :help "Insert a select statement "] ["Indexed Loop" sh-indexed-loop - :help "Insert an indexed loop from 1 to n."] + :help "Insert an indexed loop from 1 to n"] ["Options Loop" sh-while-getopts :help "Insert a while getopts loop."] ["While Loop" sh-while @@ -482,7 +479,7 @@ This is buffer-local in every such buffer.") ["Show indentation" smie-config-show-indent :help "Show the how the current line would be indented"] ["Learn buffer indentation" smie-config-guess - :help "Learn how to indent the buffer the way it currently is."])) + :help "Learn how to indent the buffer the way it currently is"])) (defvar sh-skeleton-pair-default-alist '((?\( _ ?\)) (?\)) (?\[ ?\s _ ?\s ?\]) (?\]) @@ -628,7 +625,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" @@ -643,7 +641,12 @@ implemented as aliases. See `sh-feature'." :version "24.4" ; bash4 additions :group 'sh-script) - +(defcustom sh-indent-statement-after-and t + "How to indent statements following && in Shell-Script mode. +If t, indent to align with &&. +If nil, indent to align with the previous line's indentation." + :type 'boolean + :version "29.1") (defcustom sh-leading-keywords '((bash sh-append sh @@ -866,7 +869,7 @@ See `sh-feature'.") "\\(?:\\(?:.*[^\\\n]\\)?\\(?:\\\\\\\\\\)*\\\\\n\\)*.*") (defconst sh-here-doc-open-re - (concat "[^<]<<-?\\s-*\\\\?\\(\\(?:['\"][^'\"]+['\"]\\|\\sw\\|[-/~._]\\)+\\)" + (concat "[^<]<<-?\\s-*\\\\?\\(\\(?:['\"][^'\"]+['\"]\\|\\sw\\|[-/~._@]\\)+\\)" sh-escaped-line-re "\\(\n\\)"))) (defun sh--inside-noncommand-expression (pos) @@ -1409,7 +1412,7 @@ If FORCE is non-nil and no process found, create one." (defun sh-show-shell () "Pop the shell interaction buffer." (interactive) - (pop-to-buffer (process-buffer (sh-shell-process t)))) + (pop-to-buffer (process-buffer (sh-shell-process t)) display-comint-buffer-action)) (defun sh-send-text (text) "Send TEXT to `sh-shell-process'." @@ -1540,6 +1543,11 @@ with your script for an edit-interpret-debug cycle." (add-hook 'completion-at-point-functions #'sh-completion-at-point-function nil t) (setq-local outline-regexp "###") + (setq-local escaped-string-quote + (lambda (terminator) + (if (eq terminator ?') + "'\\'" + "\\"))) ;; Parse or insert magic number for exec, and set all variables depending ;; on the shell thus determined. (sh-set-shell @@ -1551,7 +1559,7 @@ with your script for an edit-interpret-debug cycle." ;; Checks that use `buffer-file-name' follow. ((string-match "\\.m?spec\\'" buffer-file-name) "rpm") ((string-match "[.]sh\\>" buffer-file-name) "sh") - ((string-match "[.]bash\\>" buffer-file-name) "bash") + ((string-match "[.]bash\\(rc\\)?\\>" buffer-file-name) "bash") ((string-match "[.]ksh\\>" buffer-file-name) "ksh") ((string-match "[.]mkshrc\\>" buffer-file-name) "mksh") ((string-match "[.]t?csh\\(rc\\)?\\>" buffer-file-name) "csh") @@ -1604,7 +1612,7 @@ This adds rules for comments and assignments." ;;; Completion -(defvar sh--completion-keywords '("if" "while" "until" "for")) +(defvar sh--completion-keywords '("if" "while" "until" "for" "then")) (defun sh--vars-before-point () (save-excursion @@ -1776,21 +1784,27 @@ Does not preserve point." (n (skip-syntax-backward "."))) (if (or (zerop n) (and (eq n -1) + ;; Skip past quoted white space. (let ((p (point))) (if (eq -1 (% (skip-syntax-backward "\\") 2)) t (goto-char p) nil)))) (while - (progn (skip-syntax-backward ".w_'") - (or (not (zerop (skip-syntax-backward "\\"))) - (when (eq ?\\ (char-before (1- (point)))) - (let ((p (point))) - (forward-char -1) - (if (eq -1 (% (skip-syntax-backward "\\") 2)) - t - (goto-char p) - nil)))))) + (progn + ;; Skip past words, but stop at semicolons. + (while (and (not (zerop (skip-syntax-backward "w_'"))) + (not (eq (char-before (point)) ?\;)) + (skip-syntax-backward "."))) + (or (not (zerop (skip-syntax-backward "\\"))) + ;; Skip past quoted white space. + (when (eq ?\\ (char-before (1- (point)))) + (let ((p (point))) + (forward-char -1) + (if (eq -1 (% (skip-syntax-backward "\\") 2)) + t + (goto-char p) + nil)))))) (goto-char (- (point) (% (skip-syntax-backward "\\") 2)))) (buffer-substring-no-properties (point) pos))) @@ -1975,7 +1989,7 @@ May return nil if the line should not be treated as continued." (cons 'column (smie-indent-keyword ";")) (smie-rule-separator kind))) (`(:after . ,(or ";;" ";&" ";;&")) - (with-demoted-errors + (with-demoted-errors "SMIE rule error: %S" (smie-backward-sexp token) (cons 'column (if (or (smie-rule-bolp) @@ -1986,7 +2000,9 @@ May return nil if the line should not be treated as continued." (current-column) (smie-indent-calculate))))) (`(:before . ,(or "|" "&&" "||")) - (unless (smie-rule-parent-p token) + (when (and (not (smie-rule-parent-p token)) + (or (not (equal token "&&")) + sh-indent-statement-after-and)) (smie-backward-sexp token) `(column . ,(+ (funcall smie-rules-function :elem 'basic) (smie-indent-virtual))))) diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el index 6183aee20e3..8d259860901 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,19 +3211,12 @@ 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) (let ((file-name - (read-file-name prompt + (read-file-name prompt-def (file-name-directory last-value) default (if (plist-member plist :must-match) @@ -3261,7 +3246,7 @@ For both `:file' and `:completion', there can also be a default)) ((plist-get plist :number) - (read-number prompt (or default last-value 0))) + (read-number (concat prompt ": ") (or default last-value 0))) (t (read-string prompt-def last-value history-var default)))))) @@ -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) @@ -3663,94 +3648,69 @@ Allows the suppression of continuation prompts.") (defvar sql-preoutput-hold nil) -(defun sql-starts-with-prompt-re () - "Anchor the prompt expression at the beginning of the output line. -Remove the start of line regexp." - (concat "\\`" comint-prompt-regexp)) - -(defun sql-ends-with-prompt-re () - "Anchor the prompt expression at the end of the output line. -Match a SQL prompt or a password prompt." - (concat "\\(?:\\(?:" sql-prompt-regexp "\\)\\|" - "\\(?:" comint-password-prompt-regexp "\\)\\)\\'")) - (defun sql-interactive-remove-continuation-prompt (oline) "Strip out continuation prompts out of the OLINE. Added to the `comint-preoutput-filter-functions' hook in a SQL -interactive buffer. If `sql-output-newline-count' is greater than -zero, then an output line matching the continuation prompt is filtered -out. If the count is zero, then a newline is inserted into the output -to force the output from the query to appear on a new line. - -The complication to this filter is that the continuation prompts -may arrive in multiple chunks. If they do, then the function -saves any unfiltered output in a buffer and prepends that buffer -to the next chunk to properly match the broken-up prompt. - -If the filter gets confused, it should reset and stop filtering -to avoid deleting non-prompt output." - - ;; continue gathering lines of text iff - ;; + we know what a prompt looks like, and - ;; + there is held text, or - ;; + there are continuation prompt yet to come, or - ;; + not just a prompt string +interactive buffer. The complication to this filter is that the +continuation prompts may arrive in multiple chunks. If they do, +then the function saves any unfiltered output in a buffer and +prepends that buffer to the next chunk to properly match the +broken-up prompt. + +The filter goes into play only if something is already +accumulated, or we're waiting for continuation +prompts (`sql-output-newline-count' is positive). In this case: +- Accumulate process output into `sql-preoutput-hold'. +- Remove any complete prompts / continuation prompts that we're waiting + for. +- In case we're expecting more prompts - return all currently + accumulated _complete_ lines, leaving the rest for the next + invocation. They will appear in the output immediately. This way we + don't accumulate large chunks of data for no reason. +- If we found all expected prompts - just return all current accumulated + data." (when (and comint-prompt-regexp - (or (> (length (or sql-preoutput-hold "")) 0) - (> (or sql-output-newline-count 0) 0) - (not (or (string-match sql-prompt-regexp oline) - (and sql-prompt-cont-regexp - (string-match sql-prompt-cont-regexp oline)))))) - + ;; We either already have something held, or expect + ;; prompts + (or sql-preoutput-hold + (and sql-output-newline-count + (> sql-output-newline-count 0)))) (save-match-data - (let (prompt-found last-nl) - - ;; Add this text to what's left from the last pass - (setq oline (concat sql-preoutput-hold oline) - sql-preoutput-hold "") - - ;; If we are looking for multiple prompts - (when (and (integerp sql-output-newline-count) - (>= sql-output-newline-count 1)) - ;; Loop thru each starting prompt and remove it - (let ((start-re (sql-starts-with-prompt-re))) - (while (and (not (string= oline "")) - (> sql-output-newline-count 0) - (string-match start-re oline)) - (setq oline (replace-match "" nil nil oline) - sql-output-newline-count (1- sql-output-newline-count) - prompt-found t))) - - ;; If we've found all the expected prompts, stop looking - (if (= sql-output-newline-count 0) - (setq sql-output-newline-count nil) - - ;; Still more possible prompts, leave them for the next pass - (setq sql-preoutput-hold oline - oline ""))) - - ;; If no prompts were found, stop looking - (unless prompt-found - (setq sql-output-newline-count nil - oline (concat oline sql-preoutput-hold) - sql-preoutput-hold "")) - - ;; Break up output by physical lines if we haven't hit the final prompt - (let ((end-re (sql-ends-with-prompt-re))) - (unless (and (not (string= oline "")) - (string-match end-re oline) - (>= (match-end 0) (length oline))) - ;; Find everything upto the last nl - (setq last-nl 0) - (while (string-match "\n" oline last-nl) - (setq last-nl (match-end 0))) - ;; Hold after the last nl, return upto last nl - (setq sql-preoutput-hold (concat (substring oline last-nl) - sql-preoutput-hold) - oline (substring oline 0 last-nl))))))) + ;; Add this text to what's left from the last pass + (setq oline (concat sql-preoutput-hold oline) + sql-preoutput-hold nil) + + ;; If we are looking for prompts + (when (and sql-output-newline-count + (> sql-output-newline-count 0)) + ;; Loop thru each starting prompt and remove it + (while (and (not (string-empty-p oline)) + (> sql-output-newline-count 0) + (string-match comint-prompt-regexp oline)) + (setq oline (replace-match "" nil nil oline) + sql-output-newline-count (1- sql-output-newline-count))) + + ;; If we've found all the expected prompts, stop looking + (if (= sql-output-newline-count 0) + (setq sql-output-newline-count nil) + ;; Still more possible prompts, leave them for the next pass + (setq sql-preoutput-hold oline + oline ""))) + + ;; Lines that are now complete may be passed further + (when sql-preoutput-hold + (let ((last-nl 0)) + (while (string-match "\n" sql-preoutput-hold last-nl) + (setq last-nl (match-end 0))) + ;; Return up to last nl, hold after the last nl + (setq oline (substring sql-preoutput-hold 0 last-nl) + sql-preoutput-hold (substring sql-preoutput-hold last-nl)) + (when (string-empty-p sql-preoutput-hold) + (setq sql-preoutput-hold nil)))))) oline) + ;;; Sending the region to the SQLi buffer. (defvar sql-debug-send nil "Display text sent to SQL process pragmatically.") @@ -4182,10 +4142,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. @@ -4203,6 +4159,7 @@ must tell Emacs. Here's how to do that in your init file: (setq-local abbrev-all-caps 1) ;; Contains the name of database objects (setq-local sql-contains-names t) + (setq-local escaped-string-quote "'") (setq-local syntax-propertize-function (syntax-propertize-rules ;; Handle escaped apostrophes within strings. @@ -4214,7 +4171,18 @@ must tell Emacs. Here's how to do that in your init file: nil))) ;; Propertize rules to not have /- and -* start comments. ("\\(/-\\)" (1 ".")) - ("\\(-\\*\\)" (1 ".")))) + ("\\(-\\*\\)" + (1 + (if (save-excursion + (not (ppss-comment-depth + (syntax-ppss (match-beginning 1))))) + ;; If we're outside a comment, we don't let -* + ;; start a comment. + (string-to-syntax ".") + ;; Inside a comment, ignore it to avoid -*/ not + ;; being interpreted as a comment end. + (forward-char -1) + nil))))) ;; Set syntax and font-face highlighting ;; Catch changes to sql-product and highlight accordingly (sql-set-product (or sql-product 'ansi)) ; Fixes bug#13591 @@ -4308,9 +4276,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 @@ -4655,6 +4620,9 @@ the call to \\[sql-product-interactive] with (setq sql-buffer (buffer-name new-sqli-buffer)) (run-hooks 'sql-set-sqli-hook))) + ;; Also set the global value. + (setq-default sql-buffer (buffer-name new-sqli-buffer)) + ;; Make sure the connection is complete ;; (Sometimes start up can be slow) ;; and call the login hook @@ -4681,6 +4649,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 +4681,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/tcl.el b/lisp/progmodes/tcl.el index ed6dce02c03..8c179879ce2 100644 --- a/lisp/progmodes/tcl.el +++ b/lisp/progmodes/tcl.el @@ -344,7 +344,7 @@ information): Add functions to the hook with `add-hook': - (add-hook 'tcl-mode-hook #'tcl-guess-application)") + (add-hook \\='tcl-mode-hook #\\='tcl-guess-application)") (defvar tcl-proc-list diff --git a/lisp/progmodes/verilog-mode.el b/lisp/progmodes/verilog-mode.el index b2ce9140573..31d50a1882e 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 @@ -3620,10 +3622,10 @@ is 0. Meaning of *single* declaration: E.g. In a module's port-list - module test(input clk, rst, x, output [1:0] y); - Here 'input clk, rst, x' is 1 *single* declaration statement, -and 'output [1:0] y' is the other single declaration. In the 1st single -declaration, POINT is moved to start of 'clk'. And in the 2nd declaration, -POINT is moved to 'y'." + Here `input clk, rst, x' is 1 *single* declaration statement, +and `output [1:0] y' is the other single declaration. In the 1st single +declaration, POINT is moved to start of `clk'. And in the 2nd declaration, +POINT is moved to `y'." (let (maxpoint old-point) @@ -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 4e5f5df8142..39c5eb453b1 100644 --- a/lisp/progmodes/vhdl-mode.el +++ b/lisp/progmodes/vhdl-mode.el @@ -8789,7 +8789,10 @@ project is defined." (defun vhdl-electric-period (count) "`..' --> ` => '" (interactive "p") (if (and vhdl-stutter-mode (= count 1) (not (vhdl-in-literal))) - (cond ((= (preceding-char) vhdl-last-input-event) + ;; We use this-command-keys below to account for translation of + ;; kp-decimal into '.'; vhdl-last-input-event doesn't catch + ;; that. + (cond ((eq (preceding-char) (aref (this-command-keys) 0)) (progn (delete-char -1) (unless (eq (preceding-char) ? ) (insert " ")) (insert "=> "))) @@ -10687,8 +10690,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/which-func.el b/lisp/progmodes/which-func.el index abe25f2c633..3c8d4f43dbc 100644 --- a/lisp/progmodes/which-func.el +++ b/lisp/progmodes/which-func.el @@ -64,7 +64,7 @@ ;; Variables for customization ;; --------------------------- ;; -(defvar which-func-unknown "???" +(defvar which-func-unknown "n/a" "String to display in the mode line when current function is unknown.") (defgroup which-func nil diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index c4b439f587c..683589d71c6 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-2022 Free Software Foundation, Inc. -;; Version: 1.3.0 +;; Version: 1.4.1 ;; 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,9 +195,16 @@ 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 nil :documentation "String which describes the location. @@ -213,14 +220,14 @@ locations point to the same line. This behavior is new in Emacs 28.") 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) -(cl-defgeneric xref-match-length ((item xref-match-item)) +(cl-defmethod xref-match-length ((item xref-match-item)) "Return the length of the match." (xref-match-item-length item)) @@ -346,15 +353,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 @@ -380,7 +381,8 @@ elements is negated: these commands will NOT prompt." (defcustom xref-after-jump-hook '(recenter xref-pulse-momentarily) - "Functions called after jumping to an xref." + "Functions called after jumping to an xref. +Also see `xref-current-item'." :type 'hook) (defcustom xref-after-return-hook '(xref-pulse-momentarily) @@ -425,42 +427,79 @@ 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 'xref--history "29.1") + +(defun xref-set-marker-ring-length (_var _val) + (declare (obsolete nil "29.1")) + nil) -(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))) +(defvar xref--history (cons nil nil) + "(BACKWARD-STACK . FORWARD-STACK) of markers to visited Xref locations.") + +(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)) (set-marker marker nil nil) (run-hooks 'xref-after-return-hook)))) -(defvar xref--current-item nil) +(define-obsolete-variable-alias + 'xref--current-item + 'xref-current-item + "29.1") + +(defvar xref-current-item nil + "Dynamically bound to the current item being processed. +This can be used from `xref-after-jump-hook', for instance.") (defun xref-pulse-momentarily () (pcase-let ((`(,beg . ,end) (save-excursion (or - (let ((length (xref-match-length xref--current-item))) + (let ((length (xref-match-length xref-current-item))) (and length (cons (point) (+ (point) length)))) (back-to-indentation) (if (eolp) @@ -470,17 +509,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) @@ -511,7 +556,7 @@ If SELECT is non-nil, select the target window." (window (pop-to-buffer buf t)) (frame (let ((pop-up-frames t)) (pop-to-buffer buf t)))) (xref--goto-char marker)) - (let ((xref--current-item item)) + (let ((xref-current-item item)) (run-hooks 'xref-after-jump-hook))) @@ -619,7 +664,7 @@ SELECT is `quit', also quit the *xref* window." "Display the source of xref at point in the appropriate window, if any." (interactive) (let* ((xref (xref--item-at-point)) - (xref--current-item xref)) + (xref-current-item xref)) (when xref (xref--set-arrow) (xref--show-location (xref-item-location xref))))) @@ -678,7 +723,7 @@ quit the *xref* buffer." (let* ((buffer (current-buffer)) (xref (or (xref--item-at-point) (user-error "Choose a reference to visit"))) - (xref--current-item xref)) + (xref-current-item xref)) (xref--set-arrow) (xref--show-location (xref-item-location xref) (if quit 'quit t)) (if (fboundp 'next-error-found) @@ -695,7 +740,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. @@ -703,15 +748,23 @@ quit the *xref* buffer." This command interactively replaces FROM with TO in the names of the references displayed in the current *xref* buffer. +When called interactively, it uses '.*' as FROM, which means +replace the whole name. Unless called with prefix argument, in +which case the user is prompted for both FROM and TO. + As each match is found, the user must type a character saying what to do with it. Type SPC or `y' to replace the match, DEL or `n' to skip and go to the next match. For more directions, -type \\[help-command] at that time. -" +type \\[help-command] at that time." (interactive - (let ((fr (read-regexp "Xref query-replace (regexp)" ".*"))) - (list fr - (read-regexp (format "Xref query-replace (regexp) %s with: " fr))))) + (let* ((fr + (if current-prefix-arg + (read-regexp "Query-replace (regexp)" ".*") + ".*")) + (prompt (if current-prefix-arg + (format "Query-replace (regexp) %s with: " fr) + "Query-replace all matches with: "))) + (list fr (read-regexp prompt)))) (let* (item xrefs iter) (save-excursion (while (setq item (xref--search-property 'xref-item)) @@ -905,15 +958,15 @@ beginning of the line." (let ((win (get-buffer-window (current-buffer)))) (and win (set-window-point win (point)))) (xref--set-arrow) - (let ((xref--current-item xref)) + (let ((xref-current-item xref)) (xref--show-location (xref-item-location xref) t))) (t (error "No %s xref" (if backward "previous" "next")))))) (defvar xref--button-map (let ((map (make-sparse-keymap))) - (define-key map [mouse-1] #'xref-goto-xref) - (define-key map [mouse-2] #'xref-select-and-show-xref) + (define-key map [follow-link] 'mouse-face) + (define-key map [mouse-2] #'xref-goto-xref) map)) (defun xref-select-and-show-xref (event) @@ -1062,6 +1115,13 @@ Return an alist of the form ((GROUP . (XREF ...)) ...)." (cdr pair))) alist))) +(defun xref--ensure-default-directory (dd buffer) + ;; We might be in a let-binding which will restore the current value + ;; to a previous one (bug#53626). So do this later. + (run-with-timer + 0 nil + (lambda () (with-current-buffer buffer (setq default-directory dd))))) + (defun xref--show-xref-buffer (fetcher alist) (cl-assert (functionp fetcher)) (let* ((xrefs @@ -1072,7 +1132,7 @@ Return an alist of the form ((GROUP . (XREF ...)) ...)." (dd default-directory) buf) (with-current-buffer (get-buffer-create xref-buffer-name) - (setq default-directory dd) + (xref--ensure-default-directory dd (current-buffer)) (xref--xref-buffer-mode) (xref--show-common-initialize xref-alist fetcher alist) (pop-to-buffer (current-buffer)) @@ -1171,7 +1231,7 @@ local keymap that binds `RET' to `xref-quit-and-goto-xref'." (assoc-default 'display-action alist))) (t (with-current-buffer (get-buffer-create xref-buffer-name) - (setq default-directory dd) + (xref--ensure-default-directory dd (current-buffer)) (xref--transient-buffer-mode) (xref--show-common-initialize (xref--analyze xrefs) fetcher alist) (pop-to-buffer (current-buffer) @@ -1295,6 +1355,13 @@ definitions." (defvar xref--read-pattern-history nil) +;;;###autoload +(defun xref-show-xrefs (fetcher display-action) + "Display some Xref values produced by FETCHER using DISPLAY-ACTION. +The meanings of both arguments are the same as documented in +`xref-show-xrefs-function'." + (xref--show-xrefs fetcher display-action)) + (defun xref--show-xrefs (fetcher display-action &optional _always-show-list) (xref--push-markers) (unless (functionp fetcher) @@ -1340,12 +1407,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))) @@ -1406,7 +1478,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)) @@ -1433,6 +1505,23 @@ is nil, prompt only if there's no usable symbol at point." (interactive (list (xref--read-identifier "Find references of: "))) (xref--find-xrefs identifier 'references identifier nil)) +(defun xref-find-references-and-replace (from to) + "Replace all references to identifier FROM with TO." + (interactive + (let* ((query-replace-read-from-default 'find-tag-default) + (common + (query-replace-read-args "Query replace identifier" nil))) + (list (nth 0 common) (nth 1 common)))) + (require 'xref) + (with-current-buffer + (let ((xref-show-xrefs-function + ;; Some future-proofing (bug#44905). + (custom--standard-value 'xref-show-xrefs-function)) + ;; Disable auto-jumping, it will mess up replacement logic. + xref-auto-jump-to-first-xref) + (xref-find-references from)) + (xref-query-replace-in-results ".*" to))) + ;;;###autoload (defun xref-find-definitions-at-mouse (event) "Find the definition of identifier at or around mouse click. @@ -1460,7 +1549,7 @@ This command is intended to be bound to a mouse event." (xref-find-references identifier)) (user-error "No identifier here")))) -(declare-function apropos-parse-pattern "apropos" (pattern)) +(declare-function apropos-parse-pattern "apropos" (pattern &optional do-all)) ;;;###autoload (defun xref-find-apropos (pattern) @@ -1497,7 +1586,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) @@ -1633,7 +1723,8 @@ IGNORES is a list of glob patterns for files to ignore." . ;; '!*/' is there to filter out dirs (e.g. submodules). "xargs -0 rg <C> --null -nH --no-heading --no-messages -g '!*/' -e <R>" - )) + ) + (ugrep . "xargs -0 ugrep <C> --null -ns -e <R>")) "Associative list mapping program identifiers to command templates. Program identifier should be a symbol, named after the search program. @@ -1662,6 +1753,7 @@ utility function used by commands like `dired-do-find-regexp' and :type '(choice (const :tag "Use Grep" grep) (const :tag "Use ripgrep" ripgrep) + (const :tag "Use ugrep" ugrep) (symbol :tag "User defined")) :version "28.1" :package-version '(xref . "1.0.4")) @@ -1781,7 +1873,7 @@ to control which program to use when looking for matches." (xref--find-ignores-arguments ignores dir))) (defun xref--find-ignores-arguments (ignores dir) - "Convert IGNORES and DIR to a list of arguments for 'find'. + "Convert IGNORES and DIR to a list of arguments for `find'. IGNORES is a list of glob patterns. DIR is an absolute directory, used as the root of the ignore globs." (cl-assert (not (string-match-p "\\`~" dir))) @@ -1841,21 +1933,22 @@ Such as the current syntax table and the applied syntax properties." (defvar xref--last-file-buffer nil) (defvar xref--temp-buffer-file-name nil) +(defvar xref--hits-remote-id nil) (defun xref--convert-hits (hits regexp) (let (xref--last-file-buffer (tmp-buffer (generate-new-buffer " *xref-temp*")) - (remote-id (file-remote-p default-directory)) + (xref--hits-remote-id (file-remote-p default-directory)) (syntax-needed (xref--regexp-syntax-dependent-p regexp))) (unwind-protect (mapcan (lambda (hit) - (xref--collect-matches hit regexp tmp-buffer remote-id syntax-needed)) + (xref--collect-matches hit regexp tmp-buffer syntax-needed)) hits) (kill-buffer tmp-buffer)))) -(defun xref--collect-matches (hit regexp tmp-buffer remote-id syntax-needed) +(defun xref--collect-matches (hit regexp tmp-buffer syntax-needed) (pcase-let* ((`(,line ,file ,text) hit) - (file (and file (concat remote-id file))) + (file (and file (concat xref--hits-remote-id file))) (buf (xref--find-file-buffer file)) (inhibit-modification-hooks t)) (if buf @@ -1928,10 +2021,17 @@ Such as the current syntax table and the applied syntax properties." (defun xref--find-file-buffer (file) (unless (equal (car xref--last-file-buffer) file) - (setq xref--last-file-buffer - ;; `find-buffer-visiting' is considerably slower, - ;; especially on remote files. - (cons file (get-file-buffer file)))) + ;; `find-buffer-visiting' is considerably slower, + ;; especially on remote files. + (let ((buf (get-file-buffer file))) + (when (and buf + (or + (buffer-modified-p buf) + (unless xref--hits-remote-id + (not (verify-visited-file-modtime (current-buffer)))))) + ;; We can't use buffers whose contents diverge from disk (bug#54025). + (setq buf nil)) + (setq xref--last-file-buffer (cons file buf)))) (cdr xref--last-file-buffer)) (provide 'xref) diff --git a/lisp/progmodes/xscheme.el b/lisp/progmodes/xscheme.el index e6db65aced2..6e21131e4aa 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 bd750ff2a77..eb1abfd92db 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 af366066f71..8df5204fa12 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 2ee9717f4dc..2de98311540 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. @@ -1353,7 +1353,7 @@ to a file, and killing a buffer is counted as \"operating\" on the file. If instead you want to prioritize files that appear in buffers you switch to a lot, you can say something like the following: - (add-hook 'buffer-list-update-hook 'recentf-track-opened-file)" + (add-hook \\='buffer-list-update-hook #\\='recentf-track-opened-file)" :global t :group 'recentf :keymap recentf-mode-map @@ -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 9af99106e76..78aa130a948 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 040ce818a24..ea4e3d0bd81 100644 --- a/lisp/repeat.el +++ b/lisp/repeat.el @@ -176,7 +176,7 @@ that variable on the theory they're doing more good than harm; `repeat' does that, and usually does do more good than harm. However, like all do-gooders, sometimes `repeat' gets surprising results from its altruism. The value of this function is always whether the value of `this-command' would've been -'repeat if `repeat' hadn't modified it." +`repeat' if `repeat' hadn't modified it." (= repeat-num-input-keys-at-repeat num-input-keys)) ;; An example of the use of (repeat-is-really-this-command) may still be @@ -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 dd1bdae4c54..3d0877a9a64 100644 --- a/lisp/replace.el +++ b/lisp/replace.el @@ -186,6 +186,12 @@ See `replace-regexp' and `query-replace-regexp-eval'.") length) length))))) +(defvar query-replace-read-from-default nil + "Function to get default non-regexp value for `query-replace-read-from'.") + +(defvar query-replace-read-from-regexp-default nil + "Function to get default regexp value for `query-replace-read-from'.") + (defun query-replace-read-from-suggestions () "Return a list of standard suggestions for `query-replace-read-from'. By default, the list includes the active region, the identifier @@ -233,8 +239,12 @@ wants to replace FROM with TO." query-replace-defaults)) (symbol-value query-replace-from-history-variable))) (minibuffer-allow-text-properties t) ; separator uses text-properties + (default (when (and query-replace-read-from-default (not regexp-flag)) + (funcall query-replace-read-from-default))) (prompt - (cond ((and query-replace-defaults separator) + (cond ((and query-replace-read-from-regexp-default regexp-flag) prompt) + (default (format-prompt prompt default)) + ((and query-replace-defaults separator) (format-prompt prompt (car minibuffer-history))) (query-replace-defaults (format-prompt @@ -255,16 +265,26 @@ wants to replace FROM with TO." (append '((separator . t) (face . t)) text-property-default-nonsticky))) (if regexp-flag - (read-regexp prompt nil 'minibuffer-history) + (read-regexp + (if query-replace-read-from-regexp-default + (string-remove-suffix ": " prompt) + prompt) + query-replace-read-from-regexp-default + 'minibuffer-history) (read-from-minibuffer prompt nil nil nil nil - (query-replace-read-from-suggestions) t))))) + (if default + (delete-dups + (cons default (query-replace-read-from-suggestions))) + (query-replace-read-from-suggestions)) + t))))) (to)) - (if (and (zerop (length from)) query-replace-defaults) + (if (and (zerop (length from)) query-replace-defaults (not default)) (cons (caar query-replace-defaults) (query-replace-compile-replacement (cdar query-replace-defaults) regexp-flag)) - (setq from (query-replace--split-string from)) + (setq from (or (and (zerop (length from)) default) + (query-replace--split-string from))) (when (consp from) (setq to (cdr from) from (car from))) (add-to-history query-replace-from-history-variable from nil t) ;; Warn if user types \n or \t, but don't reject the input. @@ -345,11 +365,33 @@ should a regexp." (unless noerror (barf-if-buffer-read-only)) (save-mark-and-excursion - (let* ((from (query-replace-read-from prompt regexp-flag)) + (let* ((delimited-flag (and current-prefix-arg + (not (eq current-prefix-arg '-)))) + (from (minibuffer-with-setup-hook + (minibuffer-lazy-highlight-setup + :case-fold case-fold-search + :filter (when (use-region-p) + (replace--region-filter + (funcall region-extract-function 'bounds))) + :highlight query-replace-lazy-highlight + :regexp regexp-flag + :regexp-function (or replace-regexp-function + delimited-flag + (and replace-char-fold + (not regexp-flag) + #'char-fold-to-regexp)) + :transform (lambda (string) + (let* ((split (query-replace--split-string string)) + (from-string (if (consp split) (car split) split))) + (when (and case-fold-search search-upper-case) + (setq isearch-case-fold-search + (isearch-no-upper-case-p from-string regexp-flag))) + from-string))) + (query-replace-read-from prompt regexp-flag))) (to (if (consp from) (prog1 (cdr from) (setq from (car from))) (query-replace-read-to from prompt regexp-flag)))) (list from to - (or (and current-prefix-arg (not (eq current-prefix-arg '-))) + (or delimited-flag (and (plist-member (text-properties-at 0 from) 'isearch-regexp-function) (get-text-property 0 'isearch-regexp-function from))) (and current-prefix-arg (eq current-prefix-arg '-)))))) @@ -2102,6 +2144,7 @@ See also `multi-occur'." ;; (for Occur Edit mode). front-sticky t rear-nonsticky t + read-only t occur-target ,markers follow-link t help-echo "mouse-2: go to this occurrence")))) @@ -2279,11 +2322,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) @@ -2418,20 +2461,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'.") @@ -2637,6 +2680,15 @@ It is used by `query-replace-regexp', `replace-regexp', It is called with three arguments, as if it were `re-search-forward'.") +(defvar replace-regexp-function nil + "Function to convert the FROM string of query-replace commands to a regexp. +This is used by `query-replace', `query-replace-regexp', etc. as +the value of `isearch-regexp-function' when they search for the +occurrences of the string/regexp to be replaced. This is intended +to be used when the string to be replaced, as typed by the user, +is not to be interpreted literally, but instead should be converted +to a regexp that is actually used for the search.") + (defun replace-search (search-string limit regexp-flag delimited-flag case-fold &optional backward) "Search for the next occurrence of SEARCH-STRING to replace." @@ -2649,7 +2701,8 @@ It is called with three arguments, as if it were ;; outside of this function because then another I-search ;; used after `recursive-edit' might override them. (let* ((isearch-regexp regexp-flag) - (isearch-regexp-function (or delimited-flag + (isearch-regexp-function (or replace-regexp-function + delimited-flag (and replace-char-fold (not regexp-flag) #'char-fold-to-regexp))) @@ -2665,6 +2718,11 @@ It is called with three arguments, as if it were (or (if regexp-flag replace-re-search-function replace-search-function) + ;; `isearch-search-fun' can't be used here because + ;; when buffer-local `isearch-search-fun-function' + ;; searches e.g. the minibuffer history, then + ;; `query-replace' should not operate on the whole + ;; history, but only on the minibuffer contents. (isearch-search-fun-default)))) (funcall search-function search-string limit t))) @@ -2706,7 +2764,8 @@ It is called with three arguments, as if it were (if query-replace-lazy-highlight (let ((isearch-string search-string) (isearch-regexp regexp-flag) - (isearch-regexp-function (or delimited-flag + (isearch-regexp-function (or replace-regexp-function + delimited-flag (and replace-char-fold (not regexp-flag) #'char-fold-to-regexp))) @@ -2752,6 +2811,26 @@ It is called with three arguments, as if it were ,search-str ,next-replace) ,stack)) +(defun replace--region-filter (bounds) + "Return a function that decides if a region is inside BOUNDS. +BOUNDS is a list of cons cells of the form (START . END). The +returned function takes as argument two buffer positions, START +and END." + (let ((region-bounds + (mapcar (lambda (position) + (cons (copy-marker (car position)) + (copy-marker (cdr position)))) + bounds))) + (lambda (start end) + (delq nil (mapcar + (lambda (bounds) + (and + (>= start (car bounds)) + (<= start (cdr bounds)) + (>= end (car bounds)) + (<= end (cdr bounds)))) + region-bounds))))) + (defun perform-replace (from-string replacements query-flag regexp-flag delimited-flag &optional repeat-count map start end backward region-noncontiguous-p) @@ -2836,22 +2915,9 @@ characters." ;; Unless a single contiguous chunk is selected, operate on multiple chunks. (when region-noncontiguous-p - (let ((region-bounds - (mapcar (lambda (position) - (cons (copy-marker (car position)) - (copy-marker (cdr position)))) - (funcall region-extract-function 'bounds)))) - (setq region-filter - (lambda (start end) - (delq nil (mapcar - (lambda (bounds) - (and - (>= start (car bounds)) - (<= start (cdr bounds)) - (>= end (car bounds)) - (<= end (cdr bounds)))) - region-bounds)))) - (add-function :after-while isearch-filter-predicate region-filter))) + (setq region-filter (replace--region-filter + (funcall region-extract-function 'bounds))) + (add-function :after-while isearch-filter-predicate region-filter)) ;; If region is active, in Transient Mark mode, operate on region. (if backward @@ -3212,7 +3278,13 @@ characters." (last-command 'recenter-top-bottom)) (recenter-top-bottom))) ((eq def 'edit) - (let ((opos (point-marker))) + (let ((opos (point-marker)) + ;; Restore original isearch filter to allow + ;; using isearch in a recursive edit even + ;; when perform-replace was started from + ;; `xref--query-replace-1' that let-binds + ;; `isearch-filter-predicate' (bug#53758). + (isearch-filter-predicate #'isearch-filter-visible)) (setq real-match-data (replace-match-data nil real-match-data real-match-data)) diff --git a/lisp/rot13.el b/lisp/rot13.el index 2dd53dfb2fd..c063725de85 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/ruler-mode.el b/lisp/ruler-mode.el index afe1cd4bfda..f0efc20f037 100644 --- a/lisp/ruler-mode.el +++ b/lisp/ruler-mode.el @@ -279,21 +279,24 @@ or remove a tab stop. \\[ruler-mode-toggle-show-tab-stops] or (let ((edges (window-edges))) (- (nth 2 edges) (nth 0 edges)))) -(defsubst ruler-mode-window-col (n) +(defsubst ruler-mode-window-col (event) "Return a column number relative to the selected window. -N is a column number relative to selected frame. +EVENT is the mouse event that gives the current column. If required, account for screen estate taken by `display-line-numbers'." - (if display-line-numbers + (let ((n (car (posn-col-row event)))) + (when display-line-numbers ;; FIXME: ruler-mode relies on N being an integer, so if the ;; 'line-number' face is customized to use a font that is larger ;; or smaller than that of the default face, the alignment might ;; be off by up to half a column, unless the font width is an ;; integral multiple or divisor of the default face's font. (setq n (- n (round (line-number-display-width 'columns))))) - (- n - (or (car (window-margins)) 0) - (fringe-columns 'left) - (scroll-bar-columns 'left))) + (- n + (if (eq (posn-area event) 'header-line) + (+ (or (car (window-margins)) 0) + (fringe-columns 'left) + (scroll-bar-columns 'left)) + 0)))) (defun ruler-mode-mouse-set-left-margin (start-event) "Set left margin end to the graduation where the mouse pointer is on. @@ -370,7 +373,7 @@ dragging. See also the variable `ruler-mode-dragged-symbol'." col newc oldc) (save-selected-window (select-window (posn-window start)) - (setq col (ruler-mode-window-col (car (posn-col-row start))) + (setq col (ruler-mode-window-col start) newc (+ col (ruler-mode-text-scaled-window-hscroll))) (and (>= col 0) (< col (ruler-mode-text-scaled-window-width)) @@ -455,7 +458,7 @@ Called on each mouse motion event START-EVENT." col newc) (save-selected-window (select-window (posn-window start)) - (setq col (ruler-mode-window-col (car (posn-col-row end))) + (setq col (ruler-mode-window-col end) newc (+ col (ruler-mode-text-scaled-window-hscroll))) (when (and (>= col 0) (< col (ruler-mode-text-scaled-window-width))) (set ruler-mode-dragged-symbol newc))))) @@ -471,7 +474,7 @@ START-EVENT is the mouse click event." (when (eq start end) ;; mouse click (save-selected-window (select-window (posn-window start)) - (setq col (ruler-mode-window-col (car (posn-col-row start))) + (setq col (ruler-mode-window-col start) ts (+ col (ruler-mode-text-scaled-window-hscroll))) (and (>= col 0) (< col (ruler-mode-text-scaled-window-width)) (not (member ts tab-stop-list)) @@ -492,7 +495,7 @@ START-EVENT is the mouse click event." (when (eq start end) ;; mouse click (save-selected-window (select-window (posn-window start)) - (setq col (ruler-mode-window-col (car (posn-col-row start))) + (setq col (ruler-mode-window-col start) ts (+ col (ruler-mode-text-scaled-window-hscroll))) (and (>= col 0) (< col (ruler-mode-text-scaled-window-width)) (member ts tab-stop-list) diff --git a/lisp/savehist.el b/lisp/savehist.el index aab304007b2..172acaa4e87 100644 --- a/lisp/savehist.el +++ b/lisp/savehist.el @@ -60,14 +60,19 @@ If you want to save only specific histories, use `savehist-save-hook' to modify the value of `savehist-minibuffer-history-variables'." :type 'boolean) -(defcustom savehist-additional-variables () +(defcustom savehist-additional-variables nil "List of additional variables to save. -Each element is a symbol whose value will be persisted across Emacs -sessions that use Savehist. The contents of variables should be -printable with the Lisp printer. You don't need to add minibuffer -history variables to this list, all minibuffer histories will be -saved automatically as long as `savehist-save-minibuffer-history' is -non-nil. +Each element is a variable that will be persisted across Emacs +sessions that use Savehist. + +An element may be variable name (a symbol) or a cons cell of the form +\(VAR . MAX-SIZE), which means to truncate VAR's value to at most +MAX-SIZE elements (if the value is a list) before saving the value. + +The contents of variables should be printable with the Lisp +printer. You don't need to add minibuffer history variables to +this list, all minibuffer histories will be saved automatically +as long as `savehist-save-minibuffer-history' is non-nil. User options should be saved with the Customize interface. This list is useful for saving automatically updated variables that are not @@ -278,12 +283,21 @@ If AUTO-SAVE is non-nil, compare the saved contents to the one last saved, (delete-region (point) (1+ (point))))) (insert "))\n")))))) ;; Save the additional variables. - (dolist (symbol savehist-additional-variables) - (when (boundp symbol) - (let ((value (symbol-value symbol))) - (when (savehist-printable value) - (prin1 `(setq ,symbol ',value) (current-buffer)) - (insert ?\n)))))) + (dolist (elem savehist-additional-variables) + (let ((symbol (if (consp elem) + (car elem) + elem))) + (when (boundp symbol) + (let ((value (symbol-value symbol))) + (when (savehist-printable value) + ;; When we have a max-size, chop off the last elements. + (when (and (consp elem) + (listp value) + (length> value (cdr elem))) + (setq value (copy-sequence value)) + (setcdr (nthcdr (cdr elem) value) nil)) + (prin1 `(setq ,symbol ',value) (current-buffer)) + (insert ?\n))))))) ;; If autosaving, avoid writing if nothing has changed since the ;; last write. (let ((checksum (md5 (current-buffer) nil nil savehist-coding-system))) diff --git a/lisp/saveplace.el b/lisp/saveplace.el index c088facb3c3..a23454b0bb4 100644 --- a/lisp/saveplace.el +++ b/lisp/saveplace.el @@ -290,7 +290,11 @@ may have changed) back to `save-place-alist'." ;; adding hooks to it. (with-current-buffer (get-buffer-create " *Saved Places*") (delete-region (point-min) (point-max)) - (insert-file-contents file) + ;; Make sure our 'coding:' cookie in the save-place + ;; file will take effect, in case the caller binds + ;; coding-system-for-read. + (let (coding-system-for-read) + (insert-file-contents file)) (goto-char (point-min)) (setq save-place-alist (with-demoted-errors "Error reading save-place-file: %S" @@ -328,11 +332,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/scroll-bar.el b/lisp/scroll-bar.el index 3d12723c025..5786a21e88e 100644 --- a/lisp/scroll-bar.el +++ b/lisp/scroll-bar.el @@ -132,8 +132,11 @@ Setting the variable with a customization buffer also takes effect." (define-minor-mode scroll-bar-mode "Toggle vertical scroll bars on all frames (Scroll Bar mode). -This command applies to all frames that exist and frames to be -created in the future." +This command applies to all frames that exist, as well as new +frames to be created in the future. This is done by altering the +frame parameters, so if you (re-)set `default-frame-alist' after +toggling the scroll bars on or off with this command, the scroll +bars may reappear on new frames." :variable ((get-scroll-bar-mode) . (lambda (v) (set-scroll-bar-mode (if v (or previous-scroll-bar-mode diff --git a/lisp/scroll-lock.el b/lisp/scroll-lock.el index d41e3352332..fa1f3a633b5 100644 --- a/lisp/scroll-lock.el +++ b/lisp/scroll-lock.el @@ -30,15 +30,13 @@ ;;; Code: -(defvar scroll-lock-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [remap next-line] 'scroll-lock-next-line) - (define-key map [remap previous-line] 'scroll-lock-previous-line) - (define-key map [remap forward-paragraph] 'scroll-lock-forward-paragraph) - (define-key map [remap backward-paragraph] 'scroll-lock-backward-paragraph) - (define-key map [S-down] 'scroll-lock-next-line-always-scroll) - map) - "Keymap for Scroll Lock mode.") +(defvar-keymap scroll-lock-mode-map + :doc "Keymap for Scroll Lock mode." + "<remap> <next-line>" #'scroll-lock-next-line + "<remap> <previous-line>" #'scroll-lock-previous-line + "<remap> <forward-paragraph>" #'scroll-lock-forward-paragraph + "<remap> <backward-paragraph>" #'scroll-lock-backward-paragraph + "S-<down>" #'scroll-lock-next-line-always-scroll) (defvar-local scroll-lock-preserve-screen-pos-save scroll-preserve-screen-position "Used for saving the state of `scroll-preserve-screen-position'.") @@ -55,7 +53,7 @@ will scroll the buffer by the respective amount of lines instead and point will be kept vertically fixed relative to window boundaries during scrolling. -Note that the default key binding to Scroll_Lock will not work on +Note that the default key binding to `scroll' will not work on MS-Windows systems if `w32-scroll-lock-modifier' is non-nil." :lighter " ScrLck" :keymap scroll-lock-mode-map diff --git a/lisp/select.el b/lisp/select.el index d9efe811a07..df1d4026552 100644 --- a/lisp/select.el +++ b/lisp/select.el @@ -25,9 +25,10 @@ ;; Based partially on earlier release by Lucid. ;; The functionality here is divided in two parts: -;; - Low-level: gui-get-selection, gui-set-selection, gui-selection-owner-p, -;; gui-selection-exists-p are the backend-dependent functions meant to access -;; various kinds of selections (CLIPBOARD, PRIMARY, SECONDARY). +;; - Low-level: gui-backend-get-selection, gui-backend-set-selection, +;; gui-backend-selection-owner-p, gui-backend-selection-exists-p are +;; the backend-dependent functions meant to access various kinds of +;; selections (CLIPBOARD, PRIMARY, SECONDARY). ;; - Higher-level: gui-select-text and gui-selection-value go together to ;; access the general notion of "GUI selection" for interoperation with other ;; applications. This can use either the clipboard or the primary selection, @@ -108,9 +109,10 @@ E.g. it doesn't exist under MS-Windows." :group 'killing :version "25.1") -;; We keep track of the last text selected here, so we can check the -;; current selection against it, and avoid passing back our own text -;; from gui-selection-value. We track both +;; We keep track of the last selection here, so we can check the +;; current selection against it, and avoid passing back with +;; gui-selection-value the same text we previously killed or +;; yanked. We track both ;; separately in case another X application only sets one of them ;; we aren't fooled by the PRIMARY or CLIPBOARD selection staying the same. @@ -119,45 +121,94 @@ E.g. it doesn't exist under MS-Windows." (defvar gui--last-selected-text-primary nil "The value of the PRIMARY selection last seen.") +(defvar gui--last-selection-timestamp-clipboard nil + "The timestamp of the CLIPBOARD selection last seen.") +(defvar gui--last-selection-timestamp-primary nil + "The timestamp of the PRIMARY selection last seen.") + +(defun gui--set-last-clipboard-selection (text) + "Save last clipboard selection. +Save the selected text, passed as argument, and for window +systems that support it, save the selection timestamp too." + (setq gui--last-selected-text-clipboard text) + (when (eq window-system 'x) + (setq gui--last-selection-timestamp-clipboard + (gui-backend-get-selection 'CLIPBOARD 'TIMESTAMP)))) + +(defun gui--set-last-primary-selection (text) + "Save last primary selection. +Save the selected text, passed as argument, and for window +systems that support it, save the selection timestamp too." + (setq gui--last-selected-text-primary text) + (when (eq window-system 'x) + (setq gui--last-selection-timestamp-primary + (gui-backend-get-selection 'PRIMARY 'TIMESTAMP)))) + +(defun gui--clipboard-selection-unchanged-p (text) + "Check whether the clipboard selection has changed. +Compare the selection text, passed as argument, with the text +from the last saved selection. For window systems that support +it, compare the selection timestamp too." + (and + (equal text gui--last-selected-text-clipboard) + (or (not (eq window-system 'x)) + (eq gui--last-selection-timestamp-clipboard + (gui-backend-get-selection 'CLIPBOARD 'TIMESTAMP))))) + +(defun gui--primary-selection-unchanged-p (text) + "Check whether the primary selection has changed. +Compare the selection text, passed as argument, with the text +from the last saved selection. For window systems that support +it, compare the selection timestamp too." + (and + (equal text gui--last-selected-text-primary) + (or (not (eq window-system 'x)) + (eq gui--last-selection-timestamp-primary + (gui-backend-get-selection 'PRIMARY 'TIMESTAMP))))) + + (defun gui-select-text (text) "Select TEXT, a string, according to the window system. -if `select-enable-clipboard' is non-nil, copy TEXT to the system's clipboard. +If `select-enable-clipboard' is non-nil, copy TEXT to the system's clipboard. If `select-enable-primary' is non-nil, put TEXT in the primary selection. MS-Windows does not have a \"primary\" selection." (when select-enable-primary (gui-set-selection 'PRIMARY text) - (setq gui--last-selected-text-primary text)) + (gui--set-last-primary-selection text)) (when select-enable-clipboard ;; When cutting, the selection is cleared and PRIMARY ;; set to the empty string. Prevent that, PRIMARY ;; should not be reset by cut (Bug#16382). (setq saved-region-selection text) (gui-set-selection 'CLIPBOARD text) - (setq gui--last-selected-text-clipboard text))) + (gui--set-last-clipboard-selection text))) (define-obsolete-function-alias 'x-select-text 'gui-select-text "25.1") (defcustom x-select-request-type nil "Data type request for X selection. The value is one of the following data types, a list of them, or nil: - `COMPOUND_TEXT', `UTF8_STRING', `STRING', `TEXT' + `COMPOUND_TEXT', `UTF8_STRING', `STRING', `TEXT', `text/plain\\;charset=utf-8' If the value is one of the above symbols, try only the specified type. If the value is a list of them, try each of them in the specified order until succeed. -The value nil is the same as the list (UTF8_STRING COMPOUND_TEXT STRING)." +The value nil is the same as the list (UTF8_STRING COMPOUND_TEXT STRING +text/plain\\;charset=utf-8)." :type '(choice (const :tag "Default" nil) (const COMPOUND_TEXT) (const UTF8_STRING) (const STRING) (const TEXT) + (const text/plain\;charset=utf-8) (set :tag "List of values" (const COMPOUND_TEXT) (const UTF8_STRING) (const STRING) - (const TEXT))) + (const TEXT) + (const text/plain\;charset=utf-8))) :group 'killing) (defun gui--selection-value-internal (type) @@ -165,20 +216,29 @@ The value nil is the same as the list (UTF8_STRING COMPOUND_TEXT STRING)." Call `gui-get-selection' with an appropriate DATA-TYPE argument decided by `x-select-request-type'. The return value is already decoded. If `gui-get-selection' signals an error, return nil." - (let ((request-type (if (eq window-system 'x) - (or x-select-request-type - '(UTF8_STRING COMPOUND_TEXT STRING)) - 'STRING)) - text) - (with-demoted-errors "gui-get-selection: %S" - (if (consp request-type) - (while (and request-type (not text)) - (setq text (gui-get-selection type (car request-type))) - (setq request-type (cdr request-type))) - (setq text (gui-get-selection type request-type)))) - (if text - (remove-text-properties 0 (length text) '(foreign-selection nil) text)) - text)) + ;; The doc string of `interprogram-paste-function' says to return + ;; nil if no other program has provided text to paste. + (unless (and + ;; `gui-backend-selection-owner-p' might be unreliable on + ;; some other window systems. + (memq window-system '(x haiku)) + (eq type 'CLIPBOARD) + ;; Should we unify this with gui--clipboard-selection-unchanged-p? + (gui-backend-selection-owner-p type)) + (let ((request-type (if (memq window-system '(x pgtk haiku)) + (or x-select-request-type + '(UTF8_STRING COMPOUND_TEXT STRING text/plain\;charset=utf-8)) + 'STRING)) + text) + (with-demoted-errors "gui-get-selection: %S" + (if (consp request-type) + (while (and request-type (not text)) + (setq text (gui-get-selection type (car request-type))) + (setq request-type (cdr request-type))) + (setq text (gui-get-selection type request-type)))) + (if text + (remove-text-properties 0 (length text) '(foreign-selection nil) text)) + text))) (defun gui-selection-value () (let ((clip-text @@ -186,19 +246,17 @@ decoded. If `gui-get-selection' signals an error, return nil." (let ((text (gui--selection-value-internal 'CLIPBOARD))) (when (string= text "") (setq text nil)) - ;; When `select-enable-clipboard' is non-nil, - ;; killing/copying text (with, say, `C-w') will push the - ;; text to the clipboard (and store it in - ;; `gui--last-selected-text-clipboard'). We check - ;; whether the text on the clipboard is identical to this - ;; text, and if so, we report that the clipboard is - ;; empty. See (bug#27442) for further discussion about - ;; this DWIM action, and possible ways to make this check - ;; less fragile, if so desired. - (prog1 - (unless (equal text gui--last-selected-text-clipboard) - text) - (setq gui--last-selected-text-clipboard text))))) + ;; Check the CLIPBOARD selection for 'newness', i.e., + ;; whether it is different from the last time we did a + ;; yank operation or whether it was set by Emacs itself + ;; with a kill operation, since in both cases the text + ;; will already be in the kill ring. See (bug#27442) and + ;; (bug#53894) for further discussion about this DWIM + ;; action, and possible ways to make this check less + ;; fragile, if so desired. + (unless (gui--clipboard-selection-unchanged-p text) + (gui--set-last-clipboard-selection text) + text)))) (primary-text (when select-enable-primary (let ((text (gui--selection-value-internal 'PRIMARY))) @@ -206,10 +264,9 @@ decoded. If `gui-get-selection' signals an error, return nil." ;; Check the PRIMARY selection for 'newness', is it different ;; from what we remembered them to be last time we did a ;; cut/paste operation. - (prog1 - (unless (equal text gui--last-selected-text-primary) - text) - (setq gui--last-selected-text-primary text)))))) + (unless (gui--primary-selection-unchanged-p text) + (gui--set-last-primary-selection text) + text))))) ;; As we have done one selection, clear this now. (setq next-selection-coding-system nil) @@ -224,11 +281,11 @@ decoded. If `gui-get-selection' signals an error, return nil." ;; something like the following has happened since the last time ;; we looked at the selections: Application X set all the ;; selections, then Application Y set only one of them. - ;; In this case since we don't have - ;; timestamps there is no way to know what the 'correct' value to - ;; return is. The nice thing to do would be to tell the user we - ;; saw multiple possible selections and ask the user which was the - ;; one they wanted. + ;; In this case, for systems that support selection timestamps, we + ;; could return the newer. For systems that don't, there is no + ;; way to know what the 'correct' value to return is. The nice + ;; thing to do would be to tell the user we saw multiple possible + ;; selections and ask the user which was the one they wanted. (or clip-text primary-text) )) @@ -304,22 +361,33 @@ 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) + ('text/plain\;charset=utf-8 '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)) @@ -328,16 +396,21 @@ the formats available in the clipboard if TYPE is `CLIPBOARD'." (defun gui-set-selection (type data) "Make an X selection of type TYPE and value DATA. The argument TYPE (nil means `PRIMARY') says which selection, and -DATA specifies the contents. TYPE must be a symbol. \(It can also -be a string, which stands for the symbol with that name, but this -is considered obsolete.) DATA may be a string, a symbol, an -integer (or a cons of two integers or list of two integers). - -The selection may also be a cons of two markers pointing to the same buffer, -or an overlay. In these cases, the selection is considered to be the text -between the markers *at whatever time the selection is examined*. -Thus, editing done in the buffer after you specify the selection -can alter the effective value of the selection. +DATA specifies the contents. TYPE must be a symbol. \(It can +also be a string, which stands for the symbol with that name, but +this is considered obsolete.) DATA may be a string, a symbol, or +an integer. + +The selection may also be a cons of two markers pointing to the +same buffer, or an overlay. In these cases, the selection is +considered to be the text between the markers *at whatever time +the selection is examined*. Thus, editing done in the buffer +after you specify the selection can alter the effective value of +the selection. If DATA is a string, then its text properties can +specify alternative values for different data types. For +example, the value of any property named `text/uri-list' will be +used instead of DATA itself when another program converts TYPE to +the target `text/uri-list'. The data may also be a vector of valid non-vector selection values. @@ -413,7 +486,8 @@ two markers or an overlay. Otherwise, it is nil." (defun xselect--int-to-cons (n) (cons (ash n -16) (logand n 65535))) -(defun xselect--encode-string (type str &optional can-modify) +(defun xselect--encode-string (type str &optional can-modify + prefer-string-to-c-string) (when str ;; If TYPE is nil, this is a local request; return STR as-is. (if (null type) @@ -440,13 +514,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 @@ -463,7 +537,8 @@ two markers or an overlay. Otherwise, it is nil." (if eight-bit 'C_STRING 'STRING)))))))) (cond - ((eq type 'UTF8_STRING) + ((or (eq type 'UTF8_STRING) + (eq type 'text/plain\;charset=utf-8)) (if (or (not coding) (not (eq (coding-system-type coding) 'utf-8))) (setq coding 'utf-8)) @@ -475,6 +550,12 @@ two markers or an overlay. Otherwise, it is nil." (setq coding 'iso-8859-1)) (setq str (encode-coding-string str coding))) + ((eq type 'text/plain) + (if (or (not coding) + (not (eq (coding-system-type coding) 'charset))) + (setq coding 'ascii)) + (setq str (encode-coding-string str coding))) + ((eq type 'COMPOUND_TEXT) (if (or (not coding) (not (eq (coding-system-type coding) 'iso-2022))) @@ -499,7 +580,10 @@ two markers or an overlay. Otherwise, it is nil." (setq str (string-replace "\0" "\\0" str)) (setq next-selection-coding-system nil) - (cons type str)))) + (cons (if (and prefer-string-to-c-string + (eq type 'C_STRING)) + 'STRING type) + str)))) (defun xselect-convert-to-string (_selection type value) (let ((str (cond ((stringp value) value) @@ -517,31 +601,49 @@ two markers or an overlay. Otherwise, it is nil." (if len (xselect--int-to-cons len)))) -(defun xselect-convert-to-targets (_selection _type _value) - ;; return a vector of atoms, but remove duplicates first. - (let* ((all (cons 'TIMESTAMP - (cons 'MULTIPLE - (mapcar 'car selection-converter-alist)))) - (rest all)) - (while rest - (cond ((memq (car rest) (cdr rest)) - (setcdr rest (delq (car rest) (cdr rest)))) - ((eq (car (cdr rest)) '_EMACS_INTERNAL) ; shh, it's a secret - (setcdr rest (cdr (cdr rest)))) - (t - (setq rest (cdr rest))))) - (apply 'vector all))) +(defun xselect-convert-to-targets (selection _type value) + ;; Return a vector of atoms, but remove duplicates first. + (apply #'vector + (delete-dups + `( TIMESTAMP MULTIPLE + . ,(delq '_EMACS_INTERNAL + (mapcar (lambda (conv) + (if (or (not (consp (cdr conv))) + (funcall (cadr conv) selection + (car conv) value)) + (car conv) + '_EMACS_INTERNAL)) + selection-converter-alist)))))) (defun xselect-convert-to-delete (selection _type _value) - (gui-backend-set-selection selection nil) + ;; This should be handled by the caller of `x-begin-drag'. + (unless (eq selection 'XdndSelection) + (gui-backend-set-selection selection nil)) ;; A return value of nil means that we do not know how to do this conversion, ;; and replies with an "error". A return value of NULL means that we have ;; done the conversion (and any side-effects) but have no value to return. 'NULL) -(defun xselect-convert-to-filename (_selection _type value) - (when (setq value (xselect--selection-bounds value)) - (xselect--encode-string 'TEXT (buffer-file-name (nth 2 value))))) +(defun xselect-convert-to-filename (selection _type value) + (if (not (eq selection 'XdndSelection)) + (when (setq value (xselect--selection-bounds value)) + (xselect--encode-string 'TEXT (buffer-file-name (nth 2 value)))) + (if (and (stringp value) + (file-exists-p value)) + (xselect--encode-string 'TEXT (expand-file-name value) + nil t) + (when (vectorp value) + (with-temp-buffer + (cl-loop for file across value + do (progn (insert (encode-coding-string + (expand-file-name file) + file-name-coding-system)) + (insert "\0"))) + ;; Get rid of the last NULL byte. + (when (> (point) 1) + (delete-char -1)) + ;; Motif wants STRING. + (cons 'STRING (buffer-string))))))) (defun xselect-convert-to-charpos (_selection _type value) (when (setq value (xselect--selection-bounds value)) @@ -603,11 +705,85 @@ This function returns the string \"emacs\"." (when (eq selection 'CLIPBOARD) 'NULL)) +(defun xselect-convert-to-username (_selection _type _value) + (user-real-login-name)) + +(defun xselect-convert-to-text-uri-list (_selection _type value) + (if (stringp value) + (concat (url-encode-url value) "\n") + (when (vectorp value) + (with-temp-buffer + (cl-loop for tem across value + do (progn + (insert (url-encode-url tem)) + (insert "\n"))) + (buffer-string))))) + +(defun xselect-convert-to-xm-file (selection _type value) + (when (and (stringp value) + (file-exists-p value) + (eq selection 'XdndSelection)) + (xselect--encode-string 'C_STRING + (concat value [0])))) + +(defun xselect-uri-list-available-p (selection _type value) + "Return whether or not `text/uri-list' is a valid target for SELECTION. +VALUE is the local selection value of SELECTION." + (and (eq selection 'XdndSelection) + (or (stringp value) + (vectorp value)))) + +(defun xselect-convert-xm-special (_selection _type _value) + "") + +(defun xselect-dt-netfile-available-p (selection _type value) + "Return whether or not `_DT_NETFILE' is a valid target for SELECTION. +VALUE is SELECTION's local selection value." + (and (eq selection 'XdndSelection) + (stringp value) + (file-exists-p value) + (not (file-remote-p value)))) + +(defun xselect-tt-net-file (file) + "Get the canonical ToolTalk filename for FILE. +FILE must be a local file, or otherwise the conversion will fail. +The string returned has three components: the hostname of the +machine where the file is, the real path, and the local path. +They are encoded into a string of the form +\"HOST=0-X,RPATH=X-Y,LPATH=Y-Z:DATA\", where X, Y, and Z are the +positions of the hostname, rpath and lpath inside DATA." + (let ((hostname (system-name)) + (rpath file) + (lpath file)) + (format "HOST=0-%d,RPATH=%d-%d,LPATH=%d-%d:%s%s%s" + (1- (length hostname)) (length hostname) + (1- (+ (length hostname) (length rpath))) + (+ (length hostname) (length rpath)) + (1- (+ (length hostname) (length rpath) + (length lpath))) + hostname rpath lpath))) + +(defun xselect-convert-to-dt-netfile (selection _type value) + "Convert SELECTION to a ToolTalk filename. +VALUE should be SELECTION's local value." + (when (and (eq selection 'XdndSelection) + (stringp value) + (file-exists-p value) + (not (file-remote-p value))) + (xselect-tt-net-file value))) + (setq selection-converter-alist '((TEXT . xselect-convert-to-string) (COMPOUND_TEXT . xselect-convert-to-string) (STRING . xselect-convert-to-string) (UTF8_STRING . xselect-convert-to-string) + (text/plain . xselect-convert-to-string) + (text/plain\;charset=utf-8 . xselect-convert-to-string) + (text/uri-list . (xselect-uri-list-available-p + . xselect-convert-to-text-uri-list)) + (text/x-xdnd-username . xselect-convert-to-username) + (FILE . (xselect-uri-list-available-p + . xselect-convert-to-xm-file)) (TARGETS . xselect-convert-to-targets) (LENGTH . xselect-convert-to-length) (DELETE . xselect-convert-to-delete) @@ -623,7 +799,11 @@ This function returns the string \"emacs\"." (ATOM . xselect-convert-to-atom) (INTEGER . xselect-convert-to-integer) (SAVE_TARGETS . xselect-convert-to-save-targets) - (_EMACS_INTERNAL . xselect-convert-to-identity))) + (_EMACS_INTERNAL . xselect-convert-to-identity) + (XmTRANSFER_SUCCESS . xselect-convert-xm-special) + (XmTRANSFER_FAILURE . xselect-convert-xm-special) + (_DT_NETFILE . (xselect-convert-to-dt-netfile + . xselect-dt-netfile-available-p)))) (provide 'select) diff --git a/lisp/server.el b/lisp/server.el index 65602cd1a11..8f47a99a31a 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. @@ -779,7 +779,8 @@ by the current Emacs process, use the `server-process' variable." (condition-case nil (if server-use-tcp (with-temp-buffer - (insert-file-contents-literally (expand-file-name name server-auth-dir)) + (setq default-directory server-auth-dir) + (insert-file-contents-literally (expand-file-name name)) (or (and (looking-at "127\\.0\\.0\\.1:[0-9]+ \\([0-9]+\\)") (assq 'comm (process-attributes @@ -900,12 +901,17 @@ This handles splitting the command if it would be bigger than ) (cond (w - (server--create-frame - nowait proc - `((display . ,display) - ,@(if parent-id - `((parent-id . ,(string-to-number parent-id)))) - ,@parameters))) + (condition-case nil + (server--create-frame + nowait proc + `((display . ,display) + ,@(if parent-id + `((parent-id . ,(string-to-number parent-id)))) + ,@parameters)) + (error + (server-log "Window system unsupported" proc) + (server-send-string proc "-window-system-unsupported \n") + nil))) (t (server-log "Window system unsupported" proc) @@ -1361,7 +1367,7 @@ The following commands are accepted by the client: ((functionp initial-buffer-choice) (funcall initial-buffer-choice))))) (switch-to-buffer - (if (buffer-live-p buf) buf (get-buffer-create "*scratch*")) + (if (buffer-live-p buf) buf (get-scratch-buffer-create)) 'norecord))) ;; Delete the client if necessary. @@ -1580,13 +1586,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 +1722,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 +1733,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 542fb3d7c87..ba965ff8a5b 100644 --- a/lisp/ses.el +++ b/lisp/ses.el @@ -84,17 +84,14 @@ (defcustom ses-initial-size '(1 . 1) "Initial size of a new spreadsheet, as a cons (NUMROWS . NUMCOLS)." - :group 'ses :type '(cons (integer :tag "numrows") (integer :tag "numcols"))) (defcustom ses-initial-column-width 7 "Initial width of columns in a new spreadsheet." - :group 'ses :type '(integer :match (lambda (widget value) (> value 0)))) (defcustom ses-initial-default-printer "%.7g" "Initial default printer for a new spreadsheet." - :group 'ses :type '(choice string (list :tag "Parenthesized string" string) function)) @@ -103,15 +100,30 @@ "Things to do after entering a value into a cell. An abnormal hook that usually runs a cursor-movement function. Each function is called with ARG=1." - :group 'ses :type 'hook :options '(forward-char backward-char next-line previous-line)) (defcustom ses-mode-hook nil "Hook functions to be run upon entering SES mode." - :group 'ses :type 'hook) +(defcustom ses-jump-cell-name-function #'upcase + "Function to process the string passed to function `ses-jump'. +Set it to `identity' to make no change. +Set it to `upcase' to make cell name change case isensitive. + + May return + +* a string, in this case this must be a cell name. +* a (row . col) cons cell, in this case that must be valid cell coordinates." + :type 'function) + +(defcustom ses-jump-prefix-function #'ses-jump-prefix + "Function that takes the prefix argument passed to function `ses-jump'. +It may return the same sort of thing as `ses-jump-cell-name-function'." + :type 'function) + + ;;---------------------------------------------------------------------------- ;; Global variables and constants @@ -227,26 +239,18 @@ 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 (suppress-keymap newmap t) ;;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 (substring numeric x (1+ x)) #'ses-read-cell)) + (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)) @@ -353,7 +357,7 @@ printer and then modify its output.") (t (error "Unexpected elements `%S' in list `ses-localvars'" x))))) ;;; This variable is documented as being permitted in file-locals: -(put 'ses--symbolic-formulas 'safe-local-variable 'consp) +(put 'ses--symbolic-formulas 'safe-local-variable #'consp) (defconst ses-paramlines-plist '(ses--col-widths -5 ses--col-printers -4 ses--default-printer -3 @@ -1064,8 +1068,7 @@ the old and FORCE is nil." (defcustom ses-self-reference-early-detection nil "Non-nil if cycle detection is early for cells that refer to themselves." :version "24.1" - :type 'boolean - :group 'ses) + :type 'boolean) (defun ses-update-cells (list &optional force) "Recalculate cells in LIST, checking for dependency loops. @@ -2072,8 +2075,8 @@ formula: ;; Not to use tab characters for safe (tabs may do bad for column ;; calculation). indent-tabs-mode nil) - (1value (add-hook 'change-major-mode-hook 'ses-cleanup nil t)) - (1value (add-hook 'kill-buffer-hook 'ses-killbuffer-hook nil t)) + (1value (add-hook 'change-major-mode-hook #'ses-cleanup nil t)) + (1value (add-hook 'kill-buffer-hook #'ses-killbuffer-hook nil t)) (cl-pushnew (current-buffer) ses--ses-buffer-list :test 'eq) ;; This makes revert impossible if the buffer is read-only. ;; (1value (add-hook 'before-revert-hook 'ses-cleanup nil t)) @@ -2124,8 +2127,8 @@ formula: ;; find-alternate-file, post-command-hook doesn't get run for some reason, ;; so use an idle timer to make sure. (setq ses--deferred-narrow 'ses-mode) - (1value (add-hook 'post-command-hook 'ses-command-hook nil t)) - (run-with-idle-timer 0.01 nil 'ses-command-hook) + (1value (add-hook 'post-command-hook #'ses-command-hook nil t)) + (run-with-idle-timer 0.01 nil #'ses-command-hook) (run-mode-hooks 'ses-mode-hook))) (put 'ses-mode 'mode-class 'special) @@ -2241,24 +2244,43 @@ Based on the current set of columns and `window-hscroll' position." ;;---------------------------------------------------------------------------- ;; Redisplay and recalculation ;;---------------------------------------------------------------------------- +(defun ses-jump-prefix (prefix-int) + "Convert an integer (unversal prefix) into a (ROW . COL). +Does it by numbering cells starting from 0 from top left to bottom right, +going row by row." + (and (>= prefix-int 0) + (< prefix-int (* ses--numcols ses--numrows)) + (cons (/ prefix-int ses--numcols) (% prefix-int ses--numcols)))) + -(defun ses-jump (sym) +(defun ses-jump (&optional sym) "Move point to cell SYM." - (interactive (let* (names - (s (completing-read - "Jump to cell: " - (and ses--named-cell-hashmap - (progn (maphash (lambda (key _val) - (push (symbol-name key) names)) - ses--named-cell-hashmap) - names))))) - (if (string= s "") - (user-error "Invalid cell name") - (list (intern s))))) - (let ((rowcol (ses-sym-rowcol sym))) + (interactive "P") + (setq sym + (if current-prefix-arg + (funcall ses-jump-prefix-function (prefix-numeric-value sym)) + (or sym + (completing-read + "Jump to cell: " + (and ses--named-cell-hashmap + (let (names) + (maphash (lambda (key _val) + (push (symbol-name key) names)) + ses--named-cell-hashmap) + names)))))) + (and (stringp sym) + (not (and ses--named-cell-hashmap (gethash (intern sym) ses--named-cell-hashmap))) + (setq sym (funcall ses-jump-cell-name-function sym))) + (if (stringp sym) + (if (string= sym "") + (user-error "Empty cell name") + (setq sym (intern sym)))) + (let ((rowcol (if (consp sym) + (prog1 sym (setq sym (ses-cell-symbol (car sym) (cdr sym)))) + (ses-sym-rowcol sym)))) (or rowcol (error "Invalid cell name")) (if (eq (symbol-value sym) '*skip*) - (error "Cell is covered by preceding cell")) + (error "Cell is covered by preceding cell")) (ses-goto-print (car rowcol) (cdr rowcol)))) (defun ses-jump-safe (cell) @@ -2309,7 +2331,7 @@ Narrow to print area if optional argument NONARROW is nil." "Recalculate and reprint the current cell or range. If CURCELL is non nil use it as current cell or range -without any check, otherwise function (ses-check-curcell 'range) +without any check, otherwise function (ses-check-curcell \\='range) is called. For an individual cell, shows the error if the formula or printer @@ -2515,7 +2537,7 @@ Return nil if cell formula was unsafe and user declined confirmation." ;; Position cursor inside close-quote. (setq initial (cons initial (length initial)))) (dolist (key ses-completion-keys) - (define-key ses-mode-edit-map key 'ses-edit-cell-complete-symbol)) + (define-key ses-mode-edit-map key #'ses-edit-cell-complete-symbol)) ;; make it globally visible, so that it can be visible from the minibuffer. (setq ses--completion-table ses--named-cell-hashmap) (list row col @@ -2612,8 +2634,9 @@ With prefix, deletes several cells." ;;---------------------------------------------------------------------------- (defun ses-read-printer-complete-symbol () (interactive) - (let ((completion-at-point-functions (cons 'ses--read-printer-completion-at-point-function - completion-at-point-functions))) + (let ((completion-at-point-functions + (cons #'ses--read-printer-completion-at-point-function + completion-at-point-functions))) (completion-at-point))) (defun ses--read-printer-completion-at-point-function () @@ -2655,7 +2678,7 @@ canceled." (setq default "") (setq prompt (format-prompt prompt default))) (dolist (key ses-completion-keys) - (define-key ses-mode-edit-map key 'ses-read-printer-complete-symbol)) + (define-key ses-mode-edit-map key #'ses-read-printer-complete-symbol)) ;; make it globally visible, so that it can be visible from the minibuffer. (setq ses--completion-table ses--local-printer-hashmap) (let ((new (read-from-minibuffer prompt @@ -3554,7 +3577,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))) @@ -3751,15 +3774,15 @@ DEFINITION shall be either a string formatter, e.g.: \"%.2f\" or (\"%.2f\") for left alignment. or a lambda expression, e.g. for formatting in ISO format dates -created with a '(calcFunc-date YEAR MONTH DAY)' formula: +created with a `(calcFunc-date YEAR MONTH DAY)' formula: (lambda (x) (cond ((null val) \"\") - ((eq (car-safe x) 'date) - (let ((calc-format-date '(X YYYY \"-\" MM \"-\" DD))) + ((eq (car-safe x) \\='date) + (let ((calc-format-date \\='(X YYYY \"-\" MM \"-\" DD))) (math-format-date x))) - (t (ses-center-span val ?# 'ses-prin1)))) + (t (ses-center-span val ?# \\='ses-prin1)))) If NAME is already used to name a local printer function, then the current definition is proposed as default value, and the @@ -3774,7 +3797,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))) @@ -4085,17 +4110,19 @@ SPAN indicates how many rightward columns to include in width (default = 0)." (ses-center value span ?- printer)) (defun ses-dashfill-span (value &optional printer) - "Print VALUE, centered using dashes within the span that starts in the -current column and continues until the next nonblank column." + "Print VALUE, centered using dashes. +Centers within the span that starts in the current column and continues +until the next nonblank column." (ses-center-span value ?- printer)) (defun ses-tildefill-span (value &optional printer) - "Print VALUE, centered using tildes within the span that starts in the -current column and continues until the next nonblank column." + "Print VALUE, centered using tildes. +Centers within the span that starts in the current column and continues +until the next nonblank column." (ses-center-span value ?~ printer)) (defun ses-prin1 (value) - "Shorthand for '(prin1-to-string VALUE t)'. + "Shorthand for `(prin1-to-string VALUE t)'. Useful to handle the default behavior in custom lambda based printer functions." (prin1-to-string value t)) diff --git a/lisp/shell.el b/lisp/shell.el index f0115b90a50..8bcc578406a 100644 --- a/lisp/shell.el +++ b/lisp/shell.el @@ -98,6 +98,7 @@ (require 'comint) (require 'pcomplete) (eval-when-compile (require 'files-x)) ;with-connection-local-variables +(require 'subr-x) ;;; Customization and Buffer Variables @@ -330,6 +331,12 @@ Useful for shells like zsh that has this feature." :group 'shell-directories :version "28.1") +(defcustom shell-kill-buffer-on-exit nil + "Kill a shell buffer after the shell process terminates." + :type 'boolean + :group 'shell + :version "29.1") + (defvar shell-mode-map (let ((map (make-sparse-keymap))) (define-key map "\C-c\C-f" 'shell-forward-command) @@ -527,7 +534,7 @@ Shell buffers. It implements `shell-completion-execonly' for the shell. This is useful for entering passwords. Or, add the function `comint-watch-for-password-prompt' to `comint-output-filter-functions'. -If you want to make multiple shell buffers, rename the `*shell*' buffer +If you want to make multiple shell buffers, rename the \"*shell*\" buffer using \\[rename-buffer] or \\[rename-uniquely] and start a new shell. If you want to make shell buffers limited in length, add the function @@ -570,7 +577,14 @@ the initialization of the input ring history, and history expansion. Variables `comint-output-filter-functions', a hook, and `comint-scroll-to-bottom-on-input' and `comint-scroll-to-bottom-on-output' control whether input and output cause the window to scroll to the end of the -buffer." +buffer. + +By default, shell mode does nothing special when it receives a +\"bell\" character (C-g or ^G). If you + (add-hook \\='comint-output-filter-functions #\\='shell-filter-ring-bell nil t) +from `shell-mode-hook', Emacs will call the `ding' function +whenever it receives the bell character in output from a +command." :interactive nil (setq comint-prompt-regexp shell-prompt-pattern) (shell-completion-vars) @@ -681,6 +695,13 @@ This function can be put on `comint-preoutput-filter-functions'." (replace-regexp-in-string "[\C-a\C-b]" "" string t t) string)) +(defun shell-filter-ring-bell (string) + "Call `ding' if STRING contains a \"^G\" character. +This function can be put on `comint-output-filter-functions'." + (when (string-search "\a" string) + (ding)) + string) + (defun shell-write-history-on-exit (process event) "Called when the shell process is stopped. @@ -698,7 +719,7 @@ Sentinels will always get the two parameters PROCESS and EVENT." (insert (format "\nProcess %s %s\n" process event)))))) ;;;###autoload -(defun shell (&optional buffer) +(defun shell (&optional buffer file-name) "Run an inferior shell, with I/O through BUFFER (which defaults to `*shell*'). Interactively, a prefix arg means to prompt for BUFFER. If `default-directory' is a remote file name, it is also prompted @@ -709,6 +730,8 @@ If BUFFER exists and shell process is running, just switch to BUFFER. Program used comes from variable `explicit-shell-file-name', or (if that is nil) from the ESHELL environment variable, or (if that is nil) from `shell-file-name'. +Non-interactively, it can also be specified via the FILE-NAME arg. + If a file `~/.emacs_SHELLNAME' exists, or `~/.emacs.d/init_SHELLNAME.sh', it is given as initial input (but this may be lost, due to a timing error, if the shell discards input when it starts up). @@ -732,25 +755,47 @@ Make the shell buffer the current buffer, and return it. \(Type \\[describe-mode] in the shell buffer for a list of commands.)" (interactive - (list - (and current-prefix-arg - (prog1 - (read-buffer "Shell buffer: " - ;; If the current buffer is an inactive - ;; shell buffer, use it as the default. - (if (and (eq major-mode 'shell-mode) - (null (get-buffer-process (current-buffer)))) - (buffer-name) - (generate-new-buffer-name "*shell*"))) - (if (file-remote-p default-directory) - ;; It must be possible to declare a local default-directory. - ;; FIXME: This can't be right: it changes the default-directory - ;; of the current-buffer rather than of the *shell* buffer. - (setq default-directory - (expand-file-name - (read-directory-name - "Default directory: " default-directory default-directory - t nil)))))))) + (let* ((buffer + (and current-prefix-arg + (read-buffer "Shell buffer: " + ;; If the current buffer is an inactive + ;; shell buffer, use it as the default. + (if (and (eq major-mode 'shell-mode) + (null (get-buffer-process + (current-buffer)))) + (buffer-name) + (generate-new-buffer-name "*shell*"))))) + (buf (if (or buffer (not (derived-mode-p 'shell-mode)) + (comint-check-proc (current-buffer))) + (get-buffer-create (or buffer "*shell*")) + ;; If the current buffer is a dead shell buffer, use it. + (current-buffer)))) + + (with-current-buffer buf + (when (and buffer (file-remote-p default-directory)) + ;; It must be possible to declare a local default-directory. + (setq default-directory + (expand-file-name + (read-directory-name + "Default directory: " default-directory default-directory + t nil)))) + (list + buffer + ;; On remote hosts, the local `shell-file-name' might be useless. + (with-connection-local-variables + (when (and (file-remote-p default-directory) + (null explicit-shell-file-name) + (null (getenv "ESHELL"))) + ;; `expand-file-name' shall not add the MS Windows volume letter + ;; (Bug#49229). + (replace-regexp-in-string + "^[[:alpha:]]:" "" + (file-local-name + (expand-file-name + (read-file-name "Remote shell path: " default-directory + shell-file-name t shell-file-name + #'file-remote-p)))))))))) + (setq buffer (if (or buffer (not (derived-mode-p 'shell-mode)) (comint-check-proc (current-buffer))) (get-buffer-create (or buffer "*shell*")) @@ -758,24 +803,11 @@ Make the shell buffer the current buffer, and return it. (current-buffer))) ;; The buffer's window must be correctly set when we call comint ;; (so that comint sets the COLUMNS env var properly). - (pop-to-buffer-same-window buffer) + (pop-to-buffer buffer display-comint-buffer-action) (with-connection-local-variables - ;; On remote hosts, the local `shell-file-name' might be useless. - (when (and (file-remote-p default-directory) - (called-interactively-p 'any) - (null explicit-shell-file-name) - (null (getenv "ESHELL"))) - ;; `expand-file-name' shall not add the MS Windows volume letter - ;; (Bug#49229). - (setq-local explicit-shell-file-name - (replace-regexp-in-string - "^[[:alpha:]]:" "" - (file-local-name - (expand-file-name - (read-file-name "Remote shell path: " default-directory - shell-file-name t shell-file-name - #'file-remote-p)))))) + (when file-name + (setq-local explicit-shell-file-name file-name)) ;; Rain or shine, BUFFER must be current by now. (unless (comint-check-proc buffer) @@ -783,16 +815,37 @@ Make the shell buffer the current buffer, and return it. (getenv "ESHELL") shell-file-name)) (name (file-name-nondirectory prog)) (startfile (concat "~/.emacs_" name)) - (xargs-name (intern-soft (concat "explicit-" name "-args")))) + (xargs-name (intern-soft (concat "explicit-" name "-args"))) + (start-point (point))) (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) + nil (if (and xargs-name (boundp xargs-name)) (symbol-value xargs-name) '("-i"))) - (shell-mode)))) + (shell-mode) + (when (file-exists-p startfile) + ;; Wait until the prompt has appeared. + (while (= start-point (point)) + (sleep-for 0.1)) + (shell-eval-command + (with-temp-buffer + (insert-file-contents startfile) + (buffer-string))))))) + (when shell-kill-buffer-on-exit + (let* ((buffer (current-buffer)) + (process (get-buffer-process buffer)) + (sentinel (process-sentinel process))) + (set-process-sentinel + process + (lambda (proc event) + (when sentinel + (funcall sentinel proc event)) + (unless (buffer-live-p proc) + (kill-buffer buffer)))))) buffer) ;;; Directory tracking @@ -1008,7 +1061,9 @@ Environment variables are expanded, see function `substitute-in-file-name'." "Toggle directory tracking in this shell buffer (Shell Dirtrack mode). The `dirtrack' package provides an alternative implementation of -this feature; see the function `dirtrack-mode'." +this feature; see the function `dirtrack-mode'. Also see +`comint-osc-directory-tracker' for an escape-sequence based +solution." :lighter nil (setq list-buffers-directory (if shell-dirtrack-mode default-directory)) (if shell-dirtrack-mode @@ -1025,61 +1080,45 @@ this feature; see the function `dirtrack-mode'." "Resync the buffer's idea of the current directory stack. This command queries the shell with the command bound to `shell-dirstack-query' (default \"dirs\"), reads the next -line output and parses it to form the new directory stack. -DON'T issue this command unless the buffer is at a shell prompt. -Also, note that if some other subprocess decides to do output -immediately after the query, its output will be taken as the -new directory stack -- you lose. If this happens, just do the -command again." +line output and parses it to form the new directory stack." (interactive) - (let* ((proc (get-buffer-process (current-buffer))) - (pmark (process-mark proc)) - (started-at-pmark (= (point) (marker-position pmark)))) - (save-excursion - (goto-char pmark) - ;; If the process echoes commands, don't insert a fake command in - ;; the buffer or it will appear twice. - (unless comint-process-echoes - (insert shell-dirstack-query) (insert "\n")) - (sit-for 0) ; force redisplay - (comint-send-string proc shell-dirstack-query) - (comint-send-string proc "\n") - (set-marker pmark (point)) - (let ((pt (point)) - (regexp - (concat - (if comint-process-echoes - ;; Skip command echo if the process echoes - (concat "\\(" (regexp-quote shell-dirstack-query) "\n\\)") - "\\(\\)") - "\\(.+\n\\)"))) - ;; This extra newline prevents the user's pending input from spoofing us. - (insert "\n") (backward-char 1) - ;; Wait for one line. - (while (not (looking-at regexp)) - (accept-process-output proc) - (goto-char pt))) - (goto-char pmark) (delete-char 1) ; remove the extra newline - ;; That's the dirlist. grab it & parse it. - (let* ((dl (buffer-substring (match-beginning 2) (1- (match-end 2)))) - (dl-len (length dl)) - (ds '()) ; new dir stack - (i 0)) - (while (< i dl-len) - ;; regexp = optional whitespace, (non-whitespace), optional whitespace - (string-match "\\s *\\(\\S +\\)\\s *" dl i) ; pick off next dir - (setq ds (cons (concat comint-file-name-prefix - (substring dl (match-beginning 1) - (match-end 1))) - ds)) - (setq i (match-end 0))) - (let ((ds (nreverse ds))) - (with-demoted-errors "Couldn't cd: %s" - (shell-cd (car ds)) - (setq shell-dirstack (cdr ds) - shell-last-dir (car shell-dirstack)) - (shell-dirstack-message))))) - (if started-at-pmark (goto-char (marker-position pmark))))) + (let* ((dls (car + (last + (string-lines + (string-chop-newline + (shell-eval-command (concat shell-dirstack-query "\n"))))))) + (dlsl nil) + (pos 0) + (ds nil)) + ;; Split the dirlist into whitespace and non-whitespace chunks. + ;; dlsl will be a reversed list of tokens. + (while (string-match "\\(\\S-+\\|\\s-+\\)" dls pos) + (push (match-string 1 dls) dlsl) + (setq pos (match-end 1))) + + ;; Prepend trailing entries until they form an existing directory, + ;; whitespace and all. Discard the next whitespace and repeat. + (while dlsl + (let ((newelt "") + tem1 tem2) + (while newelt + ;; We need tem1 because we don't want to prepend + ;; `comint-file-name-prefix' repeatedly into newelt via tem2. + (setq tem1 (pop dlsl) + tem2 (concat comint-file-name-prefix tem1 newelt)) + (cond ((file-directory-p tem2) + (push tem2 ds) + (when (string= " " (car dlsl)) + (pop dlsl)) + (setq newelt nil)) + (t + (setq newelt (concat tem1 newelt))))))) + + (with-demoted-errors "Couldn't cd: %s" + (shell-cd (car ds)) + (setq shell-dirstack (cdr ds) + shell-last-dir (car shell-dirstack)) + (shell-dirstack-message)))) ;; For your typing convenience: (defalias 'dirs 'shell-resync-dirs) @@ -1414,6 +1453,36 @@ Returns t if successful." (point-max) (shell--prompt-begin-position)))))) +(defun shell-eval-command (command) + "Eval COMMAND in the current shell process and return the result." + (let* ((proc (get-buffer-process (current-buffer))) + (old-filter (process-filter proc)) + (result "") + prev) + (unwind-protect + (progn + (set-process-filter + proc + (lambda (_proc string) + (setq result (concat result string)))) + (process-send-string proc command) + ;; Wait until we get a prompt (which will be a line without + ;; a newline). This is far from fool-proof -- if something + ;; outputs incomplete data and then sleeps, we'll think + ;; we've received the prompt. + (while (not (let* ((lines (string-lines result)) + (last (car (last lines)))) + (and (length> lines 0) + (not (equal last "")) + (or (not prev) + (not (equal last prev))) + (setq prev last)))) + (accept-process-output proc 0 100))) + ;; Restore old filter. + (set-process-filter proc old-filter)) + ;; Remove the prompt. + (replace-regexp-in-string "\n.*\\'" "\n" result))) + (provide 'shell) ;;; shell.el ends here diff --git a/lisp/simple.el b/lisp/simple.el index d235eb9745a..a22df8025b3 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -60,6 +60,24 @@ value of 1 means that nothing is amalgamated.") (defgroup paren-matching nil "Highlight (un)matching of parens and expressions." :group 'matching) + +(defvar-local escaped-string-quote "\\" + "String to insert before a string quote character in a string to escape it. +This is typically a backslash (in most languages): + + \\='foo\\\\='bar\\=' + \"foo\\\"bar\" + +But in SQL, for instance, it's \"\\='\": + + \\='foo\\='\\='bar\\=' + +This can also be a function, which is called with the string +terminator as the argument, and should return a string to be +used as the escape. + +This variable is used by the `yank-in-context' command.") + ;;; next-error support framework @@ -494,7 +512,7 @@ buffer causes automatic display of the corresponding source code location." (error t)))) (defun next-error-message-highlight (error-buffer) - "Highlight the current error message in the ‘next-error’ buffer." + "Highlight the current error message in the `next-error' buffer." (when next-error-message-highlight (with-current-buffer error-buffer (when (and next-error--message-highlight-overlay @@ -527,21 +545,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 +728,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 +739,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"))) @@ -1062,15 +1090,26 @@ Leave one space or none, according to the context." "Delete all spaces and tabs around point. If BACKWARD-ONLY is non-nil, delete them only before point." (interactive "*P") + (delete-space--internal " \t" backward-only)) + +(defun delete-all-space (&optional backward-only) + "Delete all spaces, tabs, and newlines around point. +If BACKWARD-ONLY is non-nil, delete them only before point." + (interactive "*P") + (delete-space--internal " \t\r\n" backward-only)) + +(defun delete-space--internal (chars backward-only) + "Delete CHARS around point. +If BACKWARD-ONLY is non-nil, delete them only before point." (let ((orig-pos (point))) (delete-region (if backward-only - orig-pos + orig-pos (progn - (skip-chars-forward " \t") - (constrain-to-field nil orig-pos t))) + (skip-chars-forward chars) + (constrain-to-field nil orig-pos t))) (progn - (skip-chars-backward " \t") + (skip-chars-backward chars) (constrain-to-field nil orig-pos))))) (defun just-one-space (&optional n) @@ -1078,73 +1117,225 @@ If BACKWARD-ONLY is non-nil, delete them only before point." If N is negative, delete newlines as well, leaving -N spaces. See also `cycle-spacing'." (interactive "*p") - (cycle-spacing n nil 'single-shot)) + (let ((orig-pos (point)) + (skip-characters (if (and n (< n 0)) " \t\n\r" " \t")) + (num (abs (or n 1)))) + (skip-chars-backward skip-characters) + (constrain-to-field nil orig-pos) + (let* ((num (- num (skip-chars-forward " " (+ num (point))))) + (mid (point)) + (end (progn + (skip-chars-forward skip-characters) + (constrain-to-field nil orig-pos t)))) + (delete-region mid end) + (insert (make-string num ?\s))))) (defvar cycle-spacing--context nil - "Store context used in consecutive calls to `cycle-spacing' command. -The first time `cycle-spacing' runs, it saves in this variable: -its N argument, the original point position, and the original spacing -around point.") - -(defun cycle-spacing (&optional n preserve-nl-back mode) + "Stored context used in consecutive calls to `cycle-spacing' command. +The value is a property list with the following elements: +- `:orig-pos' The original position of point when starting the + sequence. +- `:whitespace-string' All whitespace characters around point + including newlines. +- `:n' The prefix arg given to the initial invocation + which is reused for all actions in this cycle. +- `:last-action' The last action performed in the cycle.") + +(defcustom cycle-spacing-actions + '( just-one-space + delete-all-space + restore) + "List of actions cycled through by `cycle-spacing'. +Supported values are: +- `just-one-space' Delete all but N (prefix arg) spaces. + See that command's docstring for details. +- `delete-space-after' Delete spaces after point keeping only N. +- `delete-space-before' Delete spaces before point keeping only N. +- `delete-all-space' Delete all spaces around point. +- `restore' Restore the original spacing. + +All actions make use of the prefix arg given to `cycle-spacing' +in the initial invocation, i.e., `just-one-space' keeps this +amount of spaces deleting surplus ones. `just-one-space' and all +other actions have the contract that a positive prefix arg (or +zero) only deletes tabs and spaces whereas a negative prefix arg +also deletes newlines. + +The `delete-space-before' and `delete-space-after' actions handle +the prefix arg \\[negative-argument] without a number provided +specially: all spaces before/after point are deleted (as if N was +0) including newlines (as if N was negative). + +In addition to the predefined actions listed above, any function +which accepts one argument is allowed. It receives the raw +prefix arg of this cycle. + +In addition, an action may take the form (ACTION ARG) where +ACTION is one of the predefined actions (except for `restore') +and ARG is either +- an integer with the meaning that ACTION should always use this + fixed integer instead of the actual prefix arg or +- the symbol `inverted-arg' with the meaning that ACTION should + be performed with the inverted actual prefix arg. +- the symbol `-' with the meaning that ACTION should include + newlines but it's up to the ACTION to decide how to interpret + it as a number, e.g., `delete-space-before' and + `delete-space-after' treat it like 0 whereas `just-one-space' + treats it like -1 as is usual." + :group 'editing-basics + :type (let ((actions + '((const :tag "Just N (prefix arg) spaces" just-one-space) + (const :tag "Delete spaces after point" delete-space-after) + (const :tag "Delete spaces before point" delete-space-before) + (const :tag "Delete all spaces around point" delete-all-space) + (function :tag "Function receiving a numeric arg")))) + `(repeat + (choice + ,@actions + (list :tag "Action with modified arg" + (choice ,@actions) + (choice (const :tag "Inverted prefix arg" inverted-arg) + (integer :tag "Fixed numeric arg") + (const :tag "Negative arg" -))) + (const :tag "Restore the original spacing" restore)))) + :version "29.1") + +(defun cycle-spacing (&optional n) "Manipulate whitespace around point in a smart way. -In interactive use, this function behaves differently in successive -consecutive calls. - -The first call in a sequence acts like `just-one-space'. -It deletes all spaces and tabs around point, leaving one space -\(or N spaces). N is the prefix argument. If N is negative, -it deletes newlines as well, leaving -N spaces. -\(If PRESERVE-NL-BACK is non-nil, it does not delete newlines before point.) - -The second call in a sequence deletes all spaces. - -The third call in a sequence restores the original whitespace (and point). - -If MODE is `single-shot', it performs only the first step in the sequence. -If MODE is `fast' and the first step would not result in any change -\(i.e., there are exactly (abs N) spaces around point), -the function goes straight to the second step. - -Repeatedly calling the function with different values of N starts a -new sequence each time." - (interactive "*p") - (let ((orig-pos (point)) - (skip-characters (if (and n (< n 0)) " \t\n\r" " \t")) - (num (abs (or n 1)))) - (skip-chars-backward (if preserve-nl-back " \t" skip-characters)) - (constrain-to-field nil orig-pos) - (cond - ;; Command run for the first time, single-shot mode or different argument - ((or (eq 'single-shot mode) - (not (equal last-command this-command)) - (not cycle-spacing--context) - (not (eq (car cycle-spacing--context) n))) - (let* ((start (point)) - (num (- num (skip-chars-forward " " (+ num (point))))) - (mid (point)) - (end (progn - (skip-chars-forward skip-characters) - (constrain-to-field nil orig-pos t)))) - (setq cycle-spacing--context ;; Save for later. - ;; Special handling for case where there was no space at all. - (unless (= start end) - (cons n (cons orig-pos (buffer-substring start (point)))))) - ;; If this run causes no change in buffer content, delete all spaces, - ;; otherwise delete all excess spaces. - (delete-region (if (and (eq mode 'fast) (zerop num) (= mid end)) - start mid) end) - (insert (make-string num ?\s)))) - - ;; Command run for the second time. - ((not (equal orig-pos (point))) - (delete-region (point) orig-pos)) - - ;; Command run for the third time. - (t - (insert (cddr cycle-spacing--context)) - (goto-char (cadr cycle-spacing--context)) - (setq cycle-spacing--context nil))))) +Repeated calls perform the actions in `cycle-spacing-actions' one +after the other, wrapping around after the last one. + +All actions are amendable using a prefix arg N. In general, a +zero or positive prefix arg allows only for deletion of tabs and +spaces whereas a negative prefix arg also allows for deleting +newlines. + +The prefix arg given at the first invocation starting a cycle is +provided to all following actions, i.e., + \\[negative-argument] \\[cycle-spacing] \\[cycle-spacing] \\[cycle-spacing] +is equivalent to + \\[negative-argument] \\[cycle-spacing] \\[negative-argument] \\[cycle-spacing] \\[negative-argument] \\[cycle-spacing]. + +A new sequence can be started by providing a different prefix arg +than provided at the initial invocation (except for 1), or by +doing any other command before the next \\[cycle-spacing]." + (interactive "*P") + ;; Initialize `cycle-spacing--context' if needed. + (when (or (not (equal last-command this-command)) + (not cycle-spacing--context) + ;; With M-5 M-SPC M-SPC... we pass the prefix arg 5 to + ;; each action and only start a new cycle when a different + ;; prefix arg is given and which is not the default value + ;; 1. + (and n (not (equal (plist-get cycle-spacing--context :n) + n)))) + (let ((orig-pos (point)) + (skip-characters " \t\n\r")) + (save-excursion + (skip-chars-backward skip-characters) + (constrain-to-field nil orig-pos) + (let ((start (point)) + (end (progn + (skip-chars-forward skip-characters) + (constrain-to-field nil orig-pos t)))) + (setq cycle-spacing--context ;; Save for later. + (list :orig-pos orig-pos + :whitespace-string (buffer-substring start end) + :n n + :last-action nil)))))) + + ;; Cycle through the actions in `cycle-spacing-actions'. + (when cycle-spacing--context + (cl-labels ((next-action () + (let* ((l cycle-spacing-actions) + (elt (plist-get cycle-spacing--context + :last-action))) + (if (null elt) + (car cycle-spacing-actions) + (catch 'found + (while l + (cond + ((null (cdr l)) + (throw 'found + (when (eq elt (car l)) + (car cycle-spacing-actions)))) + ((and (eq elt (car l)) + (cdr l)) + (throw 'found (cadr l))) + (t (setq l (cdr l))))))))) + (skip-chars (chars max-dist direction) + (if (eq direction 'forward) + (skip-chars-forward + chars + (and max-dist (+ (point) max-dist))) + (skip-chars-backward + chars + (and max-dist (- (point) max-dist))))) + (delete-space (n include-newlines direction) + (let ((orig-point (point)) + (chars (if include-newlines + " \t\r\n" + " \t"))) + (when (or (zerop n) + (= n (abs (skip-chars chars n direction)))) + (let ((start (point)) + (end (progn + (skip-chars chars nil direction) + (point)))) + (unless (= start end) + (delete-region start end)) + (goto-char (if (eq direction 'forward) + orig-point + (+ n end))))))) + (restore () + (delete-all-space) + (insert (plist-get cycle-spacing--context + :whitespace-string)) + (goto-char (plist-get cycle-spacing--context + :orig-pos)))) + (let ((action (next-action))) + (atomic-change-group + (restore) + (unless (eq action 'restore) + ;; action can be some-action or (some-action <arg>) where + ;; arg is either an integer, the arg to be always used for + ;; this action or - to use the inverted context n for this + ;; action. + (let* ((actual-action (if (listp action) + (car action) + action)) + (arg (when (listp action) + (nth 1 action))) + (context-n (plist-get cycle-spacing--context :n)) + (actual-n (cond + ((integerp arg) arg) + ((eq 'inverted-arg arg) + (* -1 (prefix-numeric-value context-n))) + ((eq '- arg) '-) + (t context-n))) + (numeric-n (prefix-numeric-value actual-n)) + (include-newlines (or (eq actual-n '-) + (and (integerp actual-n) + (< actual-n 0))))) + (cond + ((eq actual-action 'just-one-space) + (just-one-space numeric-n)) + ((eq actual-action 'delete-space-after) + (delete-space (if (eq actual-n '-) 0 (abs numeric-n)) + include-newlines 'forward)) + ((eq actual-action 'delete-space-before) + (delete-space (if (eq actual-n '-) 0 (abs numeric-n)) + include-newlines 'backward)) + ((eq actual-action 'delete-all-space) + (if include-newlines + (delete-all-space) + (delete-horizontal-space))) + ((functionp actual-action) + (funcall actual-action actual-n)) + (t + (error "Don't know how to handle action %S" action))))) + (setf (plist-get cycle-spacing--context :last-action) + action)))))) (defun beginning-of-buffer (&optional arg) "Move point to the beginning of the buffer. @@ -1282,6 +1473,11 @@ If Transient Mark mode is enabled, the mark is active, and N is 1, delete the text in the region and deactivate the mark instead. To disable this, set variable `delete-active-region' to nil. +If N is positive, characters composed into a single grapheme cluster +count as a single character and are deleted together. Thus, +\"\\[universal-argument] 2 \\[delete-forward-char]\" when two grapheme clusters follow point will +delete the characters composed into both of the grapheme clusters. + Optional second arg KILLFLAG non-nil means to kill (save in kill ring) instead of delete. If called interactively, a numeric prefix argument specifies N, and KILLFLAG is also set if a prefix @@ -1302,6 +1498,21 @@ the actual saved text might be different from what was killed." (kill-region (region-beginning) (region-end) 'region) (funcall region-extract-function 'delete-only))) + ;; For forward deletion, treat composed characters as a single + ;; character to delete. + ((>= n 1) + (let ((pos (point)) + start cmp) + (setq start pos) + (while (> n 0) + ;; 'find-composition' will return (FROM TO ....) or nil. + (setq cmp (find-composition pos)) + (if cmp + (setq pos (cadr cmp)) + (setq pos (1+ pos))) + (setq n (1- n))) + (delete-char (- pos start) killflag))) + ;; Otherwise, do simple deletion. (t (delete-char n killflag)))) @@ -1447,48 +1658,64 @@ START and END." (cond ((not (called-interactively-p 'any)) (count-words start end)) (arg - (count-words--buffer-message)) + (message "%s" (count-words--buffer-format))) (t - (count-words--message "Region" start end)))) + (message "%s" (count-words--format "Region" start end))))) -(defun count-words (start end) +(defun count-words (start end &optional totals) "Count words between START and END. If called interactively, START and END are normally the start and end of the buffer; but if the region is active, START and END are the start and end of the region. Print a message reporting the -number of lines, words, and chars. +number of lines, sentences, words, and chars. With prefix +argument, also include the data for the entire (un-narrowed) +buffer. If called from Lisp, return the number of words between START and -END, without printing any message." - (interactive (list nil nil)) - (cond ((not (called-interactively-p 'any)) - (let ((words 0) - ;; Count across field boundaries. (Bug#41761) - (inhibit-field-text-motion t)) - (save-excursion - (save-restriction - (narrow-to-region start end) - (goto-char (point-min)) - (while (forward-word-strictly 1) - (setq words (1+ words))))) - words)) - ((use-region-p) - (call-interactively 'count-words-region)) - (t - (count-words--buffer-message)))) - -(defun count-words--buffer-message () - (count-words--message +END, without printing any message. TOTALS is ignored when called +from Lisp." + (interactive (list nil nil current-prefix-arg)) + ;; When called from Lisp, return the data. + (if (not (called-interactively-p 'any)) + (let ((words 0) + ;; Count across field boundaries. (Bug#41761) + (inhibit-field-text-motion t)) + (save-excursion + (save-restriction + (narrow-to-region start end) + (goto-char (point-min)) + (while (forward-word-strictly 1) + (setq words (1+ words))))) + words) + ;; When called interactively, message the data. + (let ((totals (if (and totals + (or (use-region-p) + (buffer-narrowed-p))) + (save-restriction + (widen) + (count-words--format "; buffer in total" + (point-min) (point-max))) + ""))) + (if (use-region-p) + (message "%s%s" (count-words--format + "Region" (region-beginning) (region-end)) + totals) + (message "%s%s" (count-words--buffer-format) totals))))) + +(defun count-words--buffer-format () + (count-words--format (if (buffer-narrowed-p) "Narrowed part of buffer" "Buffer") (point-min) (point-max))) -(defun count-words--message (str start end) +(defun count-words--format (str start end) (let ((lines (count-lines start end)) + (sentences (count-sentences start end)) (words (count-words start end)) (chars (- end start))) - (message "%s has %d line%s, %d word%s, and %d character%s." + (format "%s has %d line%s, %d sentence%s, %d word%s, and %d character%s" str lines (if (= lines 1) "" "s") + sentences (if (= sentences 1) "" "s") words (if (= words 1) "" "s") chars (if (= chars 1) "" "s")))) @@ -2314,6 +2541,49 @@ maps." (with-suppressed-warnings ((interactive-only execute-extended-command)) (execute-extended-command prefixarg command-name typed))) +(cl-defgeneric function-documentation (function) + "Extract the raw docstring info from FUNCTION. +FUNCTION is expected to be a function value rather than, say, a mere symbol. +This is intended to be specialized via `cl-defmethod' but not called directly: +if you need a function's documentation use `documentation' which will call this +function as needed." + (let ((docstring-p (lambda (doc) + ;; A docstring can be either a string or a reference + ;; into either the `etc/DOC' or a `.elc' file. + (or (stringp doc) + (fixnump doc) (fixnump (cdr-safe doc)))))) + (pcase function + ((pred byte-code-function-p) + (when (> (length function) 4) + (let ((doc (aref function 4))) + (when (funcall docstring-p doc) doc)))) + ((or (pred stringp) (pred vectorp)) "Keyboard macro.") + (`(keymap . ,_) + "Prefix command (definition is a keymap associating keystrokes with commands).") + ((or `(lambda ,_args . ,body) `(closure ,_env ,_args . ,body) + `(autoload ,_file . ,body)) + (let ((doc (car body))) + (when (and (funcall docstring-p doc) + ;; Handle a doc reference--but these never come last + ;; in the function body, so reject them if they are last. + (or (cdr body) (eq 'autoload (car-safe function)))) + doc))) + (_ (signal 'invalid-function (list function)))))) + +(cl-defmethod function-documentation ((function accessor)) + (oclosure--accessor-docstring function)) ;; FIXME: η-reduce! + +;; This should be in `oclosure.el' but that file is loaded before `cl-generic'. +(cl-defgeneric oclosure-interactive-form (_function) + "Return the interactive form of FUNCTION or nil if none. +This is called by `interactive-form' when invoked on OClosures. +It should return either nil or a two-element list of the form (interactive FORM) +where FORM is like the first arg of the `interactive' special form. +Add your methods to this generic function, but always call `interactive-form' +instead." + ;; (interactive-form function) + nil) + (defun command-execute (cmd &optional record-flag keys special) ;; BEWARE: Called directly from the C code. "Execute CMD as an editor command. @@ -2338,12 +2608,17 @@ don't clear it." (setq current-prefix-arg prefix-arg) (setq prefix-arg nil) (when current-prefix-arg - (prefix-command-update)))))) + (prefix-command-update))))) + query) (if (and (symbolp cmd) (get cmd 'disabled) - disabled-command-function) - ;; FIXME: Weird calling convention! - (run-hooks 'disabled-command-function) + (or (and (setq query (and (consp (get cmd 'disabled)) + (eq (car (get cmd 'disabled)) 'query))) + (not (command-execute--query cmd))) + (and (not query) disabled-command-function))) + (when (not query) + ;; FIXME: Weird calling convention! + (run-hooks 'disabled-command-function)) (let ((final cmd)) (while (progn @@ -2367,6 +2642,21 @@ don't clear it." (put cmd 'command-execute-obsolete-warned t) (message "%s" (macroexp--obsolete-warning cmd (get cmd 'byte-obsolete-info) "command")))))))))) + +(defun command-execute--query (command) + "Query the user whether to run COMMAND." + (let ((query (get command 'disabled))) + (funcall (if (nth 1 query) #'yes-or-no-p #'y-or-n-p) + (nth 2 query)))) + +;;;###autoload +(defun command-query (command query &optional verbose) + "Make executing COMMAND issue QUERY to the user. +This will, by default, use `y-or-n-p', but if VERBOSE, +`yes-or-no-p' is used instead." + (put command 'disabled + (list 'query (not (not verbose)) query))) + (defvar minibuffer-history nil "Default minibuffer history list. @@ -2777,6 +3067,7 @@ Intended to be added to `minibuffer-setup-hook'." #'minibuffer-history-isearch-wrap) (setq-local isearch-push-state-function #'minibuffer-history-isearch-push-state) + (setq-local isearch-lazy-count nil) (add-hook 'isearch-mode-end-hook 'minibuffer-history-isearch-end nil t)) (defun minibuffer-history-isearch-end () @@ -2912,12 +3203,12 @@ the minibuffer contents." (defconst undo-equiv-table (make-hash-table :test 'eq :weakness t) "Table mapping redo records to the corresponding undo one. -A redo record for an undo in region maps to 'undo-in-region. +A redo record for an undo in region maps to `undo-in-region'. A redo record for ordinary undo maps to the following (earlier) undo. A redo record that undoes to the beginning of the undo list maps to t. In the rare case where there are (erroneously) consecutive nil's in `buffer-undo-list', `undo' maps the previous valid undo record to -'empty, if the previous record is a redo record, `undo' doesn't change +`empty', if the previous record is a redo record, `undo' doesn't change its mapping. To be clear, a redo record is just an undo record, the only difference @@ -3105,7 +3396,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) @@ -3827,7 +4118,10 @@ to the end of the list of defaults just after the default value." (defvar minibuffer-local-shell-command-map (let ((map (make-sparse-keymap))) (set-keymap-parent map minibuffer-local-map) - (define-key map "\t" 'completion-at-point) + (define-key map "\t" #'completion-at-point) + (define-key map [M-up] #'minibuffer-previous-completion) + (define-key map [M-down] #'minibuffer-next-completion) + (define-key map [?\M-\r] #'minibuffer-choose-completion) map) "Keymap used for completing shell commands in minibuffer.") @@ -4082,6 +4376,10 @@ interactively when the prefix argument is given), insert the output in current buffer after point leaving mark after it. This cannot be done asynchronously. +If OUTPUT-BUFFER is a buffer or buffer name different from the +current buffer, instead of outputting at point in that buffer, +the output will be appended at the end of that buffer. + The user option `shell-command-dont-erase-buffer', which see, controls whether the output buffer is erased and where to put point after the shell command. @@ -4193,25 +4491,21 @@ impose the use of a shell (with its need to quote arguments)." (cond ((eq async-shell-command-buffer 'confirm-kill-process) ;; If will kill a process, query first. - (if (yes-or-no-p "A command is running in the default buffer. Kill it? ") - (kill-process proc) - (user-error "Shell command in progress"))) + (shell-command--same-buffer-confirm "Kill it") + (kill-process proc)) ((eq async-shell-command-buffer 'confirm-new-buffer) ;; If will create a new buffer, query first. - (if (yes-or-no-p "A command is running in the default buffer. Use a new buffer? ") - (setq buffer (generate-new-buffer bname)) - (user-error "Shell command in progress"))) + (shell-command--same-buffer-confirm "Use a new buffer") + (setq buffer (generate-new-buffer bname))) ((eq async-shell-command-buffer 'new-buffer) ;; It will create a new buffer. (setq buffer (generate-new-buffer bname))) ((eq async-shell-command-buffer 'confirm-rename-buffer) ;; If will rename the buffer, query first. - (if (yes-or-no-p "A command is running in the default buffer. Rename it? ") - (progn - (with-current-buffer buffer - (rename-uniquely)) - (setq buffer (get-buffer-create bname))) - (user-error "Shell command in progress"))) + (shell-command--same-buffer-confirm "Rename it") + (with-current-buffer buffer + (rename-uniquely)) + (setq buffer (get-buffer-create bname))) ((eq async-shell-command-buffer 'rename-buffer) ;; It will rename the buffer. (with-current-buffer buffer @@ -4259,6 +4553,24 @@ impose the use of a shell (with its need to quote arguments)." (shell-command-on-region (point) (point) command output-buffer nil error-buffer))))))) +(defun shell-command--same-buffer-confirm (action) + (let ((help-form + (format + "There's a command already running in the default buffer, +so we can't start a new one in the same one. + +Answering \"yes\" will %s. + +Answering \"no\" will exit without doing anything, and won't +start the new command. + +Also see the `async-shell-command-buffer' variable." + (downcase action)))) + (unless (yes-or-no-p + (format "A command is running in the default buffer. %s? " + action)) + (user-error "Shell command in progress")))) + (defun max-mini-window-lines (&optional frame) "Compute maximum number of lines for echo area in FRAME. As defined by `max-mini-window-height'. FRAME defaults to the @@ -4693,6 +5005,8 @@ File name handlers might not support pty association, if PROGRAM is nil." (forward-line -1) (beginning-of-line)))) +(declare-function thread-name "thread.c") + (defun list-processes--refresh () "Recompute the list of processes for the Process List buffer. Also, delete any process that is exited or signaled." @@ -5070,10 +5384,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.") @@ -5351,7 +5666,7 @@ This command's old key binding has been given to `kill-ring-save'." (let ((str (if region (funcall region-extract-function nil) (filter-buffer-substring beg end)))) - (if (eq last-command 'kill-region) + (if (eq last-command 'kill-region) (kill-append str (< end beg)) (kill-new str))) (setq deactivate-mark t) @@ -5634,6 +5949,15 @@ See also `yank-handled-properties'." :group 'killing :version "24.3") +(defvar yank-transform-functions nil + "Hook run on strings to be yanked. +Each function in this list will be called (in order) with the +string to be yanked as the sole argument, and should return the (possibly) +transformed string. + +The functions will be called with the destination buffer as the current +buffer, and with point at the place where the string is to be inserted.") + (defvar yank-window-start nil) (defvar yank-undo-function nil "If non-nil, function used by `yank-pop' to delete last stretch of yanked text. @@ -5705,6 +6029,11 @@ property, as described below. Properties listed in `yank-handled-properties' are processed, then those listed in `yank-excluded-properties' are discarded. +STRING will be run through `yank-transform-functions'. +`yank-in-context' is a command that uses this mechanism to +provide a `yank' alternative that conveniently preserves +string/comment syntax. + If STRING has a non-nil `yank-handler' property anywhere, the normal insert behavior is altered, and instead, for each contiguous segment of STRING that has a given value of the `yank-handler' @@ -5755,6 +6084,88 @@ With ARG, rotate that many kills forward (or backward, if negative)." (interactive "p") (current-kill arg)) +(defun yank-in-context (&optional arg) + "Insert the last stretch of killed text while preserving syntax. +In particular, if point is inside a string, any quote characters +in the killed text will be quoted, so that the string remains a +valid string. + +If point is inside a comment, ensure that the inserted text is +also marked as a comment. + +This command otherwise behaves as `yank'. See that command for +explanation of ARG. + +This function uses the `escaped-string-quote' buffer-local +variable to determine how strings should be escaped." + (interactive "*P") + (let ((yank-transform-functions (cons #'yank-in-context--transform + yank-transform-functions))) + (yank arg))) + +(defun yank-in-context--transform (string) + (let ((ppss (syntax-ppss))) + (cond + ;; We're in a string. + ((ppss-string-terminator ppss) + (string-replace + (string (ppss-string-terminator ppss)) + (concat (if (functionp escaped-string-quote) + (funcall escaped-string-quote + (ppss-string-terminator ppss)) + escaped-string-quote) + (string (ppss-string-terminator ppss))) + string)) + ;; We're in a comment. + ((or (ppss-comment-depth ppss) + (and (bolp) + (not (eobp)) + ;; If we're in the middle of a bunch of commented text, + ;; we probably want to be commented. This is quite DWIM. + (or (bobp) + (save-excursion + (forward-line -1) + (forward-char 1) + (ppss-comment-depth (syntax-ppss)))) + (ppss-comment-depth + (setq ppss (save-excursion + (forward-char 1) + (syntax-ppss)))))) + (cond + ((and (eq (ppss-comment-depth ppss) t) + (> (length comment-end) 0) + (string-search comment-end string)) + (user-error "Can't insert a string containing a comment terminator in a comment")) + ;; If this is a comment syntax that has an explicit end, then + ;; we can just insert as is. + ((> (length comment-end) 0) string) + ;; Line-based comment formats. + ((or (string-search "\n" string) + (bolp)) + (let ((mode major-mode) + (bolp (bolp)) + (eolp (eolp)) + (comment-style 'plain)) + (with-temp-buffer + (funcall mode) + (insert string) + (when (string-match-p "\n\\'" string) + (cond + ((not eolp) (delete-char -1)) + (bolp (insert "\n")))) + (comment-normalize-vars) + (comment-region-default-1 + (if bolp + (point-min) + (save-excursion + (goto-char (point-min)) + (forward-line 1) + (point))) + (point-max)) + (buffer-string)))) + (t string))) + (t string)))) + (defvar read-from-kill-ring-history) (defun read-from-kill-ring (prompt) "Read a `kill-ring' entry using completion and minibuffer history. @@ -5893,7 +6304,7 @@ Delete ARG chars, and kill (save in kill ring) if KILLP is non-nil. If Transient Mark mode is enabled, the mark is active, and ARG is 1, delete the text in the region and deactivate the mark instead. -To disable this, set option ‘delete-active-region’ to nil. +To disable this, set option `delete-active-region' to nil. Interactively, ARG is the prefix arg (default 1) and KILLP is t if a prefix arg was specified." @@ -5923,21 +6334,34 @@ and KILLP is t if a prefix arg was specified." ;; Avoid warning about delete-backward-char (with-no-warnings (delete-backward-char n killp)))) -(defun zap-to-char (arg char) +(defun char-uppercase-p (char) + "Return non-nil if CHAR is an upper-case character. +If the Unicode tables are not yet available, e.g. during bootstrap, +then gives correct answers only for ASCII characters." + (cond ((unicode-property-table-internal 'lowercase) + (characterp (get-char-code-property char 'lowercase))) + ((and (>= char ?A) (<= char ?Z))))) + +(defun zap-to-char (arg char &optional interactive) "Kill up to and including ARGth occurrence of CHAR. +When run interactively, the argument INTERACTIVE is non-nil. Case is ignored if `case-fold-search' is non-nil in the current buffer. Goes backward if ARG is negative; error if CHAR not found. -See also `zap-up-to-char'." +See also `zap-up-to-char'. +If called interactively, do a case sensitive search if CHAR +is an upper-case character." (interactive (list (prefix-numeric-value current-prefix-arg) (read-char-from-minibuffer "Zap to char: " - nil 'read-char-history))) + nil 'read-char-history) + t)) ;; Avoid "obsolete" warnings for translation-table-for-input. (with-no-warnings (if (char-table-p translation-table-for-input) (setq char (or (aref translation-table-for-input char) char)))) - (kill-region (point) (progn - (search-forward (char-to-string char) nil nil arg) - (point)))) + (let ((case-fold-search (if (and interactive (char-uppercase-p char)) + nil + case-fold-search))) + (kill-region (point) (search-forward (char-to-string char) nil nil arg)))) ;; kill-line and its subroutines. @@ -6412,27 +6836,38 @@ An example is a rectangular region handled as a list of separate contiguous regions for each line." (cdr (region-bounds))) +(defun redisplay--unhighlight-overlay-function (rol) + "If ROL is an overlay, call `delete-overlay'." + (when (overlayp rol) (delete-overlay rol))) + (defvar redisplay-unhighlight-region-function - (lambda (rol) (when (overlayp rol) (delete-overlay rol)))) + #'redisplay--unhighlight-overlay-function + "Function to remove the region-highlight overlay.") + +(defun redisplay--highlight-overlay-function (start end window rol &optional face) + "Update the overlay ROL in WINDOW with FACE in range START-END." + (unless face (setq face 'region)) + (if (not (overlayp rol)) + (let ((nrol (make-overlay start end))) + (funcall redisplay-unhighlight-region-function rol) + (overlay-put nrol 'window window) + (overlay-put nrol 'face face) + ;; Normal priority so that a large region doesn't hide all the + ;; overlays within it, but high secondary priority so that if it + ;; ends/starts in the middle of a small overlay, that small overlay + ;; won't hide the region's boundaries. + (overlay-put nrol 'priority '(nil . 100)) + nrol) + (unless (eq (overlay-get rol 'face) face) + (overlay-put rol 'face face)) + (unless (and (eq (overlay-buffer rol) (current-buffer)) + (eq (overlay-start rol) start) + (eq (overlay-end rol) end)) + (move-overlay rol start end (current-buffer))) + rol)) (defvar redisplay-highlight-region-function - (lambda (start end window rol) - (if (not (overlayp rol)) - (let ((nrol (make-overlay start end))) - (funcall redisplay-unhighlight-region-function rol) - (overlay-put nrol 'window window) - (overlay-put nrol 'face 'region) - ;; Normal priority so that a large region doesn't hide all the - ;; overlays within it, but high secondary priority so that if it - ;; ends/starts in the middle of a small overlay, that small overlay - ;; won't hide the region's boundaries. - (overlay-put nrol 'priority '(nil . 100)) - nrol) - (unless (and (eq (overlay-buffer rol) (current-buffer)) - (eq (overlay-start rol) start) - (eq (overlay-end rol) end)) - (move-overlay rol start end (current-buffer))) - rol)) + #'redisplay--highlight-overlay-function "Function to move the region-highlight overlay. This function is called with four parameters, START, END, WINDOW and OVERLAY. If OVERLAY is nil, a new overlay is created. In @@ -6457,8 +6892,33 @@ The overlay is returned by the function.") (funcall redisplay-highlight-region-function start end window rol))) (unless (equal new rol) - (set-window-parameter window 'internal-region-overlay - new)))))) + (set-window-parameter window 'internal-region-overlay new)))))) + +(defcustom cursor-face-highlight-nonselected-window nil + "Non-nil means highlight text with `cursor-face' even in nonselected windows. +This variable is similar to `highlight-nonselected-windows'." + :local t + :type 'boolean + :version "29.1") + +(defun redisplay--update-cursor-face-highlight (window) + "Highlights the overlay used to highlight text with cursor-face." + (let ((rol (window-parameter window 'internal-cursor-face-overlay))) + (if-let* (((or cursor-face-highlight-nonselected-window + (eq window (selected-window)) + (and (window-minibuffer-p) + (eq window (minibuffer-selected-window))))) + (pt (window-point window)) + (cursor-face (get-text-property pt 'cursor-face))) + (let* ((start (previous-single-property-change + (1+ pt) 'cursor-face nil (point-min))) + (end (next-single-property-change + pt 'cursor-face nil (point-max))) + (new (redisplay--highlight-overlay-function + start end window rol cursor-face))) + (unless (equal new rol) + (set-window-parameter window 'internal-cursor-face-overlay new))) + (redisplay--unhighlight-overlay-function rol)))) (defvar pre-redisplay-functions (list #'redisplay--update-region-highlight) "Hook run just before redisplay. @@ -6466,6 +6926,15 @@ It is called in each window that is to be redisplayed. It takes one argument, which is the window that will be redisplayed. When run, the `current-buffer' is set to the buffer displayed in that window.") +(define-minor-mode cursor-face-highlight-mode + "When enabled, respect the cursor-face property." + :global nil + (if cursor-face-highlight-mode + (add-hook 'pre-redisplay-functions + #'redisplay--update-cursor-face-highlight nil t) + (remove-hook 'pre-redisplay-functions + #'redisplay--update-cursor-face-highlight t))) + (defun redisplay--pre-redisplay-functions (windows) (with-demoted-errors "redisplay--pre-redisplay-functions: %S" (if (null windows) @@ -6475,9 +6944,11 @@ is set to the buffer displayed in that window.") (with-current-buffer (window-buffer win) (run-hook-with-args 'pre-redisplay-functions win)))))) -(add-function :before pre-redisplay-function - #'redisplay--pre-redisplay-functions) - +(when (eq pre-redisplay-function #'ignore) + ;; Override the default set in the C code. + ;; This is not done using `add-function' so as to loosen the bootstrap + ;; dependencies. + (setq pre-redisplay-function #'redisplay--pre-redisplay-functions)) (defvar-local mark-ring nil "The list of former marks of the current buffer, most recent first.") @@ -8266,7 +8737,8 @@ Just \\[universal-argument] as argument means to use the current column." ;; We used to use current-column silently, but C-x f is too easily ;; typed as a typo for C-x C-f, so we turned it into an error and ;; now an interactive prompt. - (read-number "Set fill-column to: " (current-column))))) + (read-number (format "Change fill-column from %s to: " fill-column) + (current-column))))) (if (consp arg) (setq arg (current-column))) (if (not (integerp arg)) @@ -8573,40 +9045,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. @@ -8899,7 +9374,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)) @@ -8967,6 +9442,7 @@ makes it easier to edit it." (define-key map [down-mouse-2] nil) (define-key map "\C-m" 'choose-completion) (define-key map "\e\e\e" 'delete-completion-window) + (define-key map [remap keyboard-quit] #'delete-completion-window) (define-key map [left] 'previous-completion) (define-key map [right] 'next-completion) (define-key map [?\t] 'next-completion) @@ -8997,6 +9473,16 @@ Its value is a list of the form (START END) where START is the place where the completion should be inserted and END (if non-nil) is the end of the text to replace. If END is nil, point is used instead.") +(defvar completion-base-affixes nil + "Base context of the text corresponding to the shown completions. +This variable is used in the *Completions* buffer. +Its value is a list of the form (PREFIX SUFFIX) where PREFIX is the text +before the place where completion should be inserted, and SUFFIX is the text +after the completion.") + +(defvar completion-use-base-affixes nil + "Non-nil means to restore original prefix and suffix in the minibuffer.") + (defvar completion-list-insert-choice-function #'completion--replace "Function to use to insert the text chosen in *Completions*. Called with three arguments (BEG END TEXT), it should replace the text @@ -9014,73 +9500,160 @@ Go to the window from which completion was requested." (if (get-buffer-window buf) (select-window (get-buffer-window buf)))))) +(defcustom completion-wrap-movement t + "Non-nil means to wrap around when selecting completion options. +This affects the commands `next-completion' and +`previous-completion'." + :type 'boolean + :version "29.1" + :group 'completion) + +(defcustom completion-auto-select nil + "Non-nil means to automatically select the *Completions* buffer. +When the value is t, pressing TAB will switch to the completion list +buffer when Emacs pops up a window showing that buffer. +If the value is `second-tab', then the first TAB will pop up the +window showing the completions list buffer, and the next TAB will +switch to that window. +See `completion-auto-help' for controlling when the window showing +the completions is popped up and down." + :type '(choice (const :tag "Don't auto-select completions window" nil) + (const :tag "Select completions window on first TAB" t) + (const :tag "Select completions window on second TAB" + second-tab)) + :version "29.1" + :group 'completion) + +(defun first-completion () + "Move to the first item in the completion list." + (interactive) + (goto-char (point-min)) + (unless (get-text-property (point) 'mouse-face) + (when-let ((pos (next-single-property-change (point) 'mouse-face))) + (goto-char pos)))) + +(defun last-completion () + "Move to the last item in the completion list." + (interactive) + (goto-char (previous-single-property-change + (point-max) 'mouse-face nil (point-min))) + ;; Move to the start of last one. + (unless (get-text-property (point) 'mouse-face) + (when-let ((pos (previous-single-property-change (point) 'mouse-face))) + (goto-char pos)))) + (defun previous-completion (n) - "Move to the previous item in the completion list." + "Move to the previous item in the completion list. +With prefix argument N, move back N items (negative N means move +forward). + +Also see the `completion-wrap-movement' variable." (interactive "p") (next-completion (- n))) (defun next-completion (n) "Move to the next item in the completion list. -With prefix argument N, move N items (negative N means move backward)." +With prefix argument N, move N items (negative N means move +backward). + +Also see the `completion-wrap-movement' variable." (interactive "p") - (let ((beg (point-min)) (end (point-max))) - (while (and (> n 0) (not (eobp))) - ;; If in a completion, move to the end of it. - (when (get-text-property (point) 'mouse-face) - (goto-char (next-single-property-change (point) 'mouse-face nil end))) - ;; Move to start of next one. - (unless (get-text-property (point) 'mouse-face) - (goto-char (next-single-property-change (point) 'mouse-face nil end))) - (setq n (1- n))) - (while (and (< n 0) (not (bobp))) - (let ((prop (get-text-property (1- (point)) 'mouse-face))) - ;; If in a completion, move to the start of it. - (when (and prop (eq prop (get-text-property (point) 'mouse-face))) - (goto-char (previous-single-property-change - (point) 'mouse-face nil beg))) - ;; Move to end of the previous completion. - (unless (or (bobp) (get-text-property (1- (point)) 'mouse-face)) - (goto-char (previous-single-property-change - (point) 'mouse-face nil beg))) - ;; Move to the start of that one. - (goto-char (previous-single-property-change - (point) 'mouse-face nil beg)) - (setq n (1+ n)))))) - -(defun choose-completion (&optional event) + (let ((tabcommand (member (this-command-keys) '("\t" [backtab]))) + pos) + (catch 'bound + (while (> n 0) + (setq pos (point)) + ;; If in a completion, move to the end of it. + (when (get-text-property pos 'mouse-face) + (setq pos (next-single-property-change pos 'mouse-face))) + (when pos (setq pos (next-single-property-change pos 'mouse-face))) + (if pos + ;; Move to the start of next one. + (goto-char pos) + ;; If at the last completion option, wrap or skip + ;; to the minibuffer, if requested. + (when completion-wrap-movement + (if (and (eq completion-auto-select t) tabcommand + (minibufferp completion-reference-buffer)) + (throw 'bound nil) + (first-completion)))) + (setq n (1- n))) + + (while (< n 0) + (setq pos (point)) + ;; If in a completion, move to the start of it. + (when (and (get-text-property pos 'mouse-face) + (not (bobp)) + (get-text-property (1- pos) 'mouse-face)) + (setq pos (previous-single-property-change pos 'mouse-face))) + (when pos (setq pos (previous-single-property-change pos 'mouse-face))) + (if pos + (progn + (goto-char pos) + ;; Move to the start of that one. + (unless (get-text-property (point) 'mouse-face) + (goto-char (previous-single-property-change + (point) 'mouse-face nil (point-min))))) + ;; If at the first completion option, wrap or skip + ;; to the minibuffer, if requested. + (when completion-wrap-movement + (if (and (eq completion-auto-select t) tabcommand + (minibufferp completion-reference-buffer)) + (progn + (throw 'bound nil)) + (last-completion)))) + (setq n (1+ n)))) + + (when (/= 0 n) + (switch-to-minibuffer)))) + +(defun choose-completion (&optional event no-exit no-quit) "Choose the completion at point. -If EVENT, use EVENT's position to determine the starting position." - (interactive (list last-nonmenu-event)) +If EVENT, use EVENT's position to determine the starting position. +With prefix argument NO-EXIT, insert the completion at point to the +minibuffer, but don't exit the minibuffer. When the prefix argument +is not provided, then whether to exit the minibuffer depends on the value +of `completion-no-auto-exit'. +If NO-QUIT is non-nil, insert the completion at point to the +minibuffer, but don't quit the completions window." + (interactive (list last-nonmenu-event current-prefix-arg)) ;; In case this is run via the mouse, give temporary modes such as ;; isearch a chance to turn off. (run-hooks 'mouse-leave-buffer-hook) (with-current-buffer (window-buffer (posn-window (event-start event))) (let ((buffer completion-reference-buffer) (base-position completion-base-position) + (base-affixes completion-base-affixes) (insert-function completion-list-insert-choice-function) + (completion-no-auto-exit (if no-exit t completion-no-auto-exit)) (choice (save-excursion (goto-char (posn-point (event-start event))) (let (beg) (cond - ((and (not (eobp)) (get-text-property (point) 'mouse-face)) + ((and (not (eobp)) + (get-text-property (point) 'completion--string)) (setq beg (1+ (point)))) ((and (not (bobp)) - (get-text-property (1- (point)) 'mouse-face)) + (get-text-property (1- (point)) 'completion--string)) (setq beg (point))) (t (error "No completion here"))) - (setq beg (previous-single-property-change beg 'mouse-face)) + (setq beg (or (previous-single-property-change + beg 'completion--string) + beg)) (substring-no-properties (get-text-property beg 'completion--string)))))) (unless (buffer-live-p buffer) (error "Destination buffer is dead")) - (quit-window nil (posn-window (event-start event))) + (unless no-quit + (quit-window nil (posn-window (event-start event)))) (with-current-buffer buffer (choose-completion-string choice buffer - (or base-position + (or (and completion-use-base-affixes base-affixes) + base-position ;; If all else fails, just guess. (list (choose-completion-guess-base-position choice))) insert-function))))) @@ -9229,19 +9802,24 @@ Called from `temp-buffer-show-hook'." ;; - With fancy completion styles, the code below will not always ;; find the right base directory. (if minibuffer-completing-file-name - (file-name-as-directory + (file-name-directory (expand-file-name (buffer-substring (minibuffer-prompt-end) (point))))))) (with-current-buffer standard-output (let ((base-position completion-base-position) + (base-affixes completion-base-affixes) (insert-fun completion-list-insert-choice-function)) (completion-list-mode) (setq-local completion-base-position base-position) + (setq-local completion-base-affixes base-affixes) (setq-local completion-list-insert-choice-function insert-fun)) (setq-local completion-reference-buffer mainbuf) (if base-dir (setq default-directory base-dir)) (when completion-tab-width (setq tab-width completion-tab-width)) + ;; Maybe enable cursor completions-highlight. + (when completions-highlight-face + (cursor-face-highlight-mode 1)) ;; Maybe insert help string. (when completion-show-help (goto-char (point-min)) @@ -9256,16 +9834,18 @@ select the completion near point.\n\n")))))) (defun switch-to-completions () "Select the completion list window." (interactive) - (let ((window (or (get-buffer-window "*Completions*" 0) - ;; Make sure we have a completions window. - (progn (minibuffer-completion-help) - (get-buffer-window "*Completions*" 0))))) - (when window - (select-window window) - ;; In the new buffer, go to the first completion. - ;; FIXME: Perhaps this should be done in `minibuffer-completion-help'. - (when (bobp) - (next-completion 1))))) + (when-let ((window (or (get-buffer-window "*Completions*" 0) + ;; Make sure we have a completions window. + (progn (minibuffer-completion-help) + (get-buffer-window "*Completions*" 0))))) + (select-window window) + (when (bobp) + (cond + ((and (memq this-command '(completion-at-point minibuffer-complete)) + (equal (this-command-keys) [backtab])) + (goto-char (point-max)) + (last-completion)) + (t (first-completion)))))) (defun read-expression-switch-to-completions () "Select the completion list window while reading an expression." @@ -9381,9 +9961,6 @@ PREFIX is the string that represents this modifier in an event type symbol." (defvar clone-buffer-hook nil "Normal hook to run in the new buffer at the end of `clone-buffer'.") -(defvar clone-indirect-buffer-hook nil - "Normal hook to run in the new buffer at the end of `clone-indirect-buffer'.") - (defun clone-process (process &optional newname) "Create a twin copy of PROCESS. If NEWNAME is nil, it defaults to PROCESS' name; @@ -9536,8 +10113,6 @@ Returns the newly created indirect buffer." (setq newname (substring newname 0 (match-beginning 0)))) (let* ((name (generate-new-buffer-name newname)) (buffer (make-indirect-buffer (current-buffer) name t))) - (with-current-buffer buffer - (run-hooks 'clone-indirect-buffer-hook)) (when display-flag (pop-to-buffer buffer nil norecord)) buffer)) @@ -9603,7 +10178,7 @@ call `normal-erase-is-backspace-mode' (which see) instead." (if (if (eq normal-erase-is-backspace 'maybe) (and (not noninteractive) (or (memq system-type '(ms-dos windows-nt)) - (memq window-system '(w32 ns)) + (memq window-system '(w32 ns pgtk)) (and (eq window-system 'x) (fboundp 'x-backspace-delete-keys-p) (x-backspace-delete-keys-p)) @@ -9777,24 +10352,7 @@ If it does not exist, create it and switch it to `messages-buffer-mode'." ;; versions together with bad values. This is therefore not as ;; flexible as it could be. See the thread: ;; https://lists.gnu.org/r/emacs-devel/2007-08/msg00300.html -(defconst bad-packages-alist - ;; Not sure exactly which semantic versions have problems. - ;; Definitely 2.0pre3, probably all 2.0pre's before this. - '((semantic semantic-version "\\`2\\.0pre[1-3]\\'" - "The version of `semantic' loaded does not work in Emacs 22. -It can cause constant high CPU load. -Upgrade to at least Semantic 2.0pre4 (distributed with CEDET 1.0pre4).") - ;; CUA-mode does not work with GNU Emacs version 22.1 and newer. - ;; Except for version 1.2, all of the 1.x and 2.x version of cua-mode - ;; provided the `CUA-mode' feature. Since this is no longer true, - ;; we can warn the user if the `CUA-mode' feature is ever provided. - (CUA-mode t nil -"CUA-mode is now part of the standard GNU Emacs distribution, -so you can now enable CUA via the Options menu or by customizing `cua-mode'. - -You have loaded an older version of CUA-mode which does not work -correctly with this version of Emacs. You should remove the old -version and use the one distributed with Emacs.")) +(defconst bad-packages-alist nil "Alist of packages known to cause problems in this version of Emacs. Each element has the form (PACKAGE SYMBOL REGEXP STRING). PACKAGE is either a regular expression to match file names, or a @@ -9802,25 +10360,22 @@ symbol (a feature name), like for `with-eval-after-load'. SYMBOL is either the name of a string variable, or t. Upon loading PACKAGE, if SYMBOL is t or matches REGEXP, display a warning using STRING as the message.") +(make-obsolete-variable 'bad-packages-alist nil "29.1") (defun bad-package-check (package) "Run a check using the element from `bad-packages-alist' matching PACKAGE." + (declare (obsolete nil "29.1")) (condition-case nil (let* ((list (assoc package bad-packages-alist)) (symbol (nth 1 list))) (and list (boundp symbol) (or (eq symbol t) - (and (stringp (setq symbol (eval symbol))) + (and (stringp (setq symbol (symbol-value symbol))) (string-match-p (nth 2 list) symbol))) (display-warning package (nth 3 list) :warning))) (error nil))) -(dolist (elem bad-packages-alist) - (let ((pkg (car elem))) - (with-eval-after-load pkg - (bad-package-check pkg)))) - ;;; Generic dispatcher commands @@ -9857,6 +10412,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)) @@ -9962,6 +10518,33 @@ This is an integer indicating the UTC offset in seconds, i.e., the number of seconds east of Greenwich.") ) +;; Document that decoded-time-dst is problematic on 6-element lists. +;; It should return -1 indicating unknown DST, but currently returns +;; nil indicating standard time. +(put 'decoded-time-dst 'function-documentation + (append (get 'decoded-time-dst 'function-documentation) + "As a special case, `decoded-time-dst' returns an unspecified +value when given a list too short to have a dst element.")) + +(defun get-scratch-buffer-create () + "Return the *scratch* buffer, creating a new one if needed." + (or (get-buffer "*scratch*") + (let ((scratch (get-buffer-create "*scratch*"))) + ;; Don't touch the buffer contents or mode unless we know that + ;; we just created it. + (with-current-buffer scratch + (when initial-scratch-message + (insert (substitute-command-keys initial-scratch-message)) + (set-buffer-modified-p nil)) + (funcall initial-major-mode)) + scratch))) + +(defun scratch-buffer () + "Switch to the *scratch* buffer. +If the buffer doesn't exist, create it first." + (interactive) + (pop-to-buffer-same-window (get-scratch-buffer-create))) + (provide 'simple) diff --git a/lisp/skeleton.el b/lisp/skeleton.el index fda9f514263..1bfc29f34e3 100644 --- a/lisp/skeleton.el +++ b/lisp/skeleton.el @@ -37,7 +37,8 @@ ;; page 2: paired insertion ;; page 3: mirror-mode, an example for setting up paired insertion -(defvaralias 'skeleton-transformation 'skeleton-transformation-function) +(define-obsolete-variable-alias 'skeleton-transformation + 'skeleton-transformation-function "29.1") (defvar skeleton-transformation-function 'identity "If non-nil, function applied to literal strings before they are inserted. @@ -65,7 +66,8 @@ region.") "Hook called at end of skeleton but before going to point of interest. The variables `v1' and `v2' are still set when calling this.") -(defvaralias 'skeleton-filter 'skeleton-filter-function) +(define-obsolete-variable-alias 'skeleton-filter + 'skeleton-filter-function "29.1") ;;;###autoload (defvar skeleton-filter-function 'identity @@ -113,7 +115,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/so-long.el b/lisp/so-long.el index f4ae71d9058..a2b4282ad61 100644 --- a/lisp/so-long.el +++ b/lisp/so-long.el @@ -1518,14 +1518,14 @@ The variables are set in accordance with what was remembered in `so-long'." (kill-local-variable variable)))) (defun so-long-mode-maintain-preserved-variables () - "Set any 'preserved' variables. + "Set any \"preserved\" variables. The variables are set in accordance with what was remembered in `so-long'." (dolist (var (so-long-original 'so-long-mode-preserved-variables)) (so-long-restore-variable var))) (defun so-long-mode-maintain-preserved-minor-modes () - "Enable or disable 'preserved' minor modes. + "Enable or disable \"preserved\" minor modes. The modes are set in accordance with what was remembered in `so-long'." (dolist (mode (so-long-original 'so-long-mode-preserved-minor-modes)) diff --git a/lisp/sort.el b/lisp/sort.el index 1d6c22ff89b..d04f075abd1 100644 --- a/lisp/sort.el +++ b/lisp/sort.el @@ -29,6 +29,8 @@ ;;; Code: +(eval-when-compile (require 'subr-x)) + (defgroup sort nil "Commands to sort text in an Emacs buffer." :group 'data) @@ -111,7 +113,8 @@ as start and end positions), and with `string<' otherwise." (lambda (a b) (string< (car a) (car b))))))) (if reverse (setq sort-lists (nreverse sort-lists))) (if messages (message "Reordering buffer...")) - (sort-reorder-buffer sort-lists old))) + (with-buffer-unmodified-if-unchanged + (sort-reorder-buffer sort-lists old)))) (if messages (message "Reordering buffer... Done")))) nil) @@ -286,25 +289,30 @@ FIELD, BEG and END. BEG and END specify region to sort." (interactive "p\nr") (let ;; To make `end-of-line' and etc. to ignore fields. ((inhibit-field-text-motion t)) - (sort-fields-1 field beg end - (lambda () - (sort-skip-fields field) - (let* ((case-fold-search t) - (base - (if (looking-at "\\(0x\\)[0-9a-f]\\|\\(0\\)[0-7]") - (cond ((match-beginning 1) - (goto-char (match-end 1)) - 16) - ((match-beginning 2) - (goto-char (match-end 2)) - 8) - (t nil))))) - (string-to-number (buffer-substring (point) - (save-excursion - (forward-sexp 1) - (point))) - (or base sort-numeric-base)))) - nil))) + (sort-fields-1 + field beg end + (lambda () + ;; Don't try to parse blank lines (they'll be + ;; sorted at the start). + (if (looking-at "[\t ]*$") + 0 + (sort-skip-fields field) + (let* ((case-fold-search t) + (base + (if (looking-at "\\(0x\\)[0-9a-f]\\|\\(0\\)[0-7]") + (cond ((match-beginning 1) + (goto-char (match-end 1)) + 16) + ((match-beginning 2) + (goto-char (match-end 2)) + 8) + (t nil))))) + (string-to-number (buffer-substring (point) + (save-excursion + (forward-sexp 1) + (point))) + (or base sort-numeric-base))))) + nil))) ;;;;;###autoload ;;(defun sort-float-fields (field beg end) @@ -540,8 +548,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 1b6dc809521..b12cf3d9c2d 100644 --- a/lisp/speedbar.el +++ b/lisp/speedbar.el @@ -306,10 +306,9 @@ attached to and added to this list before the new frame is initialized." (symbol :tag "Parameter") (sexp :tag "Value")))) -(defcustom speedbar-use-imenu-flag (fboundp 'imenu) +(defcustom speedbar-use-imenu-flag t "Non-nil means use imenu for file parsing, nil to use etags. -XEmacs prior to 20.4 doesn't support imenu, therefore the default is to -use etags instead. Etags support is not as robust as imenu support." +Etags support is not as robust as imenu support." ; See Bug#51102 :tag "Use Imenu for tags" :group 'speedbar :type 'boolean) @@ -800,15 +799,10 @@ This basically creates a sparse keymap, and makes its parent be ["Auto Update" speedbar-toggle-updates :active (not speedbar-update-flag-disable) :style toggle :selected speedbar-update-flag]) - (if (and (or (fboundp 'defimage) - (fboundp 'make-image-specifier)) - (if (fboundp 'display-graphic-p) - (display-graphic-p) - window-system)) - (list - ["Use Images" speedbar-toggle-images - :style toggle :selected speedbar-use-images])) - ) + (when (and (fboundp 'defimage) (display-graphic-p)) + (list + ["Use Images" speedbar-toggle-images + :style toggle :selected speedbar-use-images]))) "Base part of the speedbar menu.") (defvar speedbar-easymenu-definition-special @@ -938,7 +932,9 @@ supported at a time. ;; hscroll (setq-local auto-hscroll-mode nil) ;; reset the selection variable - (setq speedbar-last-selected-file nil)) + (setq speedbar-last-selected-file nil) + (unless (display-graphic-p) + (message "Use `M-x speedbar-get-focus' to see the speedbar window"))) (defun speedbar-frame-reposition-smartly () "Reposition the speedbar frame to be next to the attached frame." @@ -2274,9 +2270,7 @@ the list." (with-current-buffer (get-file-buffer f) speedbar-tag-hierarchy-method) speedbar-tag-hierarchy-method)) - (lst (if (fboundp 'copy-tree) - (copy-tree lst) - lst))) + (lst (copy-tree lst))) (while methods (setq lst (funcall (car methods) lst) methods (cdr methods))) @@ -3694,27 +3688,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..66e2e487d9c --- /dev/null +++ b/lisp/sqlite-mode.el @@ -0,0 +1,224 @@ +;;; sqlite-mode.el --- Mode for examining sqlite3 database files -*- lexical-binding: t; -*- + +;; Copyright (C) 2021-2022 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) + "Return a list of the column names for TABLE." + (let ((sql + (caar + (sqlite-select + sqlite--db + "select sql from sqlite_master where tbl_name = ? AND type = 'table'" + (list table))))) + (with-temp-buffer + (insert sql) + (mapcar #'string-trim + (split-string + ;; Extract the args to CREATE TABLE. Point is + ;; currently at its end. + (buffer-substring + (1- (point)) ; right before ) + (1+ (progn (backward-sexp) (point)))) ; right after ( + ","))))) + +(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..6a8a53a699e --- /dev/null +++ b/lisp/sqlite.el @@ -0,0 +1,43 @@ +;;; sqlite.el --- Functions for interacting with sqlite3 databases -*- lexical-binding: t; -*- + +;; Copyright (C) 2021-2022 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 9ebd4c1a707..4b42cd236c9 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -519,10 +519,60 @@ DIRS are relative." xdg-dir) (t emacs-d-dir)))) +(defvar comp--compilable) +(defvar comp--delayed-sources) +(defun startup--require-comp-safely () + "Require the native compiler avoiding circular dependencies." + (when (featurep 'native-compile) + ;; Require comp with `comp--compilable' set to nil to break + ;; circularity. + (let ((comp--compilable nil)) + (require 'comp)) + (native--compile-async comp--delayed-sources nil 'late) + (setq comp--delayed-sources nil))) + +(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) + (startup--require-comp-safely)) + (setq comp--compilable t)) + (defvar native-comp-eln-load-path) (defvar native-comp-deferred-compilation) (defvar comp-enable-subr-trampolines) +(defvar startup--original-eln-load-path nil + "Original value of `native-comp-eln-load-path'.") + +(defun startup-redirect-eln-cache (cache-directory) + "Redirect the user's eln-cache directory to CACHE-DIRECTORY. +CACHE-DIRECTORY must be a single directory, a string. +This function destructively changes `native-comp-eln-load-path' +so that its first element is CACHE-DIRECTORY. If CACHE-DIRECTORY +is not an absolute file name, it is interpreted relative +to `user-emacs-directory'. +For best results, call this function in your early-init file, +so that the rest of initialization and package loading uses +the updated value." + ;; Remove the original eln-cache. + (setq native-comp-eln-load-path (cdr native-comp-eln-load-path)) + ;; Add the new eln-cache. + (push (expand-file-name (file-name-as-directory cache-directory) + user-emacs-directory) + native-comp-eln-load-path)) + +(defun startup--update-eln-cache () + "Update the user eln-cache directory due to user customizations." + ;; Don't override user customizations! + (when (equal native-comp-eln-load-path + startup--original-eln-load-path) + (startup-redirect-eln-cache "eln-cache") + (setq startup--original-eln-load-path + (copy-sequence native-comp-eln-load-path)))) + (defun normal-top-level () "Emacs calls this function when it first starts up. It sets `command-line-processed', processes the command-line, @@ -556,18 +606,8 @@ It is the default value of the variable `top-level'." (unless (string= "" path) (push path native-comp-eln-load-path))))) (push (expand-file-name "eln-cache/" user-emacs-directory) - native-comp-eln-load-path) - ;; When $HOME is set to '/nonexistent' means we are running the - ;; testsuite, add a temporary folder in front to produce there - ;; new compilations. - (when (and (equal (getenv "HOME") "/nonexistent") - ;; We may be running in a chroot environment where we - ;; can't write anything. - (file-writable-p (expand-file-name - (or temporary-file-directory "")))) - (let ((tmp-dir (make-temp-file "emacs-testsuite-" t))) - (add-hook 'kill-emacs-hook (lambda () (delete-directory tmp-dir t))) - (push tmp-dir native-comp-eln-load-path)))) + native-comp-eln-load-path)) + ;; Look in each dir in load-path for a subdirs.el file. If we ;; find one, load it, which will add the appropriate subdirs of ;; that dir into load-path. This needs to be done before setting @@ -663,7 +703,9 @@ It is the default value of the variable `top-level'." ;; native-comp-eln-load-path. (expand-file-name (decode-coding-string dir coding t))) - npath)))) + npath))) + (setq startup--original-eln-load-path + (copy-sequence native-comp-eln-load-path))) (dolist (filesym '(data-directory doc-directory exec-directory installation-directory invocation-directory invocation-name @@ -713,6 +755,7 @@ It is the default value of the variable `top-level'." (let ((old-face-font-rescale-alist face-font-rescale-alist)) (unwind-protect (command-line) + ;; Do this again, in case .emacs defined more abbreviations. (if default-directory (setq default-directory (abbreviate-file-name default-directory))) @@ -779,6 +822,7 @@ It is the default value of the variable `top-level'." (font-menu-add-default)) (unless inhibit-startup-hooks (run-hooks 'window-setup-hook)))) + ;; Subprocesses of Emacs do not have direct access to the terminal, so ;; unless told otherwise they should only assume a dumb terminal. ;; We are careful to do it late (after term-setup-hook), although the @@ -796,7 +840,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: @@ -975,7 +1020,11 @@ init-file, or to a default value if loading is not possible." (debug-on-error-initial (if (eq init-file-debug t) 'startup - init-file-debug))) + init-file-debug)) + ;; The init file might contain byte-code with embedded NULs, + ;; which can cause problems when read back, so disable nul + ;; byte detection. (Bug#52554) + (inhibit-null-byte-detection t)) (let ((debug-on-error debug-on-error-initial)) (condition-case-unless-debug error (when init-file-user @@ -1053,6 +1102,9 @@ the `--debug-init' option to view a complete error backtrace." (when debug-on-error-should-be-set (setq debug-on-error debug-on-error-from-init-file)))) +(defvar lisp-directory nil + "Directory where Emacs's own *.el and *.elc Lisp files are installed.") + (defun command-line () "A subroutine of `normal-top-level'. Amongst another things, it parses the command-line arguments." @@ -1084,8 +1136,7 @@ Amongst another things, it parses the command-line arguments." (let ((simple-file-name ;; Look for simple.el or simple.elc and use their directory ;; as the place where all Lisp files live. - (locate-file "simple" load-path (get-load-suffixes))) - lisp-dir) + (locate-file "simple" load-path (get-load-suffixes)))) ;; Don't abort if simple.el cannot be found, but print a warning. ;; Although in most usage we are going to cryptically abort a moment ;; later anyway, due to missing required bidi data files (eg bug#13430). @@ -1101,12 +1152,13 @@ please check its value") (unless (file-readable-p lispdir) (princ (format "Lisp directory %s not readable?" lispdir)) (terpri))) - (setq lisp-dir (file-truename (file-name-directory simple-file-name))) + (setq lisp-directory + (file-truename (file-name-directory simple-file-name))) (setq load-history (mapcar (lambda (elt) (if (and (stringp (car elt)) (not (file-name-absolute-p (car elt)))) - (cons (concat lisp-dir + (cons (concat lisp-directory (car elt)) (cdr elt)) elt)) @@ -1139,7 +1191,8 @@ please check its value") ("--no-x-resources") ("--debug-init") ("--user") ("--iconic") ("--icon-type") ("--quick") ("--no-blinking-cursor") ("--basic-display") - ("--dump-file") ("--temacs") ("--seccomp"))) + ("--dump-file") ("--temacs") ("--seccomp") + ("--init-directory"))) (argi (pop args)) (orig-argi argi) argval) @@ -1159,6 +1212,14 @@ please check its value") (t (setq argval nil argi orig-argi))))) + + ;; We handle "-scripteval" further down, but we have to + ;; inhibit loading the user init file first. (This is for + ;; "emacs -x" handling.) + (when (equal argi "-scripteval") + (setq init-file-user nil + noninteractive t)) + (cond ;; The --display arg is handled partly in C, partly in Lisp. ;; When it shows up here, we just put it back to be handled @@ -1179,6 +1240,9 @@ please check its value") (push '(vertical-scroll-bars . nil) initial-frame-alist)) ((member argi '("-q" "-no-init-file")) (setq init-file-user nil)) + ((member argi '("-init-directory")) + (setq user-emacs-directory (or argval (pop args)) + argval nil)) ((member argi '("-u" "-user")) (setq init-file-user (or argval (pop args)) argval nil)) @@ -1211,12 +1275,16 @@ please check its value") (setcdr command-line-args args))) ;; Re-evaluate predefined variables whose initial value depends on - ;; the runtime context. - (when (listp custom-delayed-init-variables) - (mapc #'custom-reevaluate-setting - ;; Initialize them in the same order they were loaded, in - ;; case there are dependencies between them. - (reverse custom-delayed-init-variables))) + ;; the runtime context. But delay the warning about + ;; `user-emacs-directory' being inaccessible until after processing + ;; the init file and the command-line arguments, in case the user + ;; customized `user-emacs-directory-warning' to nil via those. + (let ((user-emacs-directory-warning nil)) + (when (listp custom-delayed-init-variables) + (mapc #'custom-reevaluate-setting + ;; Initialize them in the same order they were loaded, in + ;; case there are dependencies between them. + (reverse custom-delayed-init-variables)))) (setq custom-delayed-init-variables t) ;; Warn for invalid user name. @@ -1255,7 +1323,8 @@ please check its value") (and (eq xdg-dir user-emacs-directory) (not (eq xdg-dir startup--xdg-config-default)))) user-emacs-directory - ;; The name is not obvious, so access more directories to calculate it. + ;; The name is not obvious, so access more directories + ;; to calculate it. (setq xdg-dir (concat "~" init-file-user "/.config/emacs/")) (startup--xdg-or-homedot xdg-dir init-file-user))) @@ -1271,6 +1340,12 @@ please check its value") startup-init-directory))) (setq early-init-file user-init-file) + ;; Amend `native-comp-eln-load-path', since the early-init file may + ;; have altered `user-emacs-directory' and/or changed the eln-cache + ;; directory. + (when (featurep 'native-compile) + (startup--update-eln-cache)) + ;; If any package directory exists, initialize the package system. (and user-init-file package-enable-at-startup @@ -1405,6 +1480,12 @@ please check its value") startup-init-directory)) t) + ;; Amend `native-comp-eln-load-path' again, since the early-init + ;; file may have altered `user-emacs-directory' and/or changed the + ;; eln-cache directory. + (when (featurep 'native-compile) + (startup--update-eln-cache)) + (when (and deactivate-mark transient-mark-mode) (with-current-buffer (window-buffer) (deactivate-mark))) @@ -1464,9 +1545,21 @@ please check its value") (list 'error (substitute-command-keys "Memory exhausted--use \\[save-some-buffers] then exit and restart Emacs"))) + ;; Reevaluate `user-emacs-directory-warning' before processing + ;; '--eval' arguments, so that the user could override the default + ;; value in the '--eval' forms. + (custom-reevaluate-setting 'user-emacs-directory-warning) + ;; Process the remaining args. (command-line-1 (cdr command-line-args)) + ;; Check if `user-emacs-directory' is accessible and warn if it + ;; isn't, unless `user-emacs-directory-warning' was customized to + ;; disable that warning. + (when (and user-emacs-directory-warning + (not (file-accessible-directory-p user-emacs-directory))) + (locate-user-emacs-file "")) + ;; This is a problem because, e.g. if emacs.d/gnus.el exists, ;; trying to load gnus could load the wrong file. ;; OK, it would not matter if .emacs.d were at the end of load-path. @@ -1567,17 +1660,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 @@ -1610,7 +1708,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))) @@ -1633,22 +1732,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) @@ -1663,7 +1771,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 " @@ -1701,7 +1811,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))) @@ -1823,7 +1934,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"))))) @@ -1832,28 +1945,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 @@ -1937,7 +2057,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) @@ -1975,11 +2094,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. @@ -1991,6 +2110,8 @@ we put it on this frame." ;; frame visible. (if (eq (window-system) 'w32) (sit-for 0 t)) + (if (eq (window-system) 'pgtk) + (sit-for 0.1 t)) (dolist (frame (append (frame-list) (list (selected-frame)))) (if (and (frame-visible-p frame) (not (window-minibuffer-p (frame-selected-window frame)))) @@ -2132,8 +2253,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." @@ -2210,10 +2334,14 @@ If you have no Meta key, you may instead type ESC followed by the character.)")) (insert "\t\t") (insert-button "Open *scratch* buffer" 'action (lambda (_button) (switch-to-buffer - (startup--get-buffer-create-scratch))) + (get-scratch-buffer-create))) '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 ")) @@ -2253,7 +2381,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") @@ -2336,12 +2466,6 @@ A fancy display is used on graphic displays, normal otherwise." (defalias 'about-emacs 'display-about-screen) (defalias 'display-splash-screen 'display-startup-screen) -(defun startup--get-buffer-create-scratch () - (or (get-buffer "*scratch*") - (with-current-buffer (get-buffer-create "*scratch*") - (set-buffer-major-mode (current-buffer)) - (current-buffer)))) - ;; This avoids byte-compiler warning in the unexec build. (declare-function pdumper-stats "pdumper.c" ()) @@ -2394,6 +2518,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))) @@ -2533,12 +2658,23 @@ nil default-directory" name) ;; This is used to handle -script. It's not clear ;; we need to document it (it is totally internal). - ((member argi '("-scriptload")) + ((member argi '("-scriptload" "-scripteval")) (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)))) - (load file-ex nil t t))) + (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)) + (if (equal argi "-scripteval") + ;; This will kill Emacs. + (command-line--eval-script file-ex) + (command-line--load-script file-ex)))) ((equal argi "-insert") (setq inhibit-startup-screen t) @@ -2547,6 +2683,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)) @@ -2616,7 +2757,7 @@ nil default-directory" name) (when (eq initial-buffer-choice t) ;; When `initial-buffer-choice' equals t make sure that *scratch* ;; exists. - (startup--get-buffer-create-scratch)) + (get-scratch-buffer-create)) ;; If *scratch* exists and is empty, insert initial-scratch-message. ;; Do this before switching to *scratch* below to handle bug#9605. @@ -2640,7 +2781,7 @@ nil default-directory" name) ((functionp initial-buffer-choice) (funcall initial-buffer-choice)) ((eq initial-buffer-choice t) - (startup--get-buffer-create-scratch)) + (get-scratch-buffer-create)) (t (error "`initial-buffer-choice' must be a string, a function, or t"))))) (unless (buffer-live-p buf) @@ -2658,10 +2799,24 @@ nil default-directory" name) (nondisplayed-buffers-p nil)) (when (> displayable-buffers-len 0) (switch-to-buffer (car displayable-buffers))) - (when (> displayable-buffers-len 1) - (switch-to-buffer-other-window (car (cdr displayable-buffers))) + (cond + ;; Two buffers; display them both. + ((= displayable-buffers-len 2) + (switch-to-buffer-other-window (cadr displayable-buffers)) ;; Focus on the first buffer. (other-window -1)) + ;; More than two buffers: Ensure that the buffer display order + ;; reflects the order they were given on the command line. + ;; (This will end up with a `next-buffer' order that's in + ;; reverse order -- the final file is the focused one, and then + ;; the rest are in `next-buffer' in descending order. + ((> displayable-buffers-len 2) + (let ((bufs (reverse (cdr displayable-buffers)))) + (switch-to-buffer-other-window (pop bufs)) + (dolist (buf bufs) + (switch-to-buffer buf nil t)) + ;; Focus on the first buffer. + (other-window -1)))) (when (> displayable-buffers-len 2) (setq nondisplayed-buffers-p t)) @@ -2708,6 +2863,35 @@ nil default-directory" name) (display-startup-screen (> displayable-buffers-len 0)))))) +(defun command-line--load-script (file) + (load-with-code-conversion + file file nil t + (lambda (buffer file) + (with-current-buffer buffer + (goto-char (point-min)) + ;; Removing the #! and then calling `eval-buffer' will make the + ;; reader not signal an error if it then turns out that the + ;; buffer is empty. + (when (looking-at "#!") + (delete-line)) + (eval-buffer buffer nil file nil t))))) + +(defun command-line--eval-script (file) + (load-with-code-conversion + file file nil t + (lambda (buffer _) + (with-current-buffer buffer + (goto-char (point-min)) + (when (looking-at "#!") + (forward-line)) + (let (value form) + (while (ignore-error 'end-of-file + (setq form (read (current-buffer)))) + (setq value (eval form t))) + (kill-emacs (if (numberp value) + value + 0))))))) + (defun command-line-normalize-file-name (file) "Collapse multiple slashes to one, to handle non-Emacs file names." (save-match-data diff --git a/lisp/strokes.el b/lisp/strokes.el index 32f657d1149..5402ebf1e1c 100644 --- a/lisp/strokes.el +++ b/lisp/strokes.el @@ -1036,8 +1036,8 @@ o Strokes are a bit computer-dependent in that they depend somewhat on (defun strokes-window-configuration-changed-p () "Non-nil if the `strokes-window-configuration' frame properties changed. This is based on the last time `strokes-window-configuration' was updated." - (compare-window-configurations (current-window-configuration) - strokes-window-configuration)) + (window-configuration-equal-p (current-window-configuration) + strokes-window-configuration)) (defun strokes-update-window-configuration () "Ensure that `strokes-window-configuration' is up-to-date." @@ -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 921853de607..8afba2b341d 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)))) @@ -206,6 +207,39 @@ Also see `local-variable-p'." (:success t) (void-variable nil))) +(defmacro buffer-local-set-state (&rest pairs) + "Like `setq-local', but allow restoring the previous state of locals later. +This macro returns an object that can be passed to `buffer-local-restore-state' +in order to restore the state of the local variables set via this macro. + +\(fn [VARIABLE VALUE]...)" + (declare (debug setq)) + (unless (zerop (mod (length pairs) 2)) + (error "PAIRS must have an even number of variable/value members")) + `(prog1 + (buffer-local-set-state--get ',pairs) + (setq-local ,@pairs))) + +(defun buffer-local-set-state--get (pairs) + (let ((states nil)) + (while pairs + (push (list (car pairs) + (and (boundp (car pairs)) + (local-variable-p (car pairs))) + (and (boundp (car pairs)) + (symbol-value (car pairs)))) + states) + (setq pairs (cddr pairs))) + (nreverse states))) + +(defun buffer-local-restore-state (states) + "Restore values of buffer-local variables recorded in STATES. +STATES should be an object returned by `buffer-local-set-state'." + (pcase-dolist (`(,variable ,local ,value) states) + (if local + (set variable value) + (kill-local-variable variable)))) + (defmacro push (newelt place) "Add NEWELT to the list stored in the generalized variable PLACE. This is morally equivalent to (setf PLACE (cons NEWELT PLACE)), @@ -242,18 +276,14 @@ change the list." (defmacro when (cond &rest body) "If COND yields non-nil, do BODY, else return nil. When COND yields non-nil, eval BODY forms sequentially and return -value of last one, or nil if there are none. - -\(fn COND BODY...)" +value of last one, or nil if there are none." (declare (indent 1) (debug t)) (list 'if cond (cons 'progn body))) (defmacro unless (cond &rest body) "If COND yields nil, do BODY, else return nil. When COND yields nil, eval BODY forms sequentially and return -value of last one, or nil if there are none. - -\(fn COND BODY...)" +value of last one, or nil if there are none." (declare (indent 1) (debug t)) (cons 'if (cons cond (cons nil body)))) @@ -411,7 +441,10 @@ To signal with MESSAGE without interpreting format characters like `%', `\\=`' and `\\='', use (error \"%s\" MESSAGE). In Emacs, the convention is that error messages start with a capital letter but *do not* end with a period. Please follow this convention -for the sake of consistency." +for the sake of consistency. + +To alter the look of the displayed error messages, you can use +the `command-error-function' variable." (declare (advertised-calling-convention (string &rest args) "23.1")) (signal 'error (list (apply #'format-message args)))) @@ -427,7 +460,10 @@ To signal with MESSAGE without interpreting format characters like `%', `\\=`' and `\\='', use (user-error \"%s\" MESSAGE). In Emacs, the convention is that error messages start with a capital letter but *do not* end with a period. Please follow this convention -for the sake of consistency." +for the sake of consistency. + +To alter the look of the displayed error messages, you can use +the `command-error-function' variable." (signal 'user-error (list (apply #'format-message format args)))) (defun define-error (name message &optional parent) @@ -929,15 +965,43 @@ 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))) + ;; For historical reasons, parse "C-x ( C-d C-x )" as "C-d", since + ;; `kbd' used to be a wrapper around `read-kbd-macro'. + (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 (apply #'vector (let ((lres (append res nil))) + ;; Remove the first and last two elements. + (setq lres (cddr lres)) + (setq lres (nreverse lres)) + (setq lres (cddr lres)) + (nreverse lres))))) + + (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 +1052,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 +1067,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))) @@ -1130,8 +1198,17 @@ Subkeymaps may be modified but are not canonicalized." (setq map (map-keymap ;; -internal (lambda (key item) (if (consp key) - ;; Treat char-ranges specially. - (push (cons key item) ranges) + (if (= (car key) (1- (cdr key))) + ;; If we have a two-character range, then + ;; treat it as two separate characters + ;; (because this makes `describe-bindings' + ;; look better and shouldn't affect + ;; anything else). + (progn + (push (cons (car key) item) bindings) + (push (cons (cdr key) item) bindings)) + ;; Treat char-ranges specially. + (push (cons key item) ranges)) (push (cons key item) bindings))) map))) ;; Create the new map. @@ -1157,6 +1234,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 +1248,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 +1272,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 +1293,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 +1313,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 +1327,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 +1348,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. @@ -1752,6 +1853,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") @@ -1778,6 +1880,9 @@ This was used internally by quail.el and keyboard.c in Emacs 27. It does nothing in Emacs 28.") (make-obsolete-variable 'inhibit--record-char nil "28.1") +(define-obsolete-function-alias 'compare-window-configurations + #'window-configuration-equal-p "29.1") + ;; We can't actually make `values' obsolete, because that will result ;; in warnings when using `values' in let-bindings. ;;(make-obsolete-variable 'values "no longer used" "28.1") @@ -1852,7 +1957,9 @@ performance impact when running `add-hook' and `remove-hook'." (set (make-local-variable hook) (list t))) ;; Detect the case where make-local-variable was used on a hook ;; and do what we used to do. - (unless (and (consp (symbol-value hook)) (memq t (symbol-value hook))) + (when (and (local-variable-if-set-p hook) + (not (and (consp (symbol-value hook)) + (memq t (symbol-value hook))))) (setq local t))) (let ((hook-value (if local (symbol-value hook) (default-value hook)))) ;; If the hook value is a single function, turn it into a list. @@ -1860,26 +1967,34 @@ performance impact when running `add-hook' and `remove-hook'." (setq hook-value (list hook-value))) ;; Do the actual addition if necessary (unless (member function hook-value) - (when (stringp function) ;FIXME: Why? - (setq function (purecopy function))) - ;; All those `equal' tests performed between functions can end up being - ;; costly since those functions may be large recursive and even cyclic - ;; structures, so we index `hook--depth-alist' with `eq'. (bug#46326) - (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))) - (setq hook-value - (if (< 0 depth) - (append hook-value (list function)) - (cons function hook-value))) - (let ((depth-alist (get hook 'hook--depth-alist))) - (when depth-alist - (setq hook-value - (sort (if (< 0 depth) hook-value (copy-sequence hook-value)) - (lambda (f1 f2) - (< (alist-get f1 depth-alist 0 nil #'eq) - (alist-get f2 depth-alist 0 nil #'eq)))))))) + (let ((depth-sym (get hook 'hook--depth-alist))) + ;; While the `member' test above has to use `equal' for historical + ;; reasons, `equal' is a performance problem on large/cyclic functions, + ;; so we index `hook--depth-alist' with `eql'. (bug#46326) + (unless (zerop depth) + (unless depth-sym + (setq depth-sym (make-symbol "depth-alist")) + (set depth-sym nil) + (setf (get hook 'hook--depth-alist) depth-sym)) + (if local (make-local-variable depth-sym)) + (setf (alist-get function + (if local (symbol-value depth-sym) + (default-value depth-sym)) + 0) + depth)) + (setq hook-value + (if (< 0 depth) + (append hook-value (list function)) + (cons function hook-value))) + (when depth-sym + (let ((depth-alist (if local (symbol-value depth-sym) + (default-value depth-sym)))) + (when depth-alist + (setq hook-value + (sort (if (< 0 depth) hook-value (copy-sequence hook-value)) + (lambda (f1 f2) + (< (alist-get f1 depth-alist 0 nil #'eq) + (alist-get f2 depth-alist 0 nil #'eq)))))))))) ;; Set the actual variable (if local (progn @@ -1927,7 +2042,7 @@ one will be removed." (format "%s hook to remove: " (if local "Buffer-local" "Global")) fn-alist - nil t) + nil t nil 'set-variable-value-history) fn-alist nil nil #'string=))) (list hook function local))) (or (boundp hook) (set hook nil)) @@ -1952,9 +2067,14 @@ one will be removed." (when old-fun ;; Remove auxiliary depth info to avoid leaks (bug#46414) ;; and to avoid the list growing too long. - (let* ((depths (get hook 'hook--depth-alist)) - (di (assq old-fun depths))) - (when di (put hook 'hook--depth-alist (delq di depths))))) + (let* ((depth-sym (get hook 'hook--depth-alist)) + (depth-alist (if depth-sym (if local (symbol-value depth-sym) + (default-value depth-sym)))) + (di (assq old-fun depth-alist))) + (when di + (setf (if local (symbol-value depth-sym) + (default-value depth-sym)) + (remq di depth-alist))))) ;; If the function is on the global hook, we need to shadow it locally ;;(when (and local (member function (default-value hook)) ;; (not (member (cons 'not function) hook-value))) @@ -2116,7 +2236,7 @@ can do the job." (not (macroexp-const-p append))) exp (let* ((sym (cadr list-var)) - (append (eval append)) + (append (eval append lexical-binding)) (msg (format-message "`add-to-list' can't use lexical var `%s'; use `push' or `cl-pushnew'" sym)) @@ -2303,6 +2423,102 @@ Affects only hooks run in the current buffer." (let ((delay-mode-hooks t)) ,@body))) +;;; `when-let' and friends. + +(defun internal--build-binding (binding prev-var) + "Check and build a single BINDING with PREV-VAR." + (setq binding + (cond + ((symbolp binding) + (list binding binding)) + ((null (cdr binding)) + (list (make-symbol "s") (car binding))) + (t binding))) + (when (> (length binding) 2) + (signal 'error + (cons "`let' bindings can have only one value-form" binding))) + (let ((var (car binding))) + `(,var (and ,prev-var ,(cadr binding))))) + +(defun internal--build-bindings (bindings) + "Check and build conditional value forms for BINDINGS." + (let ((prev-var t)) + (mapcar (lambda (binding) + (let ((binding (internal--build-binding binding prev-var))) + (setq prev-var (car binding)) + binding)) + bindings))) + +(defmacro if-let* (varlist then &rest else) + "Bind variables according to VARLIST and evaluate THEN or ELSE. +This is like `if-let' but doesn't handle a VARLIST of the form +\(SYMBOL SOMETHING) specially." + (declare (indent 2) + (debug ((&rest [&or symbolp (symbolp form) (form)]) + body))) + (if varlist + `(let* ,(setq varlist (internal--build-bindings varlist)) + (if ,(caar (last varlist)) + ,then + ,@else)) + `(let* () ,then))) + +(defmacro when-let* (varlist &rest body) + "Bind variables according to VARLIST and conditionally evaluate BODY. +This is like `when-let' but doesn't handle a VARLIST of the form +\(SYMBOL SOMETHING) specially." + (declare (indent 1) (debug if-let*)) + (list 'if-let* varlist (macroexp-progn body))) + +(defmacro and-let* (varlist &rest body) + "Bind variables according to VARLIST and conditionally evaluate BODY. +Like `when-let*', except if BODY is empty and all the bindings +are non-nil, then the result is non-nil." + (declare (indent 1) (debug if-let*)) + (let (res) + (if varlist + `(let* ,(setq varlist (internal--build-bindings varlist)) + (when ,(setq res (caar (last varlist))) + ,@(or body `(,res)))) + `(let* () ,@(or body '(t)))))) + +(defmacro if-let (spec then &rest else) + "Bind variables according to SPEC and evaluate THEN or ELSE. +Evaluate each binding in turn, as in `let*', stopping if a +binding value is nil. If all are non-nil return the value of +THEN, otherwise the last form in ELSE. + +Each element of SPEC is a list (SYMBOL VALUEFORM) that binds +SYMBOL to the value of VALUEFORM. An element can additionally be +of the form (VALUEFORM), which is evaluated and checked for nil; +i.e. SYMBOL can be omitted if only the test result is of +interest. It can also be of the form SYMBOL, then the binding of +SYMBOL is checked for nil. + +As a special case, interprets a SPEC of the form \(SYMBOL SOMETHING) +like \((SYMBOL SOMETHING)). This exists for backward compatibility +with an old syntax that accepted only one binding." + (declare (indent 2) + (debug ([&or (symbolp form) ; must be first, Bug#48489 + (&rest [&or symbolp (symbolp form) (form)])] + body))) + (when (and (<= (length spec) 2) + (not (listp (car spec)))) + ;; Adjust the single binding case + (setq spec (list spec))) + (list 'if-let* spec then (macroexp-progn else))) + +(defmacro when-let (spec &rest body) + "Bind variables according to SPEC and conditionally evaluate BODY. +Evaluate each binding in turn, stopping if a binding value is nil. +If all are non-nil, return the value of the last form in BODY. + +The variable list SPEC is the same as in `if-let'." + (declare (indent 1) (debug if-let)) + (list 'if-let spec (macroexp-progn body))) + + + ;; PUBLIC: find if the current mode derives from another. (defun provided-mode-derived-p (mode &rest modes) @@ -2651,7 +2867,8 @@ It can be retrieved with `(process-get PROCESS PROPNAME)'." (defun memory-limit () "Return an estimate of Emacs virtual memory usage, divided by 1024." - (or (cdr (assq 'vsize (process-attributes (emacs-pid)))) 0)) + (let ((default-directory temporary-file-directory)) + (or (cdr (assq 'vsize (process-attributes (emacs-pid)))) 0))) ;;;; Input and display facilities. @@ -2665,7 +2882,7 @@ It can be retrieved with `(process-get PROCESS PROPNAME)'." (defconst read-key-full-map (let ((map (make-sparse-keymap))) - (define-key map [t] 'dummy) + (define-key map [t] #'ignore) ;Dummy binding. ;; ESC needs to be unbound so that escape sequences in ;; `input-decode-map' are still processed by `read-key-sequence'. @@ -2847,7 +3064,8 @@ DEFAULT specifies a default value to return if the user just types RET. The value of DEFAULT is inserted into PROMPT. HIST specifies a history list variable. See `read-from-minibuffer' for details of the HIST argument. -This function is used by the `interactive' code letter `n'." + +This function is used by the `interactive' code letter \"n\"." (let ((n nil) (default1 (if (consp default) (car default) default))) (when default1 @@ -3079,7 +3297,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' @@ -3207,6 +3425,15 @@ switch back again to the minibuffer before entering the character. This is not possible when using `read-key', but using `read-key' may be less confusing to some users.") +(defvar from--tty-menu-p nil + "Non-nil means the current command was invoked from a TTY menu.") +(defun use-dialog-box-p () + "Say whether the current command should prompt the user via a dialog box." + (and last-input-event ; not during startup + (or (listp last-nonmenu-event) ; invoked by a mouse event + from--tty-menu-p) ; invoked via TTY menu + use-dialog-box)) + (defun y-or-n-p (prompt) "Ask user a \"y or n\" question. Return t if answer is \"y\" and nil if it is \"n\". @@ -3266,10 +3493,7 @@ like) while `y-or-n-p' is running)." ((and (member str '("h" "H")) help-form) (print help-form)) (t (setq temp-prompt (concat "Please answer y or n. " prompt)))))))) - ((and (display-popup-menus-p) - last-input-event ; not during startup - (listp last-nonmenu-event) - use-dialog-box) + ((use-dialog-box-p) (setq prompt (funcall padded prompt t) answer (x-popup-dialog t `(,prompt ("Yes" . act) ("No" . skip))))) (y-or-n-p-use-read-key @@ -3370,6 +3594,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. @@ -3569,6 +3816,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 @@ -3660,14 +3910,18 @@ Note: :data and :device are currently not supported on Windows." (declare-function w32-shell-dos-semantics "w32-fns" nil) -(defun shell-quote-argument (argument) +(defun shell-quote-argument (argument &optional posix) "Quote ARGUMENT for passing as argument to an inferior shell. This function is designed to work with the syntax of your system's standard shell, and might produce incorrect results with unusual shells. -See Info node `(elisp)Security Considerations'." - (cond - ((eq system-type 'ms-dos) +See Info node `(elisp)Security Considerations'. + +If the optional POSIX argument is non-nil, ARGUMENT is quoted +according to POSIX shell quoting rules, regardless of the +system's shell." +(cond + ((and (not posix) (eq system-type 'ms-dos)) ;; Quote using double quotes, but escape any existing quotes in ;; the argument with backslashes. (let ((result "") @@ -3682,7 +3936,7 @@ See Info node `(elisp)Security Considerations'." start (1+ end)))) (concat "\"" result (substring argument start) "\""))) - ((and (eq system-type 'windows-nt) (w32-shell-dos-semantics)) + ((and (not posix) (eq system-type 'windows-nt) (w32-shell-dos-semantics)) ;; First, quote argument so that CommandLineToArgvW will ;; understand it. See @@ -3825,7 +4079,12 @@ remove properties specified by `yank-excluded-properties'." This function is like `insert', except it honors the variables `yank-handled-properties' and `yank-excluded-properties', and the -`yank-handler' text property, in the way that `yank' does." +`yank-handler' text property, in the way that `yank' does. + +It also runs the string through `yank-transform-functions'." + ;; Allow altering the yank string. + (run-hook-wrapped 'yank-transform-functions + (lambda (f) (setq string (funcall f string)) nil)) (let (to) (while (setq to (next-single-property-change 0 'yank-handler string)) (insert-for-yank-1 (substring string 0 to)) @@ -3989,7 +4248,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. @@ -4226,11 +4485,13 @@ in which case `save-window-excursion' cannot help." (defmacro with-output-to-temp-buffer (bufname &rest body) "Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer. -This construct makes buffer BUFNAME empty before running BODY. -It does not make the buffer current for BODY. -Instead it binds `standard-output' to that buffer, so that output -generated with `prin1' and similar functions in BODY goes into -the buffer. +This is a convenience macro meant for displaying help buffers and +the like. It empties the BUFNAME buffer before evaluating BODY +and disables undo in that buffer. + +It does not make the buffer current for BODY. Instead it binds +`standard-output' to that buffer, so that output generated with +`prin1' and similar functions in BODY goes into the buffer. At the end of BODY, this marks buffer BUFNAME unmodified and displays it in a window, but does not select it. The normal way to do this is @@ -4356,8 +4617,9 @@ of that nature." (unwind-protect (progn ,@body) - (unless ,modified - (restore-buffer-modified-p nil)))))) + (when (or (not ,modified) + (eq ,modified 'autosaved)) + (restore-buffer-modified-p ,modified)))))) (defmacro with-output-to-string (&rest body) "Execute BODY, return the text it sent to `standard-output', as a string." @@ -4386,12 +4648,7 @@ is allowed once again. (Immediately, if `inhibit-quit' is nil.)" ;; Without this, it will not be handled until the next function ;; call, and that might allow it to exit thru a condition-case ;; 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)) + (eval '(ignore nil) t)))) (defmacro while-no-input (&rest body) "Execute BODY only as long as there's no pending input. @@ -4451,19 +4708,21 @@ It should contain a single %-sequence; e.g., \"Error: %S\". If `debug-on-error' is non-nil, run BODY without catching its errors. This is to be used around code that is not expected to signal an error -but that should be robust in the unexpected case that an error is signaled. - -For backward compatibility, if FORMAT is not a constant string, it -is assumed to be part of BODY, in which case the message format -used is \"Error: %S\"." +but that should be robust in the unexpected case that an error is signaled." (declare (debug t) (indent 1)) - (let ((err (make-symbol "err")) - (format (if (and (stringp format) body) format - (prog1 "Error: %S" - (if format (push format body)))))) - `(condition-case-unless-debug ,err - ,(macroexp-progn body) - (error (message ,format ,err) nil)))) + (let* ((err (make-symbol "err")) + (orig-body body) + (format (if (and (stringp format) body) format + (prog1 "Error: %S" + (if format (push format body))))) + (exp + `(condition-case-unless-debug ,err + ,(macroexp-progn body) + (error (message ,format ,err) nil)))) + (if (eq orig-body body) exp + ;; The use without `format' is obsolete, let's warn when we bump + ;; into any such remaining uses. + (macroexp-warn-and-return "Missing format argument" exp nil nil format)))) (defmacro combine-after-change-calls (&rest body) "Execute BODY, but don't call the after-change functions till the end. @@ -4765,14 +5024,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. @@ -5577,6 +5834,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)) @@ -5791,6 +6049,10 @@ to deactivate this transient map, regardless of KEEP-PRED." t) ((eq t keep-pred) (let ((mc (lookup-key map (this-command-keys-vector)))) + ;; We may have a remapped command, so chase + ;; down that. + (when (and mc (symbolp mc)) + (setq mc (or (command-remapping mc) mc))) ;; If the key is unbound `this-command` is ;; nil and so is `mc`. (and mc (eq this-command mc)))) @@ -6464,4 +6726,175 @@ not a list, return a one-element list containing OBJECT." object (list object))) +(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))) + +(defun function-alias-p (func &optional noerror) + "Return nil if FUNC is not a function alias. +If FUNC is a function alias, return the function alias chain. + +If the function alias chain contains loops, an error will be +signalled. If NOERROR, the non-loop parts of the chain is returned." + (declare (side-effect-free t)) + (let ((chain nil) + (orig-func func)) + (nreverse + (catch 'loop + (while (and (symbolp func) + (setq func (symbol-function func)) + (symbolp func)) + (when (or (memq func chain) + (eq func orig-func)) + (if noerror + (throw 'loop chain) + (signal 'cyclic-function-indirection (list orig-func)))) + (push func chain)) + chain)))) + +(defun readablep (object) + "Say whether OBJECT has a readable syntax. +This means that OBJECT can be printed out and then read back +again by the Lisp reader. This function returns nil if OBJECT is +unreadable, and the printed representation (from `prin1') of +OBJECT if it is readable." + (declare (side-effect-free t)) + (catch 'unreadable + (let ((print-unreadable-function + (lambda (_object _escape) + (throw 'unreadable nil)))) + (prin1-to-string object)))) + +(defun delete-line () + "Delete the current line." + (delete-region (line-beginning-position) + (progn + (forward-line 1) + (point)))) + +(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)))))) + +(defun string-lines (string &optional omit-nulls keep-newlines) + "Split STRING into a list of lines. +If OMIT-NULLS, empty lines will be removed from the results. +If KEEP-NEWLINES, don't strip trailing newlines from the result +lines." + (if (equal string "") + (if omit-nulls + nil + (list "")) + (let ((lines nil) + (start 0)) + (while (< start (length string)) + (let ((newline (string-search "\n" string start))) + (if newline + (progn + (when (or (not omit-nulls) + (not (= start newline))) + (let ((line (substring string start + (if keep-newlines + (1+ newline) + newline)))) + (when (not (and keep-newlines omit-nulls + (equal line "\n"))) + (push line lines)))) + (setq start (1+ newline))) + ;; No newline in the remaining part. + (if (zerop start) + ;; Avoid a string copy if there are no newlines at all. + (push string lines) + (push (substring string start) lines)) + (setq start (length string))))) + (nreverse lines)))) + +(defun buffer-match-p (condition buffer-or-name &optional arg) + "Return non-nil if BUFFER-OR-NAME matches CONDITION. +CONDITION is either: +- a regular expression, to match a buffer name, +- a predicate function that takes a buffer object and ARG as + arguments, and returns non-nil if the buffer matches, +- a cons-cell, where the car describes how to interpret the cdr. + The car can be one of the following: + * `major-mode': the buffer matches if the buffer's major + mode is derived from the major mode denoted by the cons-cell's + cdr + * `not': the cdr is interpreted as a negation of a condition. + * `and': the cdr is a list of recursive conditions, that all have + to be met. + * `or': the cdr is a list of recursive condition, of which at + least one has to be met." + (letrec + ((buffer (get-buffer buffer-or-name)) + (match + (lambda (conditions) + (catch 'match + (dolist (condition conditions) + (when (cond + ((stringp condition) + (string-match-p condition (buffer-name buffer))) + ((functionp condition) + (if (eq 1 (cdr (func-arity condition))) + (funcall condition buffer) + (funcall condition buffer arg))) + ((eq (car-safe condition) 'major-mode) + (provided-mode-derived-p + (buffer-local-value 'major-mode buffer) + (cdr condition))) + ((eq (car-safe condition) 'not) + (not (funcall match (cdr condition)))) + ((eq (car-safe condition) 'or) + (funcall match (cdr condition))) + ((eq (car-safe condition) 'and) + (catch 'fail + (dolist (c (cdr conditions)) + (unless (funcall match c) + (throw 'fail nil))) + t))) + (throw 'match t))))))) + (funcall match (list condition)))) + +(defun match-buffers (condition &optional buffers arg) + "Return a list of buffers that match CONDITION. +See `buffer-match' for details on CONDITION. By default all +buffers are checked, this can be restricted by passing an +optional argument BUFFERS, set to a list of buffers to check. +ARG is passed to `buffer-match', for predicate conditions in +CONDITION." + (let (bufs) + (dolist (buf (or buffers (buffer-list))) + (when (buffer-match-p condition (get-buffer buf) arg) + (push buf bufs))) + bufs)) + ;;; subr.el ends here diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el index 5bfad5f9b11..705b0725012 100644 --- a/lisp/tab-bar.el +++ b/lisp/tab-bar.el @@ -229,7 +229,7 @@ a list of frames to update." (defun tab-bar--key-to-number (key) "Return the tab number represented by KEY. -If KEY is a symbol 'tab-N', where N is a tab number, the value is N. +If KEY is a symbol `tab-N', where N is a tab number, the value is N. If KEY is \\='current-tab, the value is nil. For any other value of KEY, the value is t." (cond @@ -426,7 +426,7 @@ on each new frame when the global `tab-bar-mode' is disabled, or if you want to disable the tab bar individually on each new frame when the global `tab-bar-mode' is enabled, by using - (add-hook 'after-make-frame-functions 'toggle-frame-tab-bar)" + (add-hook \\='after-make-frame-functions #\\='toggle-frame-tab-bar)" (interactive) (set-frame-parameter frame 'tab-bar-lines (if (> (frame-parameter frame 'tab-bar-lines) 0) 0 1)) @@ -474,18 +474,22 @@ you can use the command `toggle-frame-tab-bar'." If t, start a new tab with the current buffer, i.e. the buffer that was current before calling the command that adds a new tab (this is the same what `make-frame' does by default). +If the value is the symbol `window', then keep the selected +window as a single window on the new tab, and keep all its +window parameters except `window-atom' and `window-side'. If the value is a string, use it as a buffer name to switch to if such buffer exists, or switch to a buffer visiting the file or directory that the string specifies. If the value is a function, call it with no arguments and switch to the buffer that it returns. -If nil, duplicate the contents of the tab that was active +If `clone', duplicate the contents of the tab that was active before calling the command that adds a new tab." :type '(choice (const :tag "Current buffer" t) + (const :tag "Current window" window) (string :tag "Buffer" "*scratch*") (directory :tag "Directory" :value "~/") (file :tag "File" :value "~/.emacs") (function :tag "Function") - (const :tag "Duplicate tab" nil)) + (const :tag "Duplicate tab" clone)) :group 'tab-bar :version "27.1") @@ -751,9 +755,13 @@ Used by `tab-bar-format-menu-bar'." (menu-bar-keymap)) (popup-menu menu event))) +(defvar tab-bar-menu-bar-button + (propertize "Menu" 'face 'tab-bar-tab-inactive) + "Button for the menu bar.") + (defun tab-bar-format-menu-bar () "Produce the Menu button for the tab bar that shows the menu bar." - `((menu-bar menu-item (propertize "Menu" 'face 'tab-bar-tab-inactive) + `((menu-bar menu-item ,tab-bar-menu-bar-button tab-bar-menu-bar :help "Menu Bar"))) (defun tab-bar-format-history () @@ -907,8 +915,8 @@ when the tab is current. Return the result as a keymap." (let* ((rest (cdr (memq 'tab-bar-format-align-right tab-bar-format))) (rest (tab-bar-format-list rest)) (rest (mapconcat (lambda (item) (nth 2 item)) rest "")) - (hpos (length rest)) - (str (propertize " " 'display `(space :align-to (- right ,hpos))))) + (hpos (string-pixel-width (propertize rest 'face 'tab-bar))) + (str (propertize " " 'display `(space :align-to (- right (,hpos)))))) `((align-right menu-item ,str ignore)))) (defun tab-bar-format-global () @@ -918,7 +926,7 @@ When `tab-bar-format-global' is added to `tab-bar-format' then modes that display information on the mode line using `global-mode-string' will display the same text on the tab bar instead." - `((global menu-item ,(string-trim-right (format-mode-line global-mode-string)) ignore))) + `((global menu-item ,(format-mode-line global-mode-string) ignore))) (defun tab-bar-format-list (format-list) (let ((i 0)) @@ -982,10 +990,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 +1135,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 +1204,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 +1214,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) @@ -1301,7 +1318,8 @@ configuration." (let ((tab-bar-new-tab-choice 'window)) (tab-bar-new-tab)) (tab-bar-switch-to-recent-tab) - (delete-window) + (let ((ignore-window-parameters t)) + (delete-window)) (tab-bar-switch-to-recent-tab)) @@ -1348,14 +1366,26 @@ After the tab is created, the hooks in ;; Handle the case when it's called in the active minibuffer. (when (minibuffer-selected-window) (select-window (minibuffer-selected-window))) + ;; Remove window parameters that can cause problems + ;; with `delete-other-windows' and `split-window'. + (unless (eq tab-bar-new-tab-choice 'clone) + (set-window-parameter nil 'window-atom nil) + (set-window-parameter nil 'window-side nil)) (let ((ignore-window-parameters t)) - (delete-other-windows)) - (unless (eq tab-bar-new-tab-choice 'window) - ;; Create a new window to get rid of old window parameters - ;; (e.g. prev/next buffers) of old window. - (split-window) (delete-window)) + (if (eq tab-bar-new-tab-choice 'clone) + ;; Create new unique windows with the same layout + (window-state-put (window-state-get)) + (delete-other-windows) + (if (eq tab-bar-new-tab-choice 'window) + ;; Create new unique window from remaining window + (window-state-put (window-state-get)) + ;; Create a new window to get rid of old window parameters + ;; (e.g. prev/next buffers) of old window. + (split-window) (delete-window)))) + (let ((buffer - (if (functionp tab-bar-new-tab-choice) + (if (and (functionp tab-bar-new-tab-choice) + (not (memq tab-bar-new-tab-choice '(clone window)))) (funcall tab-bar-new-tab-choice) (if (stringp tab-bar-new-tab-choice) (or (get-buffer tab-bar-new-tab-choice) @@ -1388,6 +1418,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))) @@ -1426,7 +1461,7 @@ If FROM-NUMBER is a tab number, a new tab is created from that tab." "Clone the current tab to ARG positions to the right. ARG and FROM-NUMBER have the same meaning as in `tab-bar-new-tab'." (interactive "P") - (let ((tab-bar-new-tab-choice nil) + (let ((tab-bar-new-tab-choice 'clone) (tab-bar-new-tab-group t)) (tab-bar-new-tab arg from-number))) @@ -1624,9 +1659,10 @@ happens interactively)." (setq index (max 0 (min index (length tabs)))) (cl-pushnew tab (nthcdr index tabs)) (when (eq index 0) - ;; pushnew handles the head of tabs but not frame-parameter + ;; `pushnew' handles the head of tabs but not frame-parameter (tab-bar-tabs-set tabs)) - (tab-bar-select-tab (1+ index)))) + (tab-bar-select-tab (1+ index))) + (tab-bar--update-tab-bar-lines)) (message "No more closed tabs to undo"))) @@ -1803,30 +1839,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. @@ -1866,6 +1906,10 @@ This navigates forward in the history of window configurations." (goto-char wc-point))) (message "No more tab forward history")))) +(defvar-keymap tab-bar-history-mode-map + "C-c <left>" #'tab-bar-history-back + "C-c <right>" #'tab-bar-history-forward) + (define-minor-mode tab-bar-history-mode "Toggle tab history mode for the tab bar. Tab history mode remembers window configurations used in every tab, @@ -2276,9 +2320,9 @@ Interactively, prompt for the buffer to switch to." (declare (advertised-calling-convention (buffer-or-name) "28.1")) (interactive (list (read-buffer-to-switch "Switch to buffer in other tab: "))) - (display-buffer (window-normalize-buffer-to-switch-to buffer-or-name) - '((display-buffer-in-tab) - (inhibit-same-window . nil)))) + (pop-to-buffer (window-normalize-buffer-to-switch-to buffer-or-name) + '((display-buffer-in-tab) + (inhibit-same-window . nil)))) (defun find-file-other-tab (filename &optional wildcards) "Edit file FILENAME, in another tab. diff --git a/lisp/tab-line.el b/lisp/tab-line.el index 6aa3a858101..80b0aabd776 100644 --- a/lisp/tab-line.el +++ b/lisp/tab-line.el @@ -486,7 +486,7 @@ which the tab will represent." (funcall tab-line-tab-name-function tab tabs) (cdr (assq 'name tab)))) (face (if selected-p - (if (eq (selected-window) (old-selected-window)) + (if (mode-line-window-selected-p) 'tab-line-tab-current 'tab-line-tab) 'tab-line-tab-inactive))) @@ -495,6 +495,8 @@ which the tab will represent." (apply 'propertize (concat (propertize name 'keymap tab-line-tab-map + 'help-echo (if selected-p "Current tab" + "Click to select tab") ;; Don't turn mouse-1 into mouse-2 (bug#49247) 'follow-link 'ignore) (or (and (or buffer-p (assq 'buffer tab) (assq 'close tab)) @@ -556,8 +558,9 @@ inherit from `tab-line-tab-inactive-alternate'. For use in When TAB is a non-file-visiting buffer, make FACE inherit from `tab-line-tab-special'. For use in `tab-line-tab-face-functions'." - (when (and buffer-p (not (buffer-file-name tab))) - (setf face `(:inherit (tab-line-tab-special ,face)))) + (let ((buffer (if buffer-p tab (cdr (assq 'buffer tab))))) + (when (and buffer (not (buffer-file-name buffer))) + (setf face `(:inherit (tab-line-tab-special ,face))))) face) (defun tab-line-tab-face-modified (tab _tabs face buffer-p _selected-p) @@ -565,8 +568,9 @@ When TAB is a non-file-visiting buffer, make FACE inherit from When TAB is a modified, file-backed buffer, make FACE inherit from `tab-line-tab-modified'. For use in `tab-line-tab-face-functions'." - (when (and buffer-p (buffer-file-name tab) (buffer-modified-p tab)) - (setf face `(:inherit (tab-line-tab-modified ,face)))) + (let ((buffer (if buffer-p tab (cdr (assq 'buffer tab))))) + (when (and buffer (buffer-file-name buffer) (buffer-modified-p buffer)) + (setf face `(:inherit (tab-line-tab-modified ,face))))) face) (defun tab-line-tab-face-group (tab _tabs face _buffer-p _selected-p) @@ -587,7 +591,7 @@ For use in `tab-line-tab-face-functions'." ;; handle tab-line scrolling (window-parameter nil 'tab-line-hscroll) ;; for setting face 'tab-line-tab-current' - (eq (selected-window) (old-selected-window)) + (mode-line-window-selected-p) (and (memq 'tab-line-tab-face-modified tab-line-tab-face-functions) (buffer-file-name) (buffer-modified-p)))) @@ -798,7 +802,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) @@ -822,7 +828,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) @@ -899,7 +907,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/tar-mode.el b/lisp/tar-mode.el index d9085323d9a..ed48b568423 100644 --- a/lisp/tar-mode.el +++ b/lisp/tar-mode.el @@ -467,8 +467,8 @@ checksum before doing the check." (defun tar-clip-time-string (time) (declare (obsolete format-time-string "27.1")) - (let ((str (current-time-string time))) - (concat " " (substring str 4 16) (format-time-string " %Y" time)))) + (let ((system-time-locale "C")) + (format-time-string " %b %e %H:%M %Y" time))) (defun tar-grind-file-mode (mode) "Construct a `rw-r--r--' string indicating MODE. diff --git a/lisp/term.el b/lisp/term.el index 68ec9db800a..f81cbf72930 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) @@ -522,6 +523,16 @@ This means text can automatically reflow if the window is resized." (make-obsolete-variable 'term-suppress-hard-newline nil "27.1") +(defcustom term-clear-full-screen-programs t + "Whether to clear contents of full-screen terminal programs after exit. +If non-nil, output of full-screen terminal programs is cleared after +exiting them. Note however that a minority of such programs +don't send an appropriate escape sequence to the terminal before +exiting so their output isn't cleared regardless of this option." + :version "29.1" + :type 'boolean + :group 'term) + ;; Where gud-display-frame should put the debugging arrow. This is ;; set by the marker-filter, which scans the debugger's output for ;; indications of the current pc. @@ -710,13 +721,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 +783,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." @@ -876,6 +918,13 @@ is buffer-local." :type 'integer :version "27.1") +(defcustom term-bind-function-keys nil + "If nil, don't alter <f1>, <f2> and so on. +If non-nil, bind these keys in `term-mode' and send them to the +underlying shell." + :type 'boolean + :version "29.1") + ;; Set up term-raw-map, etc. @@ -916,6 +965,10 @@ is buffer-local." (define-key map [next] 'term-send-next) (define-key map [xterm-paste] #'term--xterm-paste) (define-key map [?\C-/] #'term-send-C-_) + + (when term-bind-function-keys + (dotimes (key 21) + (keymap-set map (format "<f%d>" key) #'term-send-function-key))) map) "Keyboard map for sending characters directly to the inferior process.") @@ -1034,15 +1087,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" @@ -1238,7 +1291,8 @@ Entry to this mode runs the hooks on `term-mode-hook'." (when (/= width term-width) (save-excursion (term--remove-fake-newlines))) - (let ((point (point))) + (let ((point (point)) + (home-marker (marker-position term-home-marker))) (setq term-height height) (setq term-width width) (setq term-start-line-column nil) @@ -1247,11 +1301,20 @@ Entry to this mode runs the hooks on `term-mode-hook'." (term--reset-scroll-region) ;; `term-set-scroll-region' causes these to be set, we have to ;; clear them again since we're changing point (Bug#30544). + (term--unwrap-visible-long-lines width) (setq term-start-line-column nil) (setq term-current-row nil) (setq term-current-column nil) - (goto-char point)) - (term--unwrap-visible-long-lines width))) + (goto-char point) + + (when (term-using-alternate-sub-buffer) + (term-handle-deferred-scroll) + ;; When using an alternative sub-buffer, the home marker should + ;; not move forward. Bring it back by deleting text in front of + ;; it. + (when (> term-home-marker home-marker) + (let ((inhibit-read-only t)) + (delete-region home-marker term-home-marker))))))) ;; Recursive routine used to check if any string in term-kill-echo-list ;; matches part of the buffer before point. @@ -1359,6 +1422,26 @@ Entry to this mode runs the hooks on `term-mode-hook'." (defun term-send-del () (interactive) (term-send-raw-string "\e[3~")) (defun term-send-backspace () (interactive) (term-send-raw-string "\C-?")) (defun term-send-C-_ () (interactive) (term-send-raw-string "\C-_")) + +(defun term-send-function-key () + "If bound to a function key, this will send that key to the underlying shell." + (interactive) + (let ((key (this-command-keys-vector))) + (when (and (= (length key) 1) + (symbolp (elt key 0))) + (let ((name (symbol-name (elt key 0)))) + (when (string-match "\\`f\\([0-9]+\\)\\'" name) + (let* ((num (string-to-number (match-string 1 name))) + (ansi + (cond + ((<= num 5) (+ num 10)) + ((<= num 10) (+ num 11)) + ((<= num 14) (+ num 12)) + ((<= num 16) (+ num 13)) + ((<= num 20) (+ num 14))))) + (when ansi + (term-send-raw-string (format "\e[%d~" ansi))))))))) + (defun term-char-mode () "Switch to char (\"raw\") sub-mode of term mode. @@ -1498,10 +1581,10 @@ commands to use in that buffer. (or explicit-shell-file-name (getenv "ESHELL") shell-file-name)))) - (set-buffer (make-term "terminal" program)) - (term-mode) + (let ((prog (split-string-shell-command program))) + (set-buffer (apply #'make-term "terminal" (car prog) nil (cdr prog)))) (term-char-mode) - (switch-to-buffer "*terminal*")) + (pop-to-buffer-same-window "*terminal*")) (defun term-exec (buffer name command startfile switches) "Start up a process in buffer for term modes. @@ -1580,11 +1663,14 @@ Using \"emacs\" loses, because bash disables editing if $TERM == emacs.") "%s%s:li#%d:co#%d:cl=\\E[H\\E[J:cd=\\E[J:bs:am:xn:cm=\\E[%%i%%d;%%dH\ :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\ +:NR:te=\\E[47l:ti=\\E[47h\ :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 +2461,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 +3197,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)) @@ -3256,13 +3353,16 @@ Called as a buffer-local `post-command-hook' function in `term-char-mode' to prevent commands from putting the buffer into an inconsistent state by unexpectedly moving point. -Mouse events are ignored so that mouse selection is unimpeded. +Mouse and wheel events are ignored so that mouse selection and +mouse wheel scrolling are unimpeded. Only acts when the pre-command position of point was equal to the process mark, and the `term-char-mode-point-at-process-mark' option is enabled. See `term-set-goto-process-mark'." (when term-goto-process-mark - (unless (mouse-event-p last-command-event) + (unless (or (mouse-event-p last-command-event) + (memq (event-basic-type last-command-event) + '(wheel-down wheel-up))) (goto-char (term-process-mark))))) (defun term-process-mark () @@ -3285,133 +3385,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) - @@ -3484,22 +3592,20 @@ return the bright version of COLOR; otherwise, return COLOR." ((eq char ?h) (cond ((eq (car params) 4) ;; (terminfo: smir) (setq term-insert-mode t)) - ;; ((eq (car params) 47) ;; (terminfo: smcup) - ;; (term-switch-to-alternate-sub-buffer t)) - )) + ((eq (car params) 47) ;; (terminfo: smcup) + (term-switch-to-alternate-sub-buffer t)))) ;; \E[?l - DEC Private Mode Reset ((eq char ?l) (cond ((eq (car params) 4) ;; (terminfo: rmir) (setq term-insert-mode nil)) - ;; ((eq (car params) 47) ;; (terminfo: rmcup) - ;; (term-switch-to-alternate-sub-buffer nil)) - )) + ((eq (car params) 47) ;; (terminfo: rmcup) + (term-switch-to-alternate-sub-buffer nil)))) ;; 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) @@ -3540,32 +3646,35 @@ The top-most line is line 0." (term-move-columns (- (term-current-column))) (term-goto 0 0)) -;; (defun term-switch-to-alternate-sub-buffer (set) -;; ;; If asked to switch to (from) the alternate sub-buffer, and already (not) -;; ;; using it, do nothing. This test is needed for some programs (including -;; ;; Emacs) that emit the ti termcap string twice, for unknown reason. -;; (term-handle-deferred-scroll) -;; (if (eq set (not (term-using-alternate-sub-buffer))) -;; (let ((row (term-current-row)) -;; (col (term-horizontal-column))) -;; (cond (set -;; (goto-char (point-max)) -;; (if (not (eq (preceding-char) ?\n)) -;; (term-insert-char ?\n 1)) -;; (setq term-scroll-with-delete t) -;; (setq term-saved-home-marker (copy-marker term-home-marker)) -;; (set-marker term-home-marker (point))) -;; (t -;; (setq term-scroll-with-delete -;; (not (and (= term-scroll-start 0) -;; (= term-scroll-end term-height)))) -;; (set-marker term-home-marker term-saved-home-marker) -;; (set-marker term-saved-home-marker nil) -;; (setq term-saved-home-marker nil) -;; (goto-char term-home-marker))) -;; (setq term-current-column nil) -;; (setq term-current-row 0) -;; (term-goto row col)))) +(defun term-switch-to-alternate-sub-buffer (set) + ;; If asked to switch to (from) the alternate sub-buffer, and already (not) + ;; using it, do nothing. This test is needed for some programs (including + ;; Emacs) that emit the ti termcap string twice, for unknown reason. + (term-handle-deferred-scroll) + (when (eq set (not (term-using-alternate-sub-buffer))) + (cond + (set + (goto-char (point-max)) + (if (not (eq (preceding-char) ?\n)) + (term-insert-char ?\n 1)) + (setq term-scroll-with-delete t) + (setq term-saved-home-marker (copy-marker term-home-marker)) + (set-marker term-home-marker (point))) + (t + (setq term-scroll-with-delete + (not (and (= term-scroll-start 0) + (= term-scroll-end (term--last-line))))) + (goto-char (point-max)) + (when term-clear-full-screen-programs + (delete-region term-home-marker (point)) + (set-marker term-home-marker term-saved-home-marker)) + (set-marker term-saved-home-marker nil) + (setq term-saved-home-marker nil))) + + (setq term-start-line-column nil) + (setq term-current-column nil) + (setq term-current-row nil) + (term-handle-deferred-scroll))) ;; Default value for the symbol term-command-function. @@ -4291,7 +4400,10 @@ and `C-x' being marked as a `term-escape-char'." ;; for now they have the *term-ansi-term*<?> form but we'll see... (setq term-ansi-buffer-name (generate-new-buffer-name term-ansi-buffer-name)) - (setq term-ansi-buffer-name (term-ansi-make-term term-ansi-buffer-name program)) + (let ((prog (split-string-shell-command program))) + (setq term-ansi-buffer-name + (apply #'term-ansi-make-term term-ansi-buffer-name (car prog) + nil (cdr prog)))) (set-buffer term-ansi-buffer-name) (term-mode) diff --git a/lisp/term/common-win.el b/lisp/term/common-win.el index 7a48fc04c6c..6f1e322aba5 100644 --- a/lisp/term/common-win.el +++ b/lisp/term/common-win.el @@ -65,7 +65,6 @@ (cons 4 'ns-drag-file) (cons 5 'ns-drag-color) (cons 6 'ns-drag-text) - (cons 7 'ns-change-font) (cons 8 'ns-open-file-line) ;;; (cons 9 'ns-insert-working-text) ;;; (cons 10 'ns-delete-working-text) @@ -419,6 +418,16 @@ the operating system.") (setq defined-colors (cons this-color defined-colors)))) defined-colors))) +;;;; Session management. + +(defvar emacs-save-session-functions nil + "Special hook run when a save-session event occurs. +The functions do not get any argument. +Functions can return non-nil to inform the session manager that the +window system shutdown should be aborted. + +See also `emacs-session-save'.") + (provide 'term/common-win) ;;; common-win.el ends here diff --git a/lisp/term/haiku-win.el b/lisp/term/haiku-win.el new file mode 100644 index 00000000000..0dcfc1e9205 --- /dev/null +++ b/lisp/term/haiku-win.el @@ -0,0 +1,470 @@ +;;; haiku-win.el --- set up windowing on Haiku -*- lexical-binding: t -*- + +;; Copyright (C) 2021-2022 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)) + +;;;; Command line argument handling. + +(defvar x-invocation-args) +(defvar x-command-line-resources) + +(defvar haiku-initialized) +(defvar haiku-signal-invalid-refs) +(defvar haiku-drag-track-function) +(defvar haiku-allowed-ui-colors) + +(defvar haiku-dnd-selection-value nil + "The local value of the special `XdndSelection' selection.") + +(defvar haiku-dnd-selection-converters '((STRING . haiku-dnd-convert-string) + (FILE_NAME . haiku-dnd-convert-file-name) + (text/uri-list . haiku-dnd-convert-text-uri-list)) + "Alist of X selection types to functions that act as selection converters. +The functions should accept a single argument VALUE, describing +the value of the drag-and-drop selection, and return a list of +two elements TYPE and DATA, where TYPE is a string containing the +MIME type of DATA, and DATA is a unibyte string, or nil if the +data could not be converted. + +DATA may also be a list of items; that means to add every +individual item in DATA to the serialized message, instead of +DATA in its entirety. + +DATA can optionally have a text property `type', which specifies +the type of DATA inside the system message (see the doc string of +`haiku-drag-message' for more details). If DATA is a list, then +that property is obtained from the first element of DATA.") + +(defvar haiku-normal-selection-encoders '(haiku-select-encode-xstring + haiku-select-encode-utf-8-string + haiku-select-encode-file-name) + "List of functions which act as selection encoders. +These functions accept two arguments SELECTION and VALUE, and +return an association appropriate for a serialized system +message (or nil if VALUE is not applicable to the encoder) that +will be put into the system selection SELECTION. VALUE is the +content that is being put into the selection by +`gui-set-selection'. See the doc string of `haiku-drag-message' +for more details on the structure of the associations.") + +;; This list has to be set correctly, otherwise Emacs will crash upon +;; encountering an invalid color. +(setq haiku-allowed-ui-colors + ["B_PANEL_BACKGROUND_COLOR" "B_MENU_BACKGROUND_COLOR" + "B_WINDOW_TAB_COLOR" "B_KEYBOARD_NAVIGATION_COLOR" + "B_DESKTOP_COLOR" "B_MENU_SELECTED_BACKGROUND_COLOR" + "B_MENU_ITEM_TEXT_COLOR" "B_MENU_SELECTED_ITEM_TEXT_COLOR" + "B_MENU_SELECTED_BORDER_COLOR" "B_PANEL_TEXT_COLOR" + "B_DOCUMENT_BACKGROUND_COLOR" "B_DOCUMENT_TEXT_COLOR" + "B_CONTROL_BACKGROUND_COLOR" "B_CONTROL_TEXT_COLOR" + "B_CONTROL_BORDER_COLOR" "B_CONTROL_HIGHLIGHT_COLOR" + "B_NAVIGATION_PULSE_COLOR" "B_SHINE_COLOR" + "B_SHADOW_COLOR" "B_TOOLTIP_BACKGROUND_COLOR" + "B_TOOLTIP_TEXT_COLOR" "B_WINDOW_TEXT_COLOR" + "B_WINDOW_INACTIVE_TAB_COLOR" "B_WINDOW_INACTIVE_TEXT_COLOR" + "B_WINDOW_BORDER_COLOR" "B_WINDOW_INACTIVE_BORDER_COLOR" + "B_CONTROL_MARK_COLOR" "B_LIST_BACKGROUND_COLOR" + "B_LIST_SELECTED_BACKGROUND_COLOR" "B_LIST_ITEM_TEXT_COLOR" + "B_LIST_SELECTED_ITEM_TEXT_COLOR" "B_SCROLL_BAR_THUMB_COLOR" + "B_LINK_TEXT_COLOR" "B_LINK_HOVER_COLOR" + "B_LINK_VISITED_COLOR" "B_LINK_ACTIVE_COLOR" + "B_STATUS_BAR_COLOR" "B_SUCCESS_COLOR" "B_FAILURE_COLOR"]) + +(defvar x-colors) +;; Also update `x-colors' to take that into account. +(setq x-colors (append haiku-allowed-ui-colors x-colors)) + +(defun haiku-selection-bounds (value) + "Return bounds of selection value VALUE. +The return value is a list (BEG END BUF) if VALUE is a cons of +two markers or an overlay. Otherwise, it is nil." + (cond ((bufferp value) + (with-current-buffer value + (when (mark t) + (list (mark t) (point) value)))) + ((and (consp value) + (markerp (car value)) + (markerp (cdr value))) + (when (and (marker-buffer (car value)) + (buffer-name (marker-buffer (car value))) + (eq (marker-buffer (car value)) + (marker-buffer (cdr value)))) + (list (marker-position (car value)) + (marker-position (cdr value)) + (marker-buffer (car value))))) + ((overlayp value) + (when (overlay-buffer value) + (list (overlay-start value) + (overlay-end value) + (overlay-buffer value)))))) + +(defun haiku-dnd-convert-string (value) + "Convert VALUE to a UTF-8 string and appropriate MIME type. +Return a list of the appropriate MIME type, and UTF-8 data of +VALUE as a unibyte string, or nil if VALUE was not a string." + (unless (stringp value) + (when-let ((bounds (haiku-selection-bounds value))) + (setq value (ignore-errors + (with-current-buffer (nth 2 bounds) + (buffer-substring (nth 0 bounds) + (nth 1 bounds))))))) + (when (stringp value) + (list "text/plain" (string-to-unibyte + (encode-coding-string value 'utf-8))))) + +(defun haiku-dnd-convert-file-name (value) + "Convert VALUE to a file system reference if it is a file name." + (cond ((and (stringp value) + (not (file-remote-p value)) + (file-exists-p value)) + (list "refs" (propertize (expand-file-name value) + 'type 'ref))) + ((vectorp value) + (list "refs" + (cl-loop for item across value + collect (propertize (expand-file-name item) + 'type 'ref)))))) + +(defun haiku-dnd-convert-text-uri-list (value) + "Convert VALUE to a list of URLs." + (cond + ((stringp value) (list "text/uri-list" + (concat (url-encode-url value) "\n"))) + ((vectorp value) (list "text/uri-list" + (with-temp-buffer + (cl-loop for tem across value + do (progn + (insert (url-encode-url tem)) + (insert "\n"))) + (buffer-string)))))) + +(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-owner-p "haikuselect.c") +(declare-function haiku-put-resource "haikufns.c") +(declare-function haiku-drag-message "haikuselect.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 + ((eq type 'STRING) "text/plain;charset=iso-8859-1") + ((eq type 'UTF8_STRING) "text/plain") + ((stringp type) type) + ((symbolp type) (symbol-name type)) + (t "text/plain"))) + +(defun haiku-selection-targets (clipboard) + "Find the types of data available from CLIPBOARD. +CLIPBOARD should be the symbol `PRIMARY', `SECONDARY' or +`CLIPBOARD'. Return the available types as a list of strings." + (mapcar #'car (haiku-selection-data clipboard nil))) + +(defun haiku-select-encode-xstring (_selection value) + "Convert VALUE to a system message association. +VALUE will be encoded as Latin-1 (like on X Windows) and stored +under the type `text/plain;charset=iso-8859-1'." + (unless (stringp value) + (when-let ((bounds (haiku-selection-bounds value))) + (setq value (ignore-errors + (with-current-buffer (nth 2 bounds) + (buffer-substring (nth 0 bounds) + (nth 1 bounds))))))) + (when (and (stringp value) (not (string-empty-p value))) + (list "text/plain;charset=iso-8859-1" 1296649541 + (encode-coding-string value 'iso-latin-1)))) + +(defun haiku-select-encode-utf-8-string (_selection value) + "Convert VALUE to a system message association. +VALUE will be encoded as UTF-8 and stored under the type +`text/plain'." + (unless (stringp value) + (when-let ((bounds (haiku-selection-bounds value))) + (setq value (ignore-errors + (with-current-buffer (nth 2 bounds) + (buffer-substring (nth 0 bounds) + (nth 1 bounds))))))) + (when (and (stringp value) (not (string-empty-p value))) + (list "text/plain" 1296649541 + (encode-coding-string value 'utf-8-unix)))) + +(defun haiku-select-encode-file-name (_selection value) + "Convert VALUE to a system message association. +This takes the file name of VALUE's buffer (if it is an overlay +or a pair of markers) and turns it into a file system reference." + (when (setq value (xselect--selection-bounds value)) + (list "refs" 'ref (buffer-file-name (nth 2 value))))) + +(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))) + (if (eq type 'XdndSelection) + haiku-dnd-selection-value + (haiku-selection-data type (haiku--selection-type-to-mime data-type))))) + +(cl-defmethod gui-backend-set-selection (type value + &context (window-system haiku)) + (if (eq type 'XdndSelection) + (setq haiku-dnd-selection-value value) + (let ((message nil)) + (dolist (encoder haiku-normal-selection-encoders) + (let ((result (funcall encoder type value))) + (when result + (push result message)))) + (haiku-selection-put type message)))) + +(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 (selection &context (window-system haiku)) + (haiku-selection-owner-p selection)) + +(declare-function haiku-read-file-name "haikufns.c") + +(defun x-file-dialog (prompt dir &optional default-filename mustmatch only-dir-p) + "SKIP: real doc in xfns.c." + (if (eq (framep-on-display (selected-frame)) 'haiku) + (haiku-read-file-name (if (not (string-suffix-p ": " prompt)) + prompt + (substring prompt 0 (- (length prompt) 2))) + (selected-frame) + (or dir (and default-filename + (file-name-directory default-filename))) + mustmatch only-dir-p + (and default-filename + (file-name-nondirectory default-filename))) + (error "x-file-dialog on a tty frame"))) + +(defun haiku-drag-and-drop (event) + "Handle specified drag-n-drop EVENT." + (interactive "e") + (let* ((string (caddr event)) + (window (posn-window (event-start event)))) + (if (eq string 'lambda) ; This means the mouse moved. + (dnd-handle-movement (event-start event)) + (cond + ((assoc "refs" string) + (with-selected-window window + (raise-frame) + (dolist (filename (cddr (assoc "refs" string))) + (dnd-handle-one-url window 'private + (concat "file:" filename))))) + ((assoc "text/uri-list" string) + (dolist (text (cddr (assoc "text/uri-list" string))) + (let ((uri-list (split-string text "[\0\r\n]" t))) + (dolist (bf uri-list) + (dnd-handle-one-url window 'private bf))))) + ((assoc "text/plain" string) + (with-selected-window window + (raise-frame) + (dolist (text (cddr (assoc "text/plain" string))) + (goto-char (posn-point (event-start event))) + (dnd-insert-text window 'private + (if (multibyte-string-p text) + text + (decode-coding-string text 'undecided)))))) + ((not (eq (cdr (assq 'type string)) + 3003)) ; Type of the placeholder message Emacs uses + ; to cancel a drop on C-g. + (message "Don't know how to drop any of: %s" + (mapcar #'car string))))))) + +(define-key special-event-map [drag-n-drop] 'haiku-drag-and-drop) + +(defvaralias 'haiku-use-system-tooltips 'use-system-tooltips) + +(defun haiku-use-system-tooltips-watcher (&rest _ignored) + "Variable watcher to force a menu bar update when `use-system-tooltip' changes. +This is necessary because on Haiku `use-system-tooltip' doesn't +take effect on menu items until the menu bar is updated again." + (force-mode-line-update t)) + +;; Note that `mouse-position' can't return the actual frame the mouse +;; pointer is under, so this only works for the frame where the drop +;; started. +(defun haiku-dnd-drag-handler () + "Handle mouse movement during drag-and-drop." + (let ((track-mouse 'drag-source) + (mouse-position (mouse-pixel-position))) + (when (car mouse-position) + (dnd-handle-movement (posn-at-x-y (cadr mouse-position) + (cddr mouse-position) + (car mouse-position))) + (redisplay)))) + +(setq haiku-drag-track-function #'haiku-dnd-drag-handler) + +(defun x-begin-drag (targets &optional action frame _return-frame allow-current-frame) + "SKIP: real doc in xfns.c." + (unless haiku-dnd-selection-value + (error "No local value for XdndSelection")) + (let ((message nil) + (mouse-highlight nil) + (haiku-signal-invalid-refs nil)) + (dolist (target targets) + (let* ((target-atom (intern target)) + (selection-converter (cdr (assoc target-atom + haiku-dnd-selection-converters))) + (value (if (stringp haiku-dnd-selection-value) + (or (get-text-property 0 target-atom + haiku-dnd-selection-value) + haiku-dnd-selection-value) + haiku-dnd-selection-value))) + (when selection-converter + (let ((selection-result (funcall selection-converter value))) + (when selection-result + (let* ((field (cdr (assoc (car selection-result) message))) + (maybe-string (if (stringp (cadr selection-result)) + (cadr selection-result) + (caadr selection-result)))) + (unless (cadr field) + ;; Add B_MIME_TYPE to the message if the type was not + ;; previously specified, or the type if it was. + (push (or (get-text-property 0 'type maybe-string) + 1296649541) + (alist-get (car selection-result) message + nil nil #'equal)))) + (if (not (consp (cadr selection-result))) + (push (cadr selection-result) + (cdr (alist-get (car selection-result) message + nil nil #'equal))) + (dolist (tem (cadr selection-result)) + (push tem + (cdr (alist-get (car selection-result) message + nil nil #'equal)))))))))) + (prog1 (or (and (symbolp action) + action) + 'XdndActionCopy) + (haiku-drag-message (or frame (selected-frame)) + message allow-current-frame)))) + +(add-variable-watcher 'use-system-tooltips #'haiku-use-system-tooltips-watcher) + + +;;;; Session management. + +(declare-function haiku-save-session-reply "haikufns.c") + +(defun emacs-session-save () + "SKIP: real doc in x-win.el." + (with-temp-buffer ; Saving sessions is not yet supported. + (condition-case nil + ;; A return of t means cancel the shutdown. + (run-hook-with-args-until-success + 'emacs-save-session-functions) + (error t)))) + +(defun handle-save-session (_event) + "SKIP: real doc in xsmfns.c." + (interactive "e") + (let ((cancel-shutdown t)) + (unwind-protect + (setq cancel-shutdown (emacs-session-save)) + (haiku-save-session-reply (not cancel-shutdown))) + ;; The App Server will kill Emacs after receiving the reply, but + ;; the Deskbar will not, so kill ourself here. + (unless cancel-shutdown (kill-emacs)))) + + +;;;; Cursors. + +;; We use the same interface as X, but the cursor numbers are +;; different, and there are also less cursors. + +(defconst x-pointer-X-cursor 5) ; B_CURSOR_ID_CROSS_HAIR +(defconst x-pointer-arrow 1) ; B_CURSOR_ID_SYSTEM_DEFAULT +(defconst x-pointer-bottom-left-corner 22) ; B_CURSOR_ID_RESIZE_SOUTH_WEST +(defconst x-pointer-bottom-right-corner 21) ; B_CURSOR_ID_RESIZE_SOUTH_EAST +(defconst x-pointer-bottom-side 17) ; B_CURSOR_ID_RESIZE_SOUTH +(defconst x-pointer-clock 14) ; B_CURSOR_ID_PROGRESS +(defconst x-pointer-cross 5) ; B_CURSOR_ID_CROSS_HAIR +(defconst x-pointer-cross-reverse 5) ; B_CURSOR_ID_CROSS_HAIR +(defconst x-pointer-crosshair 5) ; B_CURSOR_ID_CROSS_HAIR +(defconst x-pointer-diamond-cross 5) ; B_CURSOR_ID_CROSS_HAIR +(defconst x-pointer-hand1 7) ; B_CURSOR_ID_GRAB +(defconst x-pointer-hand2 8) ; B_CURSOR_ID_GRABBING +(defconst x-pointer-left-side 18) ; B_CURSOR_ID_RESIZE_WEST +(defconst x-pointer-right-side 16) ; B_CURSOR_ID_RESIZE_EAST +(defconst x-pointer-sb-down-arrow 17) ; B_CURSOR_ID_RESIZE_SOUTH +(defconst x-pointer-sb-left-arrow 18) ; B_CURSOR_ID_RESIZE_WEST +(defconst x-pointer-sb-right-arrow 16) ; B_CURSOR_ID_RESIZE_EAST +(defconst x-pointer-sb-up-arrow 16) ; B_CURSOR_ID_RESIZE_NORTH +(defconst x-pointer-target 5) ; B_CURSOR_ID_CROSS_HAIR +(defconst x-pointer-top-left-corner 20) ; B_CURSOR_ID_RESIZE_NORTH_WEST +(defconst x-pointer-top-right-corner 19) ; B_CURSOR_ID_RESIZE_NORTH_EAST +(defconst x-pointer-top-side 16) ; B_CURSOR_ID_RESIZE_NORTH +(defconst x-pointer-watch 14) ; B_CURSOR_ID_PROGRESS +(defconst x-pointer-invisible 12) ; B_CURSOR_ID_NO_CURSOR + +(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 ffcd7a852c2..2e021b9b29c 100644 --- a/lisp/term/ns-win.el +++ b/lisp/term/ns-win.el @@ -176,7 +176,6 @@ The properties returned may include `top', `left', `height', and `width'." (define-key global-map [ns-power-off] 'save-buffers-kill-emacs) (define-key global-map [ns-open-file] 'ns-find-file) (define-key global-map [ns-open-temp-file] [ns-open-file]) -(define-key global-map [ns-change-font] 'ns-respond-to-change-font) (define-key global-map [ns-open-file-line] 'ns-open-file-select-line) (define-key global-map [ns-spi-service-call] 'ns-spi-service-call) (define-key global-map [ns-new-frame] 'make-frame) @@ -508,25 +507,28 @@ unless the current buffer is a scratch buffer." Switch to a buffer editing the last file dropped, or insert the string dropped into the current buffer." (interactive "e") - (let* ((window (posn-window (event-start event))) - (arg (car (cdr (cdr event)))) - (type (car arg)) - (operations (car (cdr arg))) - (objects (cdr (cdr arg))) - (string (mapconcat 'identity objects "\n"))) - (set-frame-selected-window nil window) - (raise-frame) - (setq window (selected-window)) - (cond ((or (memq 'ns-drag-operation-generic operations) - (memq 'ns-drag-operation-copy operations)) - ;; Perform the default/copy action. - (dolist (data objects) - (dnd-handle-one-url window 'private (if (eq type 'file) - (concat "file:" data) - data)))) - (t - ;; Insert the text as is. - (dnd-insert-text window 'private string))))) + (if (eq (car-safe (cdr-safe (cdr-safe event))) 'lambda) + (dnd-handle-movement (event-start event)) + (let* ((window (posn-window (event-start event))) + (arg (car (cdr (cdr event)))) + (type (car arg)) + (operations (car (cdr arg))) + (objects (cdr (cdr arg))) + (string (mapconcat 'identity objects "\n"))) + (set-frame-selected-window nil window) + (raise-frame) + (setq window (selected-window)) + (goto-char (posn-point (event-start event))) + (cond ((or (memq 'ns-drag-operation-generic operations) + (memq 'ns-drag-operation-copy operations)) + ;; Perform the default/copy action. + (dolist (data objects) + (dnd-handle-one-url window 'private (if (eq type 'file) + (concat "file:" data) + data)))) + (t + ;; Insert the text as is. + (dnd-insert-text window 'private string)))))) (global-set-key [drag-n-drop] 'ns-drag-n-drop) @@ -620,34 +622,6 @@ If FRAME is nil, the change applies to the selected frame." ;; Needed for font listing functions under both backend and normal (setq scalable-fonts-allowed t) -;; Set to use font panel instead -(declare-function ns-popup-font-panel "nsfns.m" (&optional frame)) -(defalias 'x-select-font 'ns-popup-font-panel "Pop up the font panel. -This function has been overloaded in Nextstep.") -(defalias 'mouse-set-font 'ns-popup-font-panel "Pop up the font panel. -This function has been overloaded in Nextstep.") - -;; nsterm.m -(defvar ns-input-font) -(defvar ns-input-fontsize) - -(defun ns-respond-to-change-font () - "Set the font chosen in the font-picker panel. -Respond to changeFont: event, expecting ns-input-font and -ns-input-fontsize of new font." - (interactive) - (let ((face 'default)) - (set-face-attribute face t - :family ns-input-font - :height (* 10 ns-input-fontsize)) - (set-face-attribute face (selected-frame) - :family ns-input-font - :height (* 10 ns-input-fontsize)) - (let ((spec (list (list t (face-attr-construct 'default))))) - (put face 'customized-face spec) - (custom-push-theme 'theme-face face 'user 'set spec) - (put face 'face-modified nil)))) - ;; Default fontset for macOS. This is mainly here to show how a fontset ;; can be set up manually. Ordinarily, fontsets are auto-created whenever ;; a font is chosen by @@ -867,10 +841,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: @@ -896,12 +870,18 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.") (declare-function ns-disown-selection-internal "nsselect.m" (selection)) (declare-function ns-selection-owner-p "nsselect.m" (&optional selection)) (declare-function ns-selection-exists-p "nsselect.m" (&optional selection)) +(declare-function ns-begin-drag "nsselect.m") + +(defvar ns-dnd-selection-value nil + "The value of the special `XdndSelection' selection on NS.") + (declare-function ns-get-selection "nsselect.m" (selection-symbol target-type)) -(cl-defmethod gui-backend-set-selection (selection value - &context (window-system ns)) - (if value (ns-own-selection-internal selection value) - (ns-disown-selection-internal selection))) +(cl-defmethod gui-backend-set-selection (selection value &context (window-system ns)) + (if (eq selection 'XdndSelection) + (setq ns-dnd-selection-value value) + (if value (ns-own-selection-internal selection value) + (ns-disown-selection-internal selection)))) (cl-defmethod gui-backend-selection-owner-p (selection &context (window-system ns)) @@ -915,6 +895,39 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.") &context (window-system ns)) (ns-get-selection selection-symbol target-type)) +(defun x-begin-drag (targets &optional action frame return-frame allow-current-frame) + "SKIP: real doc in xfns.c." + (unless ns-dnd-selection-value + (error "No local value for XdndSelection")) + (let ((pasteboard nil)) + (when (and (member "STRING" targets) + (stringp ns-dnd-selection-value)) + (push (cons 'string ns-dnd-selection-value) pasteboard)) + (when (and (member "FILE_NAME" targets) + (file-exists-p ns-dnd-selection-value)) + (let ((value (if (stringp ns-dnd-selection-value) + (or (get-text-property 0 'FILE_NAME + ns-dnd-selection-value) + ns-dnd-selection-value) + ns-dnd-selection-value))) + (if (vectorp value) + (push (cons 'file + (cl-loop for file across value + collect (expand-file-name file))) + pasteboard) + (push (cons 'file + (url-encode-url (concat "file://" + (expand-file-name + ns-dnd-selection-value)))) + pasteboard)))) + (ns-begin-drag frame pasteboard action return-frame allow-current-frame))) + +(defun ns-handle-drag-motion (frame x y) + "Handle mouse movement on FRAME at X and Y during drag-and-drop. +This moves point to the current mouse position if + `dnd-indicate-insertion-point' is enabled." + (dnd-handle-movement (posn-at-x-y x y frame))) + (provide 'ns-win) (provide 'term/ns-win) diff --git a/lisp/term/pc-win.el b/lisp/term/pc-win.el index 327d51f2759..514267a52d6 100644 --- a/lisp/term/pc-win.el +++ b/lisp/term/pc-win.el @@ -246,6 +246,14 @@ Consult the selection. Treat empty strings as if they were unset." ;; if it does not exist, or exists and compares ;; equal with the last text we've put into the ;; Windows clipboard. + ;; NOTE: that variable is actually the last text any program + ;; (not just Emacs) has put into the windows clipboard (up + ;; until the last time Emacs read or set the clipboard), so + ;; it's not suitable for checking actual selection + ;; ownership. This should not result in a bug for the current + ;; uses of gui-backend-selection-owner however, since they + ;; don't actually care about selection ownership, but about + ;; the selected text having changed. (cond ((not text) t) ((equal text gui--last-selected-text-clipboard) text) diff --git a/lisp/term/pgtk-win.el b/lisp/term/pgtk-win.el new file mode 100644 index 00000000000..8abea3edba6 --- /dev/null +++ b/lisp/term/pgtk-win.el @@ -0,0 +1,395 @@ +;;; pgtk-win.el --- parse relevant switches and set up for Pure-GTK -*- lexical-binding: t -*- + +;; Copyright (C) 1995, 2001-2020, 2022 Free Software Foundation, Inc. + +;; Author: FSF +;; Keywords: terminals + +;; 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)) +(unless (featurep 'pgtk) + (error "%s: Loading pgtk-win.el but not compiled with PGTK." + invocation-name)) + +;; Documentation-purposes only: actually loaded in loadup.el. +(require 'term/common-win) +(require 'frame) +(require 'mouse) +(require 'scroll-bar) +(require 'faces) +(require 'menu-bar) +(require 'fontset) +(require 'dnd) + +(defvar x-invocation-args) +(defvar x-command-line-resources) +(defvar pgtk-input-file) +(defvar pgtk-use-im-context-on-new-connection) + +(declare-function pgtk-use-im-context "pgtkim.c") + +(defun pgtk-drag-n-drop (event &optional new-frame force-text) + "Edit the files listed in the drag-n-drop EVENT. +Switch to a buffer editing the last file dropped." + (interactive "e") + (let* ((window (posn-window (event-start event))) + (arg (car (cdr (cdr event)))) + (type (car arg)) + (data (car (cdr arg))) + (url-or-string (cond ((eq type 'file) + (concat "file:" data)) + (t data)))) + (set-frame-selected-window nil window) + (when new-frame + (select-frame (make-frame))) + (raise-frame) + (setq window (selected-window)) + (if force-text + (dnd-insert-text window 'private data) + (dnd-handle-one-url window 'private url-or-string)))) + +(defun pgtk-drag-n-drop-other-frame (event) + "Edit the files listed in the drag-n-drop EVENT, in other frames. +May create new frames, or reuse existing ones. The frame editing +the last file dropped is selected." + (interactive "e") + (pgtk-drag-n-drop event t)) + +(defun pgtk-drag-n-drop-as-text (event) + "Drop the data in EVENT as text." + (interactive "e") + (pgtk-drag-n-drop event nil t)) + +(defun pgtk-drag-n-drop-as-text-other-frame (event) + "Drop the data in EVENT as text in a new frame." + (interactive "e") + (pgtk-drag-n-drop event t t)) + +(global-set-key [drag-n-drop] 'pgtk-drag-n-drop) + +(defun pgtk-suspend-error () + "Don't allow suspending if any of the frames are PGTK frames." + (if (memq 'pgtk (mapcar 'window-system (frame-list))) + (error "Cannot suspend Emacs while a PGTK GUI frame exists"))) + +(defvar pgtk-initialized nil + "Non-nil if pure-GTK windowing has been initialized.") + +(declare-function x-handle-args "common-win" (args)) +(declare-function x-open-connection "pgtkfns.c" + (display &optional xrm-string must-succeed)) +(declare-function pgtk-set-resource "pgtkfns.c" (attribute value)) + +;; Do the actual window system setup here; the above code just defines +;; functions and variables that we use now. +(cl-defmethod window-system-initialization (&context (window-system pgtk) + &optional display) + "Initialize the PGTK window system. +WINDOW-SYSTEM is, aptly, `pgtk'. +DISPLAY is the name of the display Emacs should connect to." + (cl-assert (not pgtk-initialized)) + + ;; PENDING: not needed? + (setq command-line-args (x-handle-args command-line-args)) + + ;; Make sure we have a valid resource name. + (when (boundp 'x-resource-name) + (unless (stringp x-resource-name) + (let (i) + (setq x-resource-name (copy-sequence invocation-name)) + + ;; Change any . or * characters in x-resource-name to hyphens, + ;; so as not to choke when we use it in X resource queries. + (while (setq i (string-match "[.*]" x-resource-name)) + (aset x-resource-name i ?-))))) + + ;; Setup the default fontset. + (create-default-fontset) + ;; Create the standard fontset. + (condition-case err + (create-fontset-from-fontset-spec standard-fontset-spec t) + (error (display-warning + 'initialization + (format "Creation of the standard fontset failed: %s" err) + :error))) + + (x-open-connection (or display + x-display-name) + x-command-line-resources + ;; Exit Emacs with fatal error if this fails and we + ;; are the initial display. + (= (length (frame-list)) 0)) + + (x-apply-session-resources) + + ;; Don't let Emacs suspend under PGTK. + (add-hook 'suspend-hook 'pgtk-suspend-error) + + (setq pgtk-initialized t)) + +;; Any display name is OK. +(add-to-list 'display-format-alist '(".*" . pgtk)) + +(cl-defmethod handle-args-function (args &context (window-system pgtk)) + (x-handle-args args)) + +(cl-defmethod frame-creation-function (params &context (window-system pgtk)) + (x-create-frame-with-faces params)) + +(declare-function pgtk-own-selection-internal "pgtkselect.c" (selection value &optional frame)) +(declare-function pgtk-disown-selection-internal "pgtkselect.c" (selection &optional terminal)) +(declare-function pgtk-selection-owner-p "pgtkselect.c" (&optional selection terminal)) +(declare-function pgtk-selection-exists-p "pgtkselect.c" (&optional selection terminal)) +(declare-function pgtk-get-selection-internal "pgtkselect.c" (selection-symbol target-type &optional terminal)) + +(cl-defmethod gui-backend-set-selection (selection value + &context (window-system pgtk)) + (if value (pgtk-own-selection-internal selection value) + (pgtk-disown-selection-internal selection))) + +(cl-defmethod gui-backend-selection-owner-p (selection + &context (window-system pgtk)) + (pgtk-selection-owner-p selection)) + +(cl-defmethod gui-backend-selection-exists-p (selection + &context (window-system pgtk)) + (pgtk-selection-exists-p selection)) + +(cl-defmethod gui-backend-get-selection (selection-symbol target-type + &context (window-system pgtk)) + (pgtk-get-selection-internal selection-symbol target-type)) + + +(defvar pgtk-preedit-overlay nil) + +(defun pgtk-preedit-text (event) + "An internal function to display preedit text from input method. + +EVENT is a `preedit-text-event'." + (interactive "e") + (when pgtk-preedit-overlay + (delete-overlay pgtk-preedit-overlay)) + (setq pgtk-preedit-overlay nil) + + (let ((ovstr "") + (idx 0) + atts ov str color face-name) + (dolist (part (nth 1 event)) + (setq str (car part)) + (setq face-name (intern (format "pgtk-im-%d" idx))) + (eval + `(defface ,face-name nil "face of input method preedit")) + (setq atts nil) + (when (setq color (cdr-safe (assq 'fg (cdr part)))) + (setq atts (append atts `(:foreground ,color)))) + (when (setq color (cdr-safe (assq 'bg (cdr part)))) + (setq atts (append atts `(:background ,color)))) + (when (setq color (cdr-safe (assq 'ul (cdr part)))) + (setq atts (append atts `(:underline ,color)))) + (face-spec-set face-name `((t . ,atts))) + (add-text-properties 0 (length str) `(face ,face-name) str) + (setq ovstr (concat ovstr str)) + (setq idx (1+ idx))) + + (setq ov (make-overlay (point) (point))) + (overlay-put ov 'before-string ovstr) + (setq pgtk-preedit-overlay ov))) + +(define-key special-event-map [preedit-text] 'pgtk-preedit-text) + +(defun pgtk-use-im-context-handler () + "Set up input context usage after Emacs initialization." + (when (eq window-system 'pgtk) + (pgtk-use-im-context pgtk-use-im-context-on-new-connection))) + +(add-hook 'after-init-hook #'pgtk-use-im-context-handler) + +(defcustom x-gtk-stock-map + (mapcar (lambda (arg) + (cons (purecopy (car arg)) (purecopy (cdr arg)))) + '( + ("etc/images/new" . ("document-new" "gtk-new")) + ("etc/images/open" . ("document-open" "gtk-open")) + ("etc/images/diropen" . "n:system-file-manager") + ("etc/images/close" . ("window-close" "gtk-close")) + ("etc/images/save" . ("document-save" "gtk-save")) + ("etc/images/saveas" . ("document-save-as" "gtk-save-as")) + ("etc/images/undo" . ("edit-undo" "gtk-undo")) + ("etc/images/cut" . ("edit-cut" "gtk-cut")) + ("etc/images/copy" . ("edit-copy" "gtk-copy")) + ("etc/images/paste" . ("edit-paste" "gtk-paste")) + ("etc/images/search" . ("edit-find" "gtk-find")) + ("etc/images/print" . ("document-print" "gtk-print")) + ("etc/images/preferences" . ("preferences-system" "gtk-preferences")) + ("etc/images/help" . ("help-browser" "gtk-help")) + ("etc/images/left-arrow" . ("go-previous" "gtk-go-back")) + ("etc/images/right-arrow" . ("go-next" "gtk-go-forward")) + ("etc/images/home" . ("go-home" "gtk-home")) + ("etc/images/jump-to" . ("go-jump" "gtk-jump-to")) + ("etc/images/index" . ("gtk-search" "gtk-index")) + ("etc/images/exit" . ("application-exit" "gtk-quit")) + ("etc/images/cancel" . "gtk-cancel") + ("etc/images/info" . ("dialog-information" "gtk-info")) + ("etc/images/bookmark_add" . "n:bookmark_add") + ;; Used in Gnus and/or MH-E: + ("etc/images/attach" . ("mail-attachment" "gtk-attach")) + ("etc/images/connect" . "gtk-connect") + ("etc/images/contact" . "gtk-contact") + ("etc/images/delete" . ("edit-delete" "gtk-delete")) + ("etc/images/describe" . ("document-properties" "gtk-properties")) + ("etc/images/disconnect" . "gtk-disconnect") + ;; ("etc/images/exit" . "gtk-exit") + ("etc/images/lock-broken" . "gtk-lock_broken") + ("etc/images/lock-ok" . "gtk-lock_ok") + ("etc/images/lock" . "gtk-lock") + ("etc/images/next-page" . "gtk-next-page") + ("etc/images/refresh" . ("view-refresh" "gtk-refresh")) + ("etc/images/search-replace" . "edit-find-replace") + ("etc/images/sort-ascending" . ("view-sort-ascending" "gtk-sort-ascending")) + ("etc/images/sort-column-ascending" . "gtk-sort-column-ascending") + ("etc/images/sort-criteria" . "gtk-sort-criteria") + ("etc/images/sort-descending" . ("view-sort-descending" + "gtk-sort-descending")) + ("etc/images/sort-row-ascending" . "gtk-sort-row-ascending") + ("etc/images/spell" . ("tools-check-spelling" "gtk-spell-check")) + ("images/gnus/toggle-subscription" . "gtk-task-recurring") + ("images/mail/compose" . ("mail-message-new" "gtk-mail-compose")) + ("images/mail/copy" . "gtk-mail-copy") + ("images/mail/forward" . "gtk-mail-forward") + ("images/mail/inbox" . "gtk-inbox") + ("images/mail/move" . "gtk-mail-move") + ("images/mail/not-spam" . "gtk-not-spam") + ("images/mail/outbox" . "gtk-outbox") + ("images/mail/reply-all" . "gtk-mail-reply-to-all") + ("images/mail/reply" . "gtk-mail-reply") + ("images/mail/save-draft" . "gtk-mail-handling") + ("images/mail/send" . ("mail-send" "gtk-mail-send")) + ("images/mail/spam" . "gtk-spam") + ;; Used for GDB Graphical Interface + ("images/gud/break" . "gtk-no") + ("images/gud/recstart" . ("media-record" "gtk-media-record")) + ("images/gud/recstop" . ("media-playback-stop" "gtk-media-stop")) + ;; No themed versions available: + ;; mail/preview (combining stock_mail and stock_zoom) + ;; mail/save (combining stock_mail, stock_save and stock_convert) + )) + "How icons for tool bars are mapped to Gtk+ stock items. +Emacs must be compiled with the Gtk+ toolkit for this to have any effect. +A value that begins with n: denotes a named icon instead of a stock icon." + :version "22.2" + :type '(choice (repeat + (choice symbol + (cons (string :tag "Emacs icon") + (choice (group (string :tag "Named") + (string :tag "Stock")) + (string :tag "Stock/named")))))) + :group 'pgtk) + +(defcustom icon-map-list '(x-gtk-stock-map) + "A list of alists that map icon file names to stock/named icons. +The alists are searched in the order they appear. The first match is used. +The keys in the alists are file names without extension and with two directory +components. For example, to map /usr/share/emacs/22.1.1/etc/images/open.xpm +to stock item gtk-open, use: + + (\"etc/images/open\" . \"gtk-open\") + +Themes also have named icons. To map to one of those, use n: before the name: + + (\"etc/images/diropen\" . \"n:system-file-manager\") + +The list elements are either the symbol name for the alist or the +alist itself. + +If you don't want stock icons, set the variable to nil." + :version "22.2" + :type '(choice (const :tag "Don't use stock icons" nil) + (repeat (choice symbol + (cons (string :tag "Emacs icon") + (string :tag "Stock/named"))))) + :group 'pgtk) + +(defconst x-gtk-stock-cache (make-hash-table :weakness t :test 'equal)) + +(defun x-gtk-map-stock (file) + "Map icon with file name FILE to a Gtk+ stock name. +This uses `icon-map-list' to map icon file names to stock icon names." + (when (stringp file) + (or (gethash file x-gtk-stock-cache) + (puthash + file + (save-match-data + (let* ((file-sans (file-name-sans-extension file)) + (key (and (string-match "/\\([^/]+/[^/]+/[^/]+$\\)" + file-sans) + (match-string 1 file-sans))) + (icon-map icon-map-list) + elem value) + (while (and (null value) icon-map) + (setq elem (car icon-map) + value (assoc-string (or key file-sans) + (if (symbolp elem) + (symbol-value elem) + elem)) + icon-map (cdr icon-map))) + (and value (cdr value)))) + x-gtk-stock-cache)))) + +(declare-function accelerate-menu "pgtkmenu.c" (&optional frame) t) + +(defun pgtk-menu-bar-open (&optional frame) + "Open the menu bar if it is shown. +`popup-menu' is used if it is off." + (interactive "i") + (cond + ((and (not (zerop (or (frame-parameter nil 'menu-bar-lines) 0))) + (fboundp 'accelerate-menu)) + (accelerate-menu frame)) + (t + (popup-menu (mouse-menu-bar-map) last-nonmenu-event)))) + +(defun pgtk-device-class (name) + "Return the device class of NAME. +Users should not call this function; see `device-class' instead." + (cond + ((string-match-p "XTEST" name) 'test) + ((string= "Virtual core pointer" name) 'core-pointer) + ((string= "Virtual core keyboard" name) 'core-keyboard) + (t (let ((number (ignore-errors + (string-to-number name)))) + (when number + (cl-case number + (0 'mouse) + (1 'pen) + (2 'eraser) + (3 'puck) + (4 'keyboard) + (5 'touchscreen) + (6 'touchpad) + (7 'trackpoint) + (8 'pad))))))) + +(defvaralias 'x-gtk-use-system-tooltips 'use-system-tooltips) + +(provide 'pgtk-win) +(provide 'term/pgtk-win) + +;;; pgtk-win.el ends here diff --git a/lisp/term/w32-win.el b/lisp/term/w32-win.el index 8b39ed9d86e..7eaa6047763 100644 --- a/lisp/term/w32-win.el +++ b/lisp/term/w32-win.el @@ -274,6 +274,9 @@ 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") + '(webpdemux "libwebpdemux-2.dll" "libwebpdemux.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/term/x-win.el b/lisp/term/x-win.el index 62cd9848667..1f29b24ef20 100644 --- a/lisp/term/x-win.el +++ b/lisp/term/x-win.el @@ -85,6 +85,8 @@ (defvar x-selection-timeout) (defvar x-session-id) (defvar x-session-previous-id) +(defvar x-dnd-movement-function) +(defvar x-dnd-unsupported-drop-function) (defun x-handle-no-bitmap-icon (_switch) (setq default-frame-alist (cons '(icon-type) default-frame-alist))) @@ -107,14 +109,6 @@ (setq x-session-previous-id (car x-invocation-args) x-invocation-args (cdr x-invocation-args))) -(defvar emacs-save-session-functions nil - "Special hook run when a save-session event occurs. -The functions do not get any argument. -Functions can return non-nil to inform the session manager that the -window system shutdown should be aborted. - -See also `emacs-session-save'.") - (defun emacs-session-filename (session-id) "Construct a filename to save the session in based on SESSION-ID. Return a filename in `user-emacs-directory', unless the session file @@ -247,7 +241,9 @@ exists." (defconst x-pointer-ur-angle 148) (defconst x-pointer-watch 150) (defconst x-pointer-xterm 152) -(defconst x-pointer-invisible 255) +(defconst x-pointer-invisible 65536) ;; This value is larger than a + ;; CARD16, so it cannot be a + ;; valid cursor. ;;;; Keysyms @@ -1489,6 +1485,12 @@ If you don't want stock icons, set the variable to nil." (string :tag "Stock/named"))))) :group 'x) +(defcustom x-display-cursor-at-start-of-preedit-string nil + "If non-nil, display the cursor at the start of any pre-edit text." + :version "29.1" + :type 'boolean + :group 'x) + (defconst x-gtk-stock-cache (make-hash-table :weakness t :test 'equal)) (defun x-gtk-map-stock (file) @@ -1517,6 +1519,106 @@ This uses `icon-map-list' to map icon file names to stock icon names." (global-set-key [XF86WakeUp] 'ignore) + +(defvar x-preedit-overlay nil + "The overlay currently used to display preedit text from a compose sequence.") + +;; With some input methods, text gets inserted before Emacs is told to +;; remove any preedit text that was displayed, which causes both the +;; preedit overlay and the text to be visible for a brief period of +;; time. This pre-command-hook clears the overlay before any command +;; and should be set whenever a preedit overlay is visible. +(defun x-clear-preedit-text () + "Clear the pre-edit overlay and remove itself from pre-command-hook. +This function should be installed in `pre-command-hook' whenever +preedit text is displayed." + (when x-preedit-overlay + (delete-overlay x-preedit-overlay) + (setq x-preedit-overlay nil)) + (remove-hook 'pre-command-hook #'x-clear-preedit-text)) + +(defun x-preedit-text (event) + "Display preedit text from a compose sequence in EVENT. +EVENT is a preedit-text event." + (interactive "e") + (when x-preedit-overlay + (delete-overlay x-preedit-overlay) + (setq x-preedit-overlay nil) + (remove-hook 'pre-command-hook #'x-clear-preedit-text)) + (when (nth 1 event) + (let ((string (propertize (nth 1 event) 'face '(:underline t)))) + (setq x-preedit-overlay (make-overlay (point) (point))) + (add-hook 'pre-command-hook #'x-clear-preedit-text) + (overlay-put x-preedit-overlay 'window (selected-window)) + (overlay-put x-preedit-overlay 'before-string + (if x-display-cursor-at-start-of-preedit-string + (propertize string 'cursor t) + string))))) + +(define-key special-event-map [preedit-text] 'x-preedit-text) + +(defvaralias 'x-gtk-use-system-tooltips 'use-system-tooltips) + +(declare-function x-internal-focus-input-context "xfns.c" (focus)) + +(defun x-gtk-use-native-input-watcher (_symbol newval &rest _ignored) + "Variable watcher for `x-gtk-use-native-input'. +If NEWVAL is non-nil, focus the GTK input context of focused +frames on all displays." + (when (and (featurep 'gtk) + (eq (framep (selected-frame)) 'x)) + (x-internal-focus-input-context newval))) + +(add-variable-watcher 'x-gtk-use-native-input + #'x-gtk-use-native-input-watcher) + +(defun x-dnd-movement (_frame position) + "Handle movement to POSITION during drag-and-drop." + (dnd-handle-movement position) + (redisplay)) + +(defun x-device-class (name) + "Return the device class of NAME. +Users should not call this function; see `device-class' instead." + (let ((downcased-name (downcase name))) + (cond + ((string-match-p "XTEST" name) 'test) + ((string= "Virtual core pointer" name) 'core-pointer) + ((string= "Virtual core keyboard" name) 'core-keyboard) + ((string-match-p "eraser" downcased-name) 'eraser) + ((string-match-p " pad" downcased-name) 'pad) + ((or (or (string-match-p "wacom" downcased-name) + (string-match-p "pen" downcased-name)) + (string-match-p "stylus" downcased-name)) + 'pen) + ((or (string-prefix-p "xwayland-touch:" name) + (string-match-p "touchscreen" downcased-name)) + 'touchscreen) + ((or (string-match-p "trackpoint" downcased-name) + (string-match-p "stick" downcased-name)) + 'trackpoint) + ((or (string-match-p "mouse" downcased-name) + (string-match-p "optical" downcased-name) + (string-match-p "pointer" downcased-name)) + 'mouse) + ((string-match-p "cursor" downcased-name) 'puck) + ((or (string-match-p "keyboard" downcased-name) + ;; One of my cheap keyboards is really named this... + (string= name "USB USB Keykoard")) + 'keyboard) + ((string-match-p "button" downcased-name) 'power-button) + ((string-match-p "touchpad" downcased-name) 'touchpad) + ((or (string-match-p "midi" downcased-name) + (string-match-p "piano" downcased-name)) + 'piano) + ((or (string-match-p "wskbd" downcased-name) ; NetBSD/OpenBSD + (and (string-match-p "/dev" downcased-name) + (string-match-p "kbd" downcased-name))) + 'keyboard)))) + +(setq x-dnd-movement-function #'x-dnd-movement) +(setq x-dnd-unsupported-drop-function #'x-dnd-handle-unsupported-drop) + (provide 'x-win) (provide 'term/x-win) diff --git a/lisp/textmodes/artist.el b/lisp/textmodes/artist.el index 18e03b49049..686d5f494c9 100644 --- a/lisp/textmodes/artist.el +++ b/lisp/textmodes/artist.el @@ -338,7 +338,8 @@ Example: (defvar artist-pointer-shape (if (eq window-system 'x) x-pointer-crosshair nil) "If in X Windows, use this pointer shape while drawing with the mouse.") -(defvaralias 'artist-text-renderer 'artist-text-renderer-function) +(define-obsolete-variable-alias 'artist-text-renderer + 'artist-text-renderer-function "29.1") (defcustom artist-text-renderer-function 'artist-figlet "Function for doing text rendering." @@ -1370,8 +1371,11 @@ Keymap summary (t ;; Turn mode on (artist-mode-init) - (let ((font (face-attribute 'default :font))) - (when (and (fontp font) (not (font-get font :spacing))) + (let* ((font (face-attribute 'default :font)) + (spacing-prop (if (fontp font) + (font-get font :spacing) + t))) + (when (or (null spacing-prop) (eq spacing-prop 0)) (message "The default font isn't monospaced, so the drawings in this buffer may look odd")))))) ;; Init and exit @@ -2840,9 +2844,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 e4df28d03de..544e0da8276 100644 --- a/lisp/textmodes/bibtex.el +++ b/lisp/textmodes/bibtex.el @@ -764,6 +764,20 @@ for a new entry." ("eprint") ("eprintclass" nil nil 4) ("primaryclass" nil nil -4) ("eprinttype" nil nil 5) ("archiveprefix" nil nil -5) ("url") ("urldate"))) + ("Conference" "Article in Conference Proceedings" ; same as InProceedings + (("author") + ("title" "Title of the article in proceedings (BibTeX converts it to lowercase)")) + (("booktitle" "Name of the conference proceedings") + ("year")) + (("editor") + ("volume" "Volume of the conference proceedings in the series") + ("number" "Number of the conference proceedings in a small series (overwritten by volume)") + ("series" "Series in which the conference proceedings appeared") + ("pages" "Pages in the conference proceedings") + ("month") ("address") + ("organization" "Sponsoring organization of the conference") + ("publisher" "Publishing company, its location") + ("note"))) ("Reference" "Single-Volume Work of Reference" ; same as @collection (("editor") ("title") ("date" nil nil 1) ("year" nil nil -1)) nil @@ -839,6 +853,33 @@ 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"))) + ("MastersThesis" "Master's Thesis" + (("author") + ("title" "Title of the master's thesis (BibTeX converts it to lowercase)") + ("school" "School where the master's thesis was written") + ("year")) + nil + (("type" "Type of the master's thesis (if other than \"Master's 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 @@ -1193,8 +1234,8 @@ See `bibtex-generate-autokey' for details." :type '(repeat (cons (regexp :tag "Old") (string :tag "New")))) -(defvaralias 'bibtex-autokey-name-case-convert - 'bibtex-autokey-name-case-convert-function) +(define-obsolete-variable-alias 'bibtex-autokey-name-case-convert + 'bibtex-autokey-name-case-convert-function "29.1") (defcustom bibtex-autokey-name-case-convert-function #'downcase "Function called for each name to perform case conversion. @@ -1268,8 +1309,8 @@ Case is significant. See `bibtex-generate-autokey' for details." :group 'bibtex-autokey :type '(repeat regexp)) -(defvaralias 'bibtex-autokey-titleword-case-convert - 'bibtex-autokey-titleword-case-convert-function) +(define-obsolete-variable-alias 'bibtex-autokey-titleword-case-convert + 'bibtex-autokey-titleword-case-convert-function "29.1") (defcustom bibtex-autokey-titleword-case-convert-function #'downcase "Function called for each titleword to perform case conversion. @@ -2257,11 +2298,17 @@ is non-nil, FUN is not called for @String entries." (set-marker-insertion-type end-marker t) (save-excursion (goto-char (point-min)) - (while (setq found (bibtex-skip-to-valid-entry)) - (set-marker end-marker (cdr found)) - (looking-at bibtex-any-entry-maybe-empty-head) - (funcall fun (bibtex-key-in-head "") (car found) end-marker) - (goto-char end-marker))))) + (let ((prev nil)) + (while (setq found (bibtex-skip-to-valid-entry)) + ;; If we have invalid entries, ensure that we have forward + ;; progress so that we don't infloop. + (if (equal (point) prev) + (forward-line 1) + (setq prev (point)) + (set-marker end-marker (cdr found)) + (looking-at bibtex-any-entry-maybe-empty-head) + (funcall fun (bibtex-key-in-head "") (car found) end-marker) + (goto-char end-marker))))))) (defun bibtex-progress-message (&optional flag interval) "Echo a message about progress of current buffer. @@ -4101,11 +4148,11 @@ Optional arg POS is the position of the BibTeX entry to use." (goto-char pnt))))) (defun bibtex-mark-entry () - "Put mark at beginning, point at end of current BibTeX entry. + "Put mark at end, point at beginning of current BibTeX entry. Activate mark in Transient Mark mode." (interactive) - (push-mark (bibtex-beginning-of-entry) t t) - (bibtex-end-of-entry)) + (push-mark (bibtex-end-of-entry) t t) + (bibtex-beginning-of-entry)) (defun bibtex-count-entries (&optional count-string-entries) "Count number of entries in current buffer or region. @@ -4317,8 +4364,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 +4426,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. @@ -4996,7 +5039,7 @@ on the value of `bibtex-entry-format'. If the reference key of the entry is empty or a prefix argument is given, calculate a new reference key. (Note: this works only if fields in entry begin on separate lines prior to calling `bibtex-clean-entry' or if -'realign is contained in `bibtex-entry-format'.) +`realign' is contained in `bibtex-entry-format'.) Don't call `bibtex-clean-entry' on @Preamble entries. At end of the cleaning process, the functions in `bibtex-clean-entry-hook' are called with region narrowed to entry." @@ -5608,5 +5651,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/css-mode.el b/lisp/textmodes/css-mode.el index 1139fd1976e..a2a7774aba7 100644 --- a/lisp/textmodes/css-mode.el +++ b/lisp/textmodes/css-mode.el @@ -269,6 +269,10 @@ ("resize" "none" "both" "horizontal" "vertical") ("text-overflow" "clip" "ellipsis" string) + ;; CSS Cascading and Inheritance Level 3 + ;; (https://www.w3.org/TR/css-cascade-3/#property-index) + ("all") + ;; CSS Color Module Level 3 ;; (https://www.w3.org/TR/css3-color/#property) ("color" color) @@ -304,27 +308,27 @@ ;; CSS Box Alignment Module Level 3 ;; (https://www.w3.org/TR/css-align-3/#property-index) - ("align-content" - baseline-position content-distribution overflow-position content-position) - ("align-items" - "normal" "stretch" baseline-position overflow-position self-position) - ("align-self" - "auto" "normal" "stretch" - baseline-position overflow-position self-position) - ("justify-content" "normal" - content-distribution overflow-position content-position "left" "right") - ("justify-items" - "normal" "stretch" baseline-position overflow-position self-position - "left" "right" "legacy") - ("justify-self" - "auto" "normal" "stretch" baseline-position overflow-position self-position - "left" "right") + ("align-content" baseline-position content-distribution + overflow-position content-position) + ("align-items" "normal" "stretch" baseline-position + overflow-position self-position) + ("align-self" "auto" "normal" "stretch" baseline-position + overflow-position self-position) + ("column-gap" "normal" length-percentage) + ("gap" row-gap column-gap) + ("justify-content" "normal" content-distribution overflow-position + content-position "left" "right") + ("justify-items" "normal" "stretch" baseline-position + overflow-position self-position "left" "right" "legacy" "center") + ("justify-self" "auto" "normal" "stretch" baseline-position + overflow-position self-position "left" "right") ("place-content" align-content justify-content) ("place-items" align-items justify-items) ("place-self" justify-self align-self) + ("row-gap" "normal" length-percentage) - ;; CSS Flexible Box Layout Module Level 2 - ;; (https://www.w3.org/TR/css-flexbox-2/#property-index) + ;; CSS Flexible Box Layout Module Level 1 + ;; (https://www.w3.org/TR/css-flexbox-1/#property-index) ("flex" "none" flex-grow flex-shrink flex-basis) ("flex-basis" "auto" "content" width) ("flex-direction" "row" "row-reverse" "column" "column-reverse") @@ -413,21 +417,20 @@ ("mask-type" "luminance" "alpha") ("clip" "rect()" "auto") - ;; CSS Multi-column Layout Module + ;; CSS Multi-column Layout Module Level 1 ;; (https://www.w3.org/TR/css3-multicol/#property-index) ;; "break-after", "break-before", and "break-inside" are left out ;; below, because they're already included in CSS Fragmentation ;; Module Level 3. - ("column-count" integer "auto") - ("column-fill" "auto" "balance") - ("column-gap" length "normal") + ("column-count" "auto" integer) + ("column-fill" "auto" "balance" "balance-all") ("column-rule" column-rule-width column-rule-style - column-rule-color "transparent") + column-rule-color) ("column-rule-color" color) - ("column-rule-style" border-style) - ("column-rule-width" border-width) + ("column-rule-style" line-style) + ("column-rule-width" line-width) ("column-span" "none" "all") - ("column-width" length "auto") + ("column-width" "auto" length) ("columns" column-width column-count) ;; CSS Overflow Module Level 3 @@ -925,6 +928,32 @@ cannot be completed sensibly: `custom-ident', (defface css-proprietary-property '((t :inherit (css-property italic))) "Face to use for vendor-specific properties.") +(defun css--selector-regexp (sassy) + (concat + "\\(?:" + (if (not sassy) + "[-_%*#.>[:alnum:]]+" + ;; Same as for non-sassy except we do want to allow { and } + ;; chars in selectors in the case of #{$foo} + ;; variable interpolation! + (concat "\\(?:[-_%*#.>&+~[:alnum:]]*" scss--hash-re + "\\|[-_%*#.>&+~[:alnum:]]+\\)")) + ;; Even though pseudo-elements should be prefixed by ::, a + ;; single colon is accepted for backward compatibility. + "\\(?:\\(:" (regexp-opt (append css-pseudo-class-ids + css-pseudo-element-ids) + t) + "\\|::" (regexp-opt css-pseudo-element-ids t) "\\)\\)?" + ;; Braces after selectors. + "\\(?:\\[[^]\n]+\\]\\)?" + ;; Parentheses after selectors. + "\\(?:([^)]+)\\)?" + ;; Main bit over. But perhaps just [target]? + "\\|\\[[^]\n]+\\]" + ;; :root, ::marker and the like. + "\\|::?[[:alnum:]]+\\(?:([^)]+)\\)?" + "\\)")) + (defun css--font-lock-keywords (&optional sassy) `((,(concat "!\\s-*" (regexp-opt css--bang-ids)) (0 font-lock-builtin-face)) @@ -945,28 +974,16 @@ cannot be completed sensibly: `custom-ident', ;; selector between [...] should simply not be highlighted. (,(concat "^[ \t]*\\(" - (if (not sassy) - ;; We don't allow / as first char, so as not to - ;; take a comment as the beginning of a selector. - "[^@/:{}() \t\n][^:{}()]*" - ;; Same as for non-sassy except we do want to allow { and } - ;; chars in selectors in the case of #{$foo} - ;; variable interpolation! - (concat "\\(?:" scss--hash-re - "\\|[^@/:{}() \t\n#]\\)" - "[^:{}()#]*\\(?:" scss--hash-re "[^:{}()#]*\\)*")) - ;; Even though pseudo-elements should be prefixed by ::, a - ;; single colon is accepted for backward compatibility. - "\\(?:\\(:" (regexp-opt (append css-pseudo-class-ids - css-pseudo-element-ids) - t) - "\\|::" (regexp-opt css-pseudo-element-ids t) "\\)" - "\\(?:([^)]+)\\)?" - (if (not sassy) - "[^:{}()\n]*" - (concat "[^:{}()\n#]*\\(?:" scss--hash-re "[^:{}()\n#]*\\)*")) + ;; We have at least one selector. + (css--selector-regexp sassy) + ;; And then possibly more. + "\\(?:" + ;; Separators between selectors. + "[ \n\t,+~>]+" + (css--selector-regexp sassy) "\\)*" - "\\)\\(?:\n[ \t]*\\)*{") + ;; And then a brace. + "\\)[ \n\t]*{") (1 'css-selector keep)) ;; In the above rule, we allow the open-brace to be on some subsequent ;; line. This will only work if we properly mark the intervening text diff --git a/lisp/textmodes/emacs-news-mode.el b/lisp/textmodes/emacs-news-mode.el new file mode 100644 index 00000000000..fdb3cb86284 --- /dev/null +++ b/lisp/textmodes/emacs-news-mode.el @@ -0,0 +1,224 @@ +;;; emacs-news-mode.el --- major mode to edit and view the NEWS file -*- lexical-binding: t; -*- + +;; Copyright (C) 2022 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)) + +(defgroup emacs-news-mode nil + "Major mode for editing and viewing the Emacs NEWS file." + :group 'lisp) + +(defface emacs-news-is-documented + '((t :inherit font-lock-type-face)) + "Face used for displaying the \"is documented\" tag." + :version "29.1") + +(defface emacs-news-does-not-need-documentation + '((t :inherit font-lock-preprocessor-face)) + "Face used for displaying the \"does not need documentation\" tag." + :version "29.1") + +(defvar-keymap emacs-news-mode-map + "C-c C-s" #'emacs-news-next-untagged-entry + "C-c C-r" #'emacs-news-previous-untagged-entry + "C-c C-g" #'emacs-news-goto-section + "C-c C-f" #'emacs-news-find-heading + "C-c C-n" #'emacs-news-count-untagged-entries) + +(defvar emacs-news-mode-font-lock-keywords + `(("^---$" 0 'emacs-news-does-not-need-documentation) + ("^\\+\\+\\+$" 0 'emacs-news-is-documented))) + +(defun emacs-news--mode-common () + (setq-local font-lock-defaults '(emacs-news-mode-font-lock-keywords t)) + (setq-local outline-regexp "\\*+ " + outline-minor-mode-cycle t + ;; We subtract one from the level, because we have a + ;; space after the asterisks. + outline-level (lambda () (1- (length (match-string 0)))) + outline-minor-mode-highlight 'append) + (outline-minor-mode)) + +;;;###autoload +(define-derived-mode emacs-news-mode text-mode "NEWS" + "Major mode for editing the Emacs NEWS file." + (setq-local fill-paragraph-function #'emacs-news--fill-paragraph) + (emacs-news--mode-common)) + +;;;###autoload +(define-derived-mode emacs-news-view-mode special-mode "NEWS" + "Major mode for viewing the Emacs NEWS file." + (setq buffer-read-only t) + (emacs-news--buttonize) + (button-mode) + (emacs-news--mode-common)) + +(defun emacs-news--fill-paragraph (&optional justify) + (cond + ;; We're in a heading -- do nothing. + ((save-excursion + (beginning-of-line) + (looking-at "\\*+ ")) + ) + ;; We're in a news item -- exclude the heading before filling. + ((and (save-excursion + (re-search-backward (concat "^\\(?:" paragraph-start "\\|\\*+ \\)") + nil t)) + (= (char-after (match-beginning 0)) ?*)) + (save-restriction + (narrow-to-region (save-excursion + (goto-char (match-beginning 0)) + (forward-line 1) + (point)) + (point-max)) + (fill-paragraph justify))) + ;; Fill normally. + (t + (fill-paragraph justify)))) + +(defun emacs-news-next-untagged-entry (&optional reverse) + "Go to the next untagged NEWS entry. +If REVERSE (interactively, the prefix), go to the previous +untagged NEWS entry." + (interactive "P" emacs-news-mode) + (let ((start (point)) + (found nil)) + ;; Don't consider the current line, because that would stop + ;; progress if calling this command repeatedly. + (unless reverse + (forward-line 1)) + (while (and (not found) + (funcall (if reverse #'re-search-backward + #'re-search-forward) + "^\\(\\*+\\) " nil t)) + (when (and (not (save-excursion + (forward-line -1) + (looking-at "---$\\|\\+\\+\\+$"))) + ;; We have an entry without a tag before it, but + ;; check whether it's a heading (which we can + ;; determine if the next entry has more asterisks). + (not (emacs-news--heading-p))) + ;; It wasn't a sub-heading, so we've found one. + (setq found t))) + (if found + (progn + (push-mark start) + (message "Untagged entry") + (beginning-of-line) + t) + (message "No further untagged entries") + (goto-char start) + nil))) + +(defun emacs-news--heading-p () + (save-excursion + (beginning-of-line) + ;; A heading starts with * characters, and then a blank line, and + ;; then paragraphs with more * characters than in the heading. + (and (looking-at "\\(\\*+\\) ") + (let ((level (length (match-string 1)))) + (forward-line 1) + (and (looking-at "$") + (re-search-forward "^\\(\\*+\\) " nil t) + (> (length (match-string 1)) level)))))) + +(defun emacs-news-previous-untagged-entry () + "Go to the previous untagged NEWS entry." + (interactive nil emacs-news-mode) + (emacs-news-next-untagged-entry t)) + +(defun emacs-news-count-untagged-entries () + "Say how many untagged entries there are in the current NEWS buffer." + (interactive nil emacs-news-mode) + (save-excursion + (goto-char (point-min)) + (let ((i 0)) + (while (emacs-news-next-untagged-entry) + (setq i (1+ i))) + (message (if (= i 1) + "There's 1 untagged entry" + (format "There are %s untagged entries" i)))))) + +(defun emacs-news--buttonize () + "Make manual and symbol references into buttons." + (save-excursion + (with-silent-modifications + (let ((inhibit-read-only t)) + ;; Do functions and variables. + (goto-char (point-min)) + (search-forward "\f" nil t) + (while (re-search-forward "'\\([^-][^ \t\n]+\\)'" nil t) + ;; Filter out references to key sequences. + (let ((string (match-string 1))) + (when-let ((symbol (intern-soft string))) + (when (or (boundp symbol) + (fboundp symbol)) + (buttonize-region (match-beginning 1) (match-end 1) + (lambda (symbol) + (describe-symbol symbol)) + symbol))))) + ;; Do manual references. + (goto-char (point-min)) + (search-forward "\f" nil t) + (while (re-search-forward "\"\\(([a-z0-9]+)[ \n][^\"]\\{1,80\\}\\)\"" + nil t) + (buttonize-region (match-beginning 1) (match-end 1) + (lambda (node) (info node)) + (match-string 1))))))) + +(defun emacs-news--sections (regexp) + (let ((sections nil)) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward (concat "^" regexp "\\(.*\\)") nil t) + (when (save-match-data (emacs-news--heading-p)) + (push (buffer-substring-no-properties + (match-beginning 1) (match-end 1)) + sections)))) + (nreverse sections))) + +(defun emacs-news-goto-section (section) + "Go to SECTION in the Emacs NEWS file." + (interactive (list + (completing-read "Goto section: " (emacs-news--sections "\\* ") + nil t)) + emacs-news-mode) + (goto-char (point-min)) + (when (search-forward (concat "\n* " section) nil t) + (beginning-of-line))) + +(defun emacs-news-find-heading (heading) + "Go to HEADING in the Emacs NEWS file." + (interactive (list + (completing-read "Goto heading: " + (emacs-news--sections "\\*\\*\\*? ") + nil t)) + emacs-news-mode) + (goto-char (point-min)) + (when (re-search-forward (concat "^*+ " (regexp-quote heading)) nil t) + (beginning-of-line))) + +(provide 'emacs-news-mode) + +;;; emacs-news-mode.el ends here diff --git a/lisp/textmodes/enriched.el b/lisp/textmodes/enriched.el index 50ff668a9ff..935be06812f 100644 --- a/lisp/textmodes/enriched.el +++ b/lisp/textmodes/enriched.el @@ -539,6 +539,30 @@ the range of text to assign text property SYMBOL with value VALUE." (list start end 'display prop) (list start end 'display (list 'disable-eval prop))))) +(defvar enriched--markup-shown) +(defun enriched-toggle-markup () + "Toggle whether to see markup in the current buffer." + (interactive) + (save-excursion + (save-restriction + (widen) + (with-silent-modifications + (if (bound-and-true-p enriched--markup-shown) + (progn + (setq-local enriched--markup-shown nil) + ;; Remove any faces, because they will be decoded, too. + (goto-char (point-min)) + (let (match) + (while (setq match (text-property-search-forward 'face)) + (put-text-property (prop-match-beginning match) + (prop-match-end match) + 'face nil))) + (enriched-decode (point-min) (point-max)) + (enriched-mode 1)) + (setq-local enriched--markup-shown t) + (enriched-encode (point-min) (point-max) (current-buffer)) + (enriched-mode -1)))))) + (provide 'enriched) ;;; enriched.el ends here diff --git a/lisp/textmodes/etc-authors-mode.el b/lisp/textmodes/etc-authors-mode.el index 3912b829d20..7eabdd4c2b8 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 ff84c353aa8..88a8395c88a 100644 --- a/lisp/textmodes/fill.el +++ b/lisp/textmodes/fill.el @@ -29,6 +29,8 @@ ;;; Code: +(eval-when-compile (require 'subr-x)) + (defgroup fill nil "Indenting and filling text." :link '(custom-manual "(emacs)Filling") @@ -396,12 +398,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 @@ -716,7 +714,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))) @@ -792,6 +793,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))) @@ -839,75 +841,67 @@ region, instead of just filling the current paragraph." (interactive (progn (barf-if-buffer-read-only) (list (if current-prefix-arg 'full) t))) - (let ((hash (and (not (buffer-modified-p)) - (buffer-hash)))) - (prog1 - (or - ;; 1. Fill the region if it is active when called interactively. - (and region transient-mark-mode mark-active - (not (eq (region-beginning) (region-end))) - (or (fill-region (region-beginning) (region-end) justify) t)) - ;; 2. Try fill-paragraph-function. - (and (not (eq fill-paragraph-function t)) - (or fill-paragraph-function - (and (minibufferp (current-buffer)) - (= 1 (point-min)))) - (let ((function (or fill-paragraph-function - ;; In the minibuffer, don't count - ;; the width of the prompt. - 'fill-minibuffer-function)) - ;; If fill-paragraph-function is set, it probably - ;; takes care of comments and stuff. If not, it - ;; will have to set fill-paragraph-handle-comment - ;; back to t explicitly or return nil. - (fill-paragraph-handle-comment nil) - (fill-paragraph-function t)) - (funcall function justify))) - ;; 3. Try our syntax-aware filling code. - (and fill-paragraph-handle-comment - ;; Our code only handles \n-terminated comments right now. - comment-start (equal comment-end "") - (let ((fill-paragraph-handle-comment nil)) - (fill-comment-paragraph justify))) - ;; 4. If it all fails, default to the good ol' text paragraph filling. - (let ((before (point)) - (paragraph-start paragraph-start) - ;; Fill prefix used for filling the paragraph. - fill-pfx) - ;; Try to prevent code sections and comment sections from being - ;; filled together. - (when (and fill-paragraph-handle-comment comment-start-skip) - (setq paragraph-start - (concat paragraph-start "\\|[ \t]*\\(?:" - comment-start-skip "\\)"))) - (save-excursion - ;; To make sure the return value of forward-paragraph is - ;; meaningful, we have to start from the beginning of - ;; line, otherwise skipping past the last few chars of a - ;; paragraph-separator would count as a paragraph (and - ;; not skipping any chars at EOB would not count as a - ;; paragraph even if it is). - (move-to-left-margin) - (if (not (zerop (fill-forward-paragraph 1))) - ;; There's no paragraph at or after point: give up. - (setq fill-pfx "") - (let ((end (point)) - (beg (progn (fill-forward-paragraph -1) (point)))) - (goto-char before) - (setq fill-pfx - (if use-hard-newlines - ;; Can't use fill-region-as-paragraph, since this - ;; paragraph may still contain hard newlines. See - ;; fill-region. - (fill-region beg end justify) - (fill-region-as-paragraph beg end justify)))))) - fill-pfx)) - ;; If we didn't change anything in the buffer (and the buffer - ;; was previously unmodified), then flip the modification status - ;; back to "unchanged". - (when (and hash - (equal hash (buffer-hash))) - (set-buffer-modified-p nil))))) + (with-buffer-unmodified-if-unchanged + (or + ;; 1. Fill the region if it is active when called interactively. + (and region transient-mark-mode mark-active + (not (eq (region-beginning) (region-end))) + (or (fill-region (region-beginning) (region-end) justify) t)) + ;; 2. Try fill-paragraph-function. + (and (not (eq fill-paragraph-function t)) + (or fill-paragraph-function + (and (minibufferp (current-buffer)) + (= 1 (point-min)))) + (let ((function (or fill-paragraph-function + ;; In the minibuffer, don't count + ;; the width of the prompt. + 'fill-minibuffer-function)) + ;; If fill-paragraph-function is set, it probably + ;; takes care of comments and stuff. If not, it + ;; will have to set fill-paragraph-handle-comment + ;; back to t explicitly or return nil. + (fill-paragraph-handle-comment nil) + (fill-paragraph-function t)) + (funcall function justify))) + ;; 3. Try our syntax-aware filling code. + (and fill-paragraph-handle-comment + ;; Our code only handles \n-terminated comments right now. + comment-start (equal comment-end "") + (let ((fill-paragraph-handle-comment nil)) + (fill-comment-paragraph justify))) + ;; 4. If it all fails, default to the good ol' text paragraph filling. + (let ((before (point)) + (paragraph-start paragraph-start) + ;; Fill prefix used for filling the paragraph. + fill-pfx) + ;; Try to prevent code sections and comment sections from being + ;; filled together. + (when (and fill-paragraph-handle-comment comment-start-skip) + (setq paragraph-start + (concat paragraph-start "\\|[ \t]*\\(?:" + comment-start-skip "\\)"))) + (save-excursion + ;; To make sure the return value of forward-paragraph is + ;; meaningful, we have to start from the beginning of + ;; line, otherwise skipping past the last few chars of a + ;; paragraph-separator would count as a paragraph (and + ;; not skipping any chars at EOB would not count as a + ;; paragraph even if it is). + (move-to-left-margin) + (if (not (zerop (fill-forward-paragraph 1))) + ;; There's no paragraph at or after point: give up. + (setq fill-pfx "") + (let ((end (point)) + (beg (progn (fill-forward-paragraph -1) (point)))) + (goto-char before) + (setq fill-pfx + (if use-hard-newlines + ;; Can't use fill-region-as-paragraph, since this + ;; paragraph may still contain hard newlines. See + ;; fill-region. + (fill-region beg end justify) + (fill-region-as-paragraph beg end justify)))))) + fill-pfx)))) (declare-function comment-search-forward "newcomment" (limit &optional noerror)) (declare-function comment-string-strip "newcomment" (str beforep afterp)) diff --git a/lisp/textmodes/flyspell.el b/lisp/textmodes/flyspell.el index 21612cd5e38..2c5e30fecd8 100644 --- a/lisp/textmodes/flyspell.el +++ b/lisp/textmodes/flyspell.el @@ -1942,9 +1942,7 @@ before point that's highlighted as misspelled." 'face 'flyspell-incorrect string)) (setq pos (cdr pos))) - (if (fboundp 'display-message) - (display-message 'no-log string) - (message "%s" string)))) + (message "%s" string))) ;;*---------------------------------------------------------------------*/ ;;* flyspell-abbrev-table ... */ @@ -2273,17 +2271,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..4d48d90b562 --- /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-2022 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 a4bf454fdcb..1810d7bcaeb 100644 --- a/lisp/textmodes/ispell.el +++ b/lisp/textmodes/ispell.el @@ -296,7 +296,8 @@ The following values are supported: "Non-nil means suppress messages in `ispell-word'." :type 'boolean) -(defvaralias 'ispell-format-word 'ispell-format-word-function) +(define-obsolete-variable-alias 'ispell-format-word + 'ispell-format-word-function "29.1") (defcustom ispell-format-word-function (function upcase) "Formatting function for displaying word being spell checked. @@ -796,6 +797,9 @@ See `ispell-buffer-with-debug' for an example of use." "An alist of parsed Aspell dicts and associated parameters. Internal use.") +(defvar ispell--aspell-found-dictionaries nil + "An alist of identified aspell dictionaries.") + (defun ispell-find-aspell-dictionaries () "Find Aspell's dictionaries, and record in `ispell-aspell-dictionary-alist'." (let* ((dictionaries @@ -809,7 +813,8 @@ Internal use.") (mapcar #'ispell-aspell-find-dictionary dictionaries)))) ;; Ensure aspell's alias dictionary will override standard ;; definitions. - (setq found (ispell-aspell-add-aliases found)) + (setq found (ispell-aspell-add-aliases found) + ispell--aspell-found-dictionaries (copy-sequence found)) ;; Merge into FOUND any elements from the standard ispell-dictionary-base-alist ;; which have no element in FOUND at all. (dolist (dict ispell-dictionary-base-alist) @@ -1377,9 +1382,11 @@ The variable `ispell-library-directory' defines their location." (if (and name (or ;; Include all for Aspell (we already know existing dicts) - ispell-really-aspell + (and ispell-really-aspell + (assoc name ispell--aspell-found-dictionaries)) ;; Include all if `ispell-library-directory' is nil (Hunspell) - (not ispell-library-directory) + (and (not ispell-really-aspell) + (not ispell-library-directory)) ;; If explicit (-d with an absolute path) and existing dict. (and dict-explt (file-name-absolute-p dict-explt) @@ -1672,14 +1679,13 @@ Valid forms include: ("\\\\bibliographystyle" ispell-tex-arg-end) ("\\\\makebox" ispell-tex-arg-end 0) ("\\\\e?psfig" ispell-tex-arg-end) - ("\\\\document\\(class\\|style\\)" . - "\\\\begin[ \t\n]*{[ \t\n]*document[ \t\n]*}")) + ("\\\\document\\(class\\|style\\)" . "\\\\begin[ \t\n]*{document}")) (;; delimited with \begin. In ispell: displaymath, eqnarray, eqnarray*, ;; equation, minipage, picture, tabular, tabular* (ispell) ("\\(figure\\|table\\)\\*?" ispell-tex-arg-end 0) ("list" ispell-tex-arg-end 2) - ("program" . "\\\\end[ \t\n]*{[ \t\n]*program[ \t\n]*}") - ("verbatim\\*?" . "\\\\end[ \t\n]*{[ \t\n]*verbatim\\*?[ \t\n]*}")))) + ("program" . "\\\\end[ \t]*{program}") + ("verbatim\\*?" . "\\\\end[ \t]*{verbatim\\*?}")))) "Lists of regions to be skipped in TeX mode. First list is used raw. Second list has key placed inside \\begin{}. @@ -2398,24 +2404,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 +2434,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))) @@ -2984,8 +2992,7 @@ By just answering RET you can find out what the current dictionary is." (interactive (list (completing-read "Use new dictionary (RET for current, SPC to complete): " - (and (fboundp 'ispell-valid-dictionary-list) - (mapcar #'list (ispell-valid-dictionary-list))) + (mapcar #'list (ispell-valid-dictionary-list)) nil t) current-prefix-arg)) (ispell-set-spellchecker-params) ; Initialize variables and dicts alists @@ -3045,6 +3052,8 @@ when needed." ;;;###autoload (defun ispell-region (reg-start reg-end &optional recheckp shift) "Interactively check a region for spelling errors. +Leave the mark at the last misspelled word that the user was queried about. + Return nil if spell session was terminated, otherwise returns shift offset amount for last line processed." (interactive "r") ; Don't flag errors on read-only bufs. @@ -3056,7 +3065,8 @@ amount for last line processed." (region-type (if (and (= reg-start (point-min)) (= reg-end (point-max))) (buffer-name) "region")) (program-basename (file-name-nondirectory ispell-program-name)) - (dictionary (or ispell-current-dictionary "default"))) + (dictionary (or ispell-current-dictionary "default")) + max-word) (unwind-protect (save-excursion (message "Spell-checking %s using %s with %s dictionary..." @@ -3152,10 +3162,14 @@ ispell-region: Search for first region to skip after (ispell-begin-skip-region-r ;; Reset `in-comment' (and indirectly `add-comment') for new line in-comment nil)) (setq ispell-end (point)) ; "end" tracks region retrieved. - (if string ; there is something to spell check! - ;; (special start end) - (setq shift (ispell-process-line string - (and recheckp shift)))) + ;; There is something to spell check! + (when string + ;; (special start end) + (let ((res (ispell-process-line string + (and recheckp shift)))) + (setq shift (car res)) + (when (cdr res) + (setq max-word (cdr res))))) (goto-char ispell-end))))) (if ispell-quit nil @@ -3166,6 +3180,9 @@ ispell-region: Search for first region to skip after (ispell-begin-skip-region-r (kill-buffer ispell-choices-buffer)) (set-marker skip-region-start nil) (set-marker rstart nil) + ;; Allow the user to pop back to the last position. + (when max-word + (push-mark max-word t)) (if ispell-quit (progn ;; preserve or clear the region for ispell-continue. @@ -3400,9 +3417,12 @@ Returns a string with the line data." This will modify the buffer for spelling errors. Requires variables ISPELL-START and ISPELL-END to be defined in its dynamic scope. -Returns the sum SHIFT due to changes in word replacements." + +Returns a cons cell where the `car' is sum SHIFT due to changes +in word replacements, and the `cdr' is the location of the final +word that was queried about." ;;(declare special ispell-start ispell-end) - (let (poss accept-list) + (let (poss accept-list max-word) (if (not (numberp shift)) (setq shift 0)) ;; send string to spell process and get input. @@ -3456,6 +3476,7 @@ Returns the sum SHIFT due to changes in word replacements." (error (concat "Ispell misalignment: word " "`%s' point %d; probably incompatible versions") ispell-pipe-word actual-point))) + (setq max-word (marker-position word-start)) ;; ispell-cmd-loop can go recursive & change buffer (if ispell-keep-choices-win (setq replace (ispell-command-loop @@ -3552,7 +3573,7 @@ Returns the sum SHIFT due to changes in word replacements." (set-marker line-end nil))) ;; Finished with misspelling! (setq ispell-filter (cdr ispell-filter))) - shift)) + (cons shift max-word))) ;;;###autoload @@ -3593,7 +3614,8 @@ to limit the check." ;;;###autoload (defun ispell-buffer () - "Check the current buffer for spelling errors interactively." + "Check the current buffer for spelling errors interactively. +Leave the mark at the last misspelled word that the user was queried about." (interactive) (ispell-region (point-min) (point-max))) @@ -3883,8 +3905,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 +3997,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/page.el b/lisp/textmodes/page.el index 3fc18323349..5d6f017eb99 100644 --- a/lisp/textmodes/page.el +++ b/lisp/textmodes/page.el @@ -35,11 +35,18 @@ A page boundary is any line whose beginning matches the regexp (interactive "p") (or count (setq count 1)) (while (and (> count 0) (not (eobp))) - ;; In case the page-delimiter matches the null string, - ;; don't find a match without moving. - (if (bolp) (forward-char 1)) - (unless (re-search-forward page-delimiter nil t) - (goto-char (point-max))) + (if (and (looking-at page-delimiter) + (> (match-end 0) (point))) + ;; If we're standing at the page delimiter, then just skip to + ;; the end of it. (But only if it's not a zero-length + ;; delimiter, because then we wouldn't have forward progress.) + (goto-char (match-end 0)) + ;; In case the page-delimiter matches the null string, + ;; don't find a match without moving. + (when (bolp) + (forward-char 1)) + (unless (re-search-forward page-delimiter nil t) + (goto-char (point-max)))) (setq count (1- count))) (while (and (< count 0) (not (bobp))) ;; In case the page-delimiter matches the null string, diff --git a/lisp/textmodes/paragraphs.el b/lisp/textmodes/paragraphs.el index 29804c3bfd2..98eb494823d 100644 --- a/lisp/textmodes/paragraphs.el +++ b/lisp/textmodes/paragraphs.el @@ -477,20 +477,60 @@ sentences. Also, every paragraph boundary terminates sentences as well." (skip-chars-backward " \t\n") (goto-char par-end))) (setq arg (1- arg))) - (constrain-to-field nil opoint t))) - -(defun repunctuate-sentences (&optional no-query) + (let ((npoint (constrain-to-field nil opoint t))) + (not (= npoint opoint))))) + +(defun count-sentences (start end) + "Count sentences in current buffer from START to END." + (let ((sentences 0) + (inhibit-field-text-motion t)) + (save-excursion + (save-restriction + (narrow-to-region start end) + (goto-char (point-min)) + (while (ignore-errors (forward-sentence)) + (setq sentences (1+ sentences))) + ;; Remove last possibly empty sentence + (when (/= (skip-chars-backward " \t\n") 0) + (setq sentences (1- sentences))) + sentences)))) + +(defun repunctuate-sentences-filter (_start _end) + "Search filter used by `repunctuate-sentences' to skip unneeded spaces. +By default, it skips occurrences that already have two spaces." + (/= 2 (- (point) (save-excursion (skip-chars-backward " ") (point))))) + +(defvar repunctuate-sentences-filter #'repunctuate-sentences-filter + "The default filter used by `repunctuate-sentences'. +It is advised to use `add-function' on this to add more filters, +for example, `(looking-back (rx (or \"e.g.\" \"i.e.\") \" \") 5)' +with a set of predefined abbreviations to skip from adding two spaces.") + +(defun repunctuate-sentences (&optional no-query start end) "Put two spaces at the end of sentences from point to the end of buffer. -It works using `query-replace-regexp'. -If optional argument NO-QUERY is non-nil, make changes without -asking for confirmation." - (interactive) +It works using `query-replace-regexp'. In Transient Mark mode, +if the mark is active, operate on the contents of the region. +Second and third arg START and END specify the region to operate on. +If optional argument NO-QUERY is non-nil, make changes without asking +for confirmation. You can use `repunctuate-sentences-filter' to add +filters to skip occurrences of spaces that don't need to be replaced." + (interactive (list nil + (if (use-region-p) (region-beginning)) + (if (use-region-p) (region-end)))) (let ((regexp "\\([]\"')]?\\)\\([.?!]\\)\\([]\"')]?\\) +") (to-string "\\1\\2\\3 ")) (if no-query - (while (re-search-forward regexp nil t) - (replace-match to-string)) - (query-replace-regexp regexp to-string)))) + (progn + (when start (goto-char start)) + (while (re-search-forward regexp end t) + (replace-match to-string))) + (unwind-protect + (progn + (add-function :after-while isearch-filter-predicate + repunctuate-sentences-filter) + (query-replace-regexp regexp to-string nil start end)) + (remove-function isearch-filter-predicate + repunctuate-sentences-filter))))) (defun backward-sentence (&optional arg) diff --git a/lisp/textmodes/pixel-fill.el b/lisp/textmodes/pixel-fill.el new file mode 100644 index 00000000000..e47653e734a --- /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-2022 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 is nil or omitted, use the entire window width. + +If WINDOW is nil or omitted, this defaults to the selected 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-cite.el b/lisp/textmodes/reftex-cite.el index 4e487d745c2..26b14ebc79e 100644 --- a/lisp/textmodes/reftex-cite.el +++ b/lisp/textmodes/reftex-cite.el @@ -360,7 +360,7 @@ The name of the first different author/editor is used." ;; Parse the bibliography environment (defun reftex-extract-bib-entries-from-thebibliography (files) - "Extract bib-entries from the \begin{thebibliography} environment. + "Extract bib-entries from the \\begin{thebibliography} environment. Parsing is not as good as for the BibTeX database stuff. The environment should be located in FILES." (let* (start end buf entries re re-list file default) @@ -580,7 +580,7 @@ If FORMAT is non-nil `format' entry accordingly." (concat key "\n " authors " " year " " extra "\n " title "\n\n"))) (defun reftex-parse-bibitem (item) - "Parse a \bibitem entry in ITEM." + "Parse a \\bibitem entry in ITEM." (let ((key "") (text "")) (when (string-match "\\`{\\([^}]+\\)}\\([^\000]*\\)" item) (setq key (match-string 1 item) @@ -596,7 +596,7 @@ If FORMAT is non-nil `format' entry accordingly." (cons "&entry" (concat key " " text))))) (defun reftex-format-bibitem (item) - "Format a \bibitem entry in ITEM so that it is (relatively) nice to look at." + "Format a \\bibitem entry in ITEM so that it is (relatively) nice to look at." (let ((text (reftex-get-bib-field "&text" item)) (key (reftex-get-bib-field "&key" item)) (lines nil)) diff --git a/lisp/textmodes/reftex-global.el b/lisp/textmodes/reftex-global.el index c7e34b4b90a..062cea9c505 100644 --- a/lisp/textmodes/reftex-global.el +++ b/lisp/textmodes/reftex-global.el @@ -154,8 +154,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)) @@ -188,8 +190,8 @@ No active TAGS table is required." default)))) (if (string= from "") (setq from default)) (unless to - (setq to (read-string (format "Replace label %s with: " - from)))) + (setq to (read-string (format "Replace label %s with: " from) + nil nil from))) (reftex-query-replace-document (concat "{" (regexp-quote from) "}") (format "{%s}" to)))) diff --git a/lisp/textmodes/reftex-index.el b/lisp/textmodes/reftex-index.el index c28f31d5647..734f82aba3f 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 e34c45178b4..49cef297882 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)) @@ -360,13 +370,18 @@ of master file." docstruct)) (defun reftex-using-biblatex-p () - "Return non-nil if we are using biblatex rather than bibtex." + "Return non-nil if we are using biblatex or other specific cite package. +biblatex and other similar packages like multibib allow multiple macro +calls to load a bibliography file. This function should be able to +detect those packages." (if (boundp 'TeX-active-styles) ;; the sophisticated AUCTeX way - (member "biblatex" TeX-active-styles) + (or (member "biblatex" TeX-active-styles) + (member "multibib" TeX-active-styles)) ;; poor-man's check... (save-excursion - (re-search-forward "^[^%\n]*?\\\\usepackage.*{biblatex}" nil t)))) + (re-search-forward + "^[^%\n]*?\\\\usepackage\\(\\[[^]]*\\]\\)?{biblatex\\|multibib}" nil t)))) ;;;###autoload (defun reftex-locate-bibliography-files (master-dir &optional files) @@ -374,7 +389,7 @@ of master file." (unless files (save-excursion (goto-char (point-min)) - ;; when biblatex is used, multiple \bibliography or + ;; when biblatex or multibib are used, multiple \bibliography or ;; \addbibresource macros are allowed. With plain bibtex, only ;; the first is used. (let ((using-biblatex (reftex-using-biblatex-p)) @@ -382,7 +397,7 @@ of master file." (while (and again (re-search-forward (concat - ;; "\\(\\`\\|[\n\r]\\)[^%]*\\\\\\(" + ;; "\\(\\`\\|[\n\r]\\)[^%]*\\\\\\(" "\\(^\\)[^%\n\r]*\\\\\\(" (mapconcat #'identity reftex-bibliography-commands "\\|") "\\)\\(\\[.+?\\]\\)?{[ \t]*\\([^}]+\\)") @@ -405,7 +420,7 @@ of master file." ;; find the file (reftex-locate-file x "bib" master-dir))) files)) - (delq nil files))) + (delq nil (delete-dups files)))) (defun reftex-replace-label-list-segment (old insert &optional entirely) "Replace the segment in OLD which corresponds to INSERT. diff --git a/lisp/textmodes/reftex-toc.el b/lisp/textmodes/reftex-toc.el index 4ba3c2193ee..f6f72cec4f8 100644 --- a/lisp/textmodes/reftex-toc.el +++ b/lisp/textmodes/reftex-toc.el @@ -381,7 +381,7 @@ SPC=view TAB=goto RET=goto+hide [q]uit [r]escan [l]abels [f]ollow [x]r [?]Help (- (or reftex-last-window-height (window-height)) (window-height))))) (when (> count 0) - (with-demoted-errors ;E.g. the window might be the root window! + (with-demoted-errors "Enlarge window error: %S" (enlarge-window count reftex-toc-split-windows-horizontally))))) (defun reftex-toc-dframe-p (&optional frame error) diff --git a/lisp/textmodes/reftex-vars.el b/lisp/textmodes/reftex-vars.el index 36dd36c95ea..f9f09825fa0 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) @@ -1314,7 +1318,7 @@ macro before insertion. For example, it will change \\cite[][]{Jones} -> \\cite{Jones} \\cite[][Chapter 1]{Jones} -> \\cite[Chapter 1]{Jones} \\cite[see][]{Jones} -> \\cite[see][]{Jones} - \\cite[see][Chapter 1]{Jones} -> \\cite{Jones} + \\cite[see][Chapter 1]{Jones} -> \\cite[see][Chapter 1]{Jones} It is possible that other packages have other conventions about which optional argument is interpreted how - that is why this cleaning up can be turned off." @@ -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/reftex.el b/lisp/textmodes/reftex.el index 907d50889a1..e72576cdc74 100644 --- a/lisp/textmodes/reftex.el +++ b/lisp/textmodes/reftex.el @@ -2257,8 +2257,7 @@ IGNORE-WORDS List of words which should be removed from the string." ("Customize" ["Browse RefTeX Group" reftex-customize t] "--" - ["Build Full Customize Menu" reftex-create-customize-menu - (fboundp 'customize-menu-create)]) + ["Build Full Customize Menu" reftex-create-customize-menu]) ("Documentation" ["Info" reftex-info t] ["Commentary" reftex-show-commentary t]))) diff --git a/lisp/textmodes/remember.el b/lisp/textmodes/remember.el index d65aea62862..e72f86f7db6 100644 --- a/lisp/textmodes/remember.el +++ b/lisp/textmodes/remember.el @@ -653,7 +653,7 @@ to turn the *scratch* buffer into your notes buffer." (remember-notes-mode 1) (current-buffer))))) (when switch-to - (switch-to-buffer buf)) + (pop-to-buffer-same-window buf)) buf)) (defun remember-notes--kill-buffer-query () diff --git a/lisp/textmodes/rst.el b/lisp/textmodes/rst.el index 9d3e9effe6e..6a91cef1d94 100644 --- a/lisp/textmodes/rst.el +++ b/lisp/textmodes/rst.el @@ -2351,7 +2351,7 @@ If user selects bullets or #, it's just added with position arranged by `rst-insert-list-new-tag'. If user selects enumerations, a further prompt is given. User need to -input a starting item, for example 'e' for 'A)' style. The position is +input a starting item, for example `e' for `A)' style. The position is also arranged by `rst-insert-list-new-tag'." (let* ((itemstyle (completing-read (format-prompt "Select preferred item style" "#.") diff --git a/lisp/textmodes/sgml-mode.el b/lisp/textmodes/sgml-mode.el index efebee0521b..b49541f47d4 100644 --- a/lisp/textmodes/sgml-mode.el +++ b/lisp/textmodes/sgml-mode.el @@ -75,7 +75,8 @@ a DOCTYPE or an XML declaration." :type 'boolean :version "22.1") -(defvaralias 'sgml-transformation 'sgml-transformation-function) +(define-obsolete-variable-alias 'sgml-transformation + 'sgml-transformation-function "29.1") (defcustom sgml-transformation-function 'identity "Default value for `skeleton-transformation-function' in SGML mode." @@ -418,11 +419,11 @@ These have to be run via `sgml-syntax-propertize'")) (defun sgml-syntax-propertize (start end &optional rules-function) "Syntactic keywords for `sgml-mode'." (setq sgml--syntax-propertize-ppss (cons start (syntax-ppss start))) - (cl-assert (>= (cadr sgml--syntax-propertize-ppss) 0)) - (sgml-syntax-propertize-inside end) - (funcall (or rules-function sgml--syntax-propertize) (point) end) - ;; Catch any '>' after the last quote. - (sgml--syntax-propertize-ppss end)) + (when (>= (cadr sgml--syntax-propertize-ppss) 0) + (sgml-syntax-propertize-inside end) + (funcall (or rules-function sgml--syntax-propertize) (point) end) + ;; Catch any '>' after the last quote. + (sgml--syntax-propertize-ppss end))) (defun sgml-syntax-propertize-inside (end) (let ((ppss (syntax-ppss))) @@ -440,7 +441,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 +530,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)) @@ -620,6 +624,7 @@ Do \\[describe-key] on the following bindings to discover what they do. (setq-local comment-indent-function 'sgml-comment-indent) (setq-local comment-line-break-function 'sgml-comment-indent-new-line) (setq-local skeleton-further-elements '((completion-ignore-case t))) + (setq-local skeleton-end-newline nil) (setq-local skeleton-end-hook (lambda () (or (eolp) @@ -1868,6 +1873,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 +2417,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 +2434,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/string-edit.el b/lisp/textmodes/string-edit.el new file mode 100644 index 00000000000..53850674ac0 --- /dev/null +++ b/lisp/textmodes/string-edit.el @@ -0,0 +1,136 @@ +;;; string-edit.el --- editing long strings -*- lexical-binding: t; -*- + +;; Copyright (C) 2022 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: + +(require 'cl-lib) + +(defface string-edit-prompt + '((t (:inherit font-lock-comment-face))) + "Face used on `string-edit' help text." + :group 'text + :version "29.1") + +(defvar string-edit--success-callback) +(defvar string-edit--abort-callback) + +;;;###autoload +(cl-defun string-edit (prompt string success-callback + &key abort-callback) + "Switch to a new buffer to edit STRING. +When the user finishes editing (with \\<string-edit-mode-map>\\[string-edit-done]), SUCCESS-CALLBACK +is called with the resulting string. + +If the user aborts (with \\<string-edit-mode-map>\\[string-edit-abort]), ABORT-CALLBACK (if any) is +called with no parameters. + +PROMPT will be inserted at the start of the buffer, but won't be +included in the resulting string. If PROMPT is nil, no help text +will be inserted." + (with-current-buffer (generate-new-buffer "*edit string*") + (when prompt + (let ((inhibit-read-only t)) + (insert prompt) + (ensure-empty-lines 0) + (add-text-properties (point-min) (point) + (list 'intangible t + 'face 'string-edit-prompt + 'read-only t)) + (insert (propertize (make-separator-line) 'rear-nonsticky t)) + (add-text-properties (point-min) (point) + (list 'string-edit--prompt t)))) + (let ((start (point))) + (insert string) + (goto-char start)) + + ;; Use `fit-window-to-buffer' after the buffer is filled with text. + (pop-to-buffer (current-buffer) + '(display-buffer-below-selected + (window-height . (lambda (window) + (fit-window-to-buffer window nil 10))))) + + (set-buffer-modified-p nil) + (setq buffer-undo-list nil) + (string-edit-mode) + (setq-local string-edit--success-callback success-callback) + (when abort-callback + (setq-local string-edit--abort-callback abort-callback)) + (setq-local header-line-format + (substitute-command-keys + "Type \\<string-edit-mode-map>\\[string-edit-done] when you've finished editing or \\[string-edit-abort] to abort")) + (message "%s" (substitute-command-keys + "Type \\<string-edit-mode-map>\\[string-edit-done] when you've finished editing")))) + +;;;###autoload +(defun read-string-from-buffer (prompt string) + "Switch to a new buffer to edit STRING in a recursive edit. +The user finishes editing with \\<string-edit-mode-map>\\[string-edit-done], or aborts with \\<string-edit-mode-map>\\[string-edit-abort]). + +PROMPT will be inserted at the start of the buffer, but won't be +included in the resulting string. If nil, no prompt will be +inserted in the buffer." + (string-edit + prompt + string + (lambda (edited) + (setq string edited) + (exit-recursive-edit)) + :abort-callback (lambda () + (exit-recursive-edit) + (error "Aborted edit"))) + (recursive-edit) + string) + +(defvar-keymap string-edit-mode-map + "C-c C-c" #'string-edit-done + "C-c C-k" #'string-edit-abort) + +(define-derived-mode string-edit-mode text-mode "String" + "Mode for editing strings." + :interactive nil) + +(defun string-edit-done () + "Finish editing the string and call the callback function. +This will kill the current buffer." + (interactive) + (goto-char (point-min)) + ;; Skip past the help text. + (when-let ((match (text-property-search-forward + 'string-edit--prompt nil t))) + (goto-char (prop-match-beginning match))) + (let ((string (buffer-substring (point) (point-max))) + (callback string-edit--success-callback)) + (quit-window 'kill) + (funcall callback string))) + +(defun string-edit-abort () + "Abort editing the current string." + (interactive) + (let ((callback string-edit--abort-callback)) + (quit-window 'kill) + (when callback + (funcall callback)))) + +(provide 'string-edit) + +;;; string-edit.el ends here diff --git a/lisp/textmodes/table.el b/lisp/textmodes/table.el index 30a07cbefea..fc06c4c0da1 100644 --- a/lisp/textmodes/table.el +++ b/lisp/textmodes/table.el @@ -753,6 +753,18 @@ the cell contents dynamically." :type 'string :group 'table) +(defcustom table-latex-environment "tabular" + "Tabular-compatible environment to use when generating latex. +The value should be a string suitable for use as a LaTeX environment +that's compatible with the \"tabular\" protocol, such as \"tabular\" +and \"longtable\"." + :tag "Latex environment used to export tables" + :type '(choice + (const :tag "tabular" "tabular") + (const :tag "longtable" "longtable") + string) + :version "29.1") + (defcustom table-cals-thead-rows 1 "Number of top rows to become header rows in CALS table." :tag "CALS Header Rows" @@ -1195,6 +1207,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 +1246,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 +2856,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 @@ -3019,7 +3037,8 @@ CALS (DocBook DTD): ""))) ((eq language 'latex) (insert (format "%% This LaTeX table template is generated by emacs %s\n" emacs-version) - "\\begin{tabular}{|" (apply #'concat (make-list (length col-list) "l|")) "}\n" + "\\begin{" table-latex-environment "}{|" + (apply #'concat (make-list (length col-list) "l|")) "}\n" "\\hline\n")) ((eq language 'cals) (insert (format "<!-- This CALS table template is generated by emacs %s -->\n" emacs-version) @@ -3045,7 +3064,7 @@ CALS (DocBook DTD): ((eq language 'html) (insert "</table>\n")) ((eq language 'latex) - (insert "\\end{tabular}\n")) + (insert "\\end{" table-latex-environment "}\n")) ((eq language 'cals) (set-marker-insertion-type (table-get-source-info 'colspec-marker) t) ;; insert before (save-excursion diff --git a/lisp/textmodes/tex-mode.el b/lisp/textmodes/tex-mode.el index 64e38ad6973..473643bb483 100644 --- a/lisp/textmodes/tex-mode.el +++ b/lisp/textmodes/tex-mode.el @@ -505,7 +505,9 @@ An alternative value is \" . \", if you use a font with a narrow period." "documentstyle" "documentclass" "verbatiminput" "includegraphics" "includegraphics*") t)) - (verbish (regexp-opt '("url" "nolinkurl" "path") t)) + (verbish (regexp-opt '("url" "nolinkurl" "path" + "href" "ProvidesFile") + t)) ;; Miscellany. (slash "\\\\") (opt " *\\(\\[[^]]*\\] *\\)*") @@ -1176,12 +1178,7 @@ subshell is initiated, `tex-shell-hook' is run." (setq-local outline-regexp latex-outline-regexp) (setq-local outline-level #'latex-outline-level) (setq-local forward-sexp-function #'latex-forward-sexp) - (setq-local skeleton-end-hook nil) - (setq-local comment-region-function #'latex--comment-region) - (setq-local comment-style 'plain)) - -(defun latex--comment-region (beg end &optional arg) - (comment-region-default-1 beg end arg t)) + (setq-local skeleton-end-hook nil)) ;;;###autoload (define-derived-mode slitex-mode latex-mode "SliTeX" @@ -2037,7 +2034,7 @@ In the tex shell buffer this command behaves like `comint-send-input'." (defun tex-display-shell () "Make the TeX shell buffer visible in a window." - (display-buffer (tex-shell-buf)) + (display-buffer (tex-shell-buf) display-comint-buffer-action) (tex-recenter-output-buffer nil)) (defun tex-shell-sentinel (proc _msg) @@ -2441,7 +2438,7 @@ Only applies the FSPEC to the args part of FORMAT." (if cmds (tex-format-cmd (caar cmds) fspec)))))) (defun tex-cmd-doc-view (file) - (pop-to-buffer (find-file-noselect file))) + (pop-to-buffer (find-file-noselect file) display-comint-buffer-action)) (defun tex-compile (dir cmd) "Run a command CMD on current TeX buffer's file in DIR." @@ -2457,7 +2454,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) @@ -2698,7 +2695,7 @@ line LINE of the window, or centered if LINE is nil." (window)) (if (null tex-shell) (message "No TeX output buffer") - (setq window (display-buffer tex-shell)) + (setq window (display-buffer tex-shell display-comint-buffer-action)) (with-selected-window window (bury-buffer tex-shell) (goto-char (point-max)) @@ -2987,13 +2984,7 @@ There might be text before point." (put-text-property (1- (match-beginning 1)) (match-beginning 1) 'syntax-table - (if (= (1+ (line-beginning-position)) (match-beginning 1)) - ;; The `%' is a single-char comment, which Emacs - ;; syntax-table can't deal with. We could turn it - ;; into a non-comment, or use `\n%' or `%^' as the comment. - ;; Instead, we include it in the ^^A comment. - (string-to-syntax "< b") - (string-to-syntax ">"))) + (string-to-syntax ">")) (let ((end (line-end-position))) (if (< end (point-max)) (put-text-property @@ -3016,8 +3007,9 @@ There might be text before point." (defconst doctex-syntax-propertize-rules (syntax-propertize-precompile-rules latex-syntax-propertize-rules - ;; For DocTeX comment-in-doc. - ("\\(\\^\\)\\^A" (1 (doctex-font-lock-^^A)))))) + ;; For DocTeX comment-in-doc (DocTeX ≥3 also allows ^^X). + ;; We make the comment start on the second char because of bug#35140. + ("\\^\\(\\^\\)[AX]" (1 (doctex-font-lock-^^A)))))) (defvar doctex-font-lock-keywords (append tex-font-lock-keywords @@ -3566,28 +3558,122 @@ There might be text before point." ("\\ordmasculine" . ?º) ("\\lambdabar" . ?ƛ) ("\\celsius" . ?℃) + ;; Text symbols formerly part of textcomp package: + ("\\textdollar" . ?$) + ("\\textborn" . ?*) + ("\\textless" . ?<) + ("\\textgreater" . ?>) + ("\\textbackslash" . ?\\) + ("\\textasciicircum" . ?^) + ("\\textunderscore" . ?_) + ("\\textbraceleft" . ?\{) + ("\\textbar" . ?|) + ("\\textbraceright" . ?\}) + ("\\textasciitilde" . ?~) + ("\\textexclamdown" . ?¡) + ("\\textcent" . ?¢) + ("\\textsterling" . ?£) + ("\\textcurrency" . ?¤) + ("\\textyen" . ?¥) + ("\\textbrokenbar" . ?¦) + ("\\textsection" . ?§) + ("\\textasciidieresis" . ?¨) + ("\\textcopyright" . ?©) + ("\\textordfeminine" . ?ª) + ("\\guillemetleft" . ?«) + ("\\guillemotleft" . ?«) + ("\\textlnot" . ?¬) + ("\\textregistered" . ?®) + ("\\textasciimacron" . ?¯) + ("\\textdegree" . ?°) + ("\\textpm" . ?±) + ("\\texttwosuperior" . ?²) + ("\\textthreesuperior" . ?³) + ("\\textasciiacute" . ?´) ("\\textmu" . ?µ) + ("\\textparagraph" . ?¶) + ("\\textpilcrow" . ?¶) + ("\\textperiodcentered" . ?·) + ("\\textonesuperior" . ?¹) + ("\\textordmasculine" . ?º) + ("\\guillemetright" . ?») + ("\\guillemotright" . ?») + ("\\textonequarter" . ?¼) + ("\\textonehalf" . ?½) + ("\\textthreequarters" . ?¾) + ("\\textquestiondown" . ?¿) + ("\\texttimes" . ?×) + ("\\textdiv" . ?÷) + ("\\textflorin" . ?ƒ) + ("\\textasciicaron" . ?ˇ) + ("\\textasciibreve" . ?˘) + ("\\textacutedbl" . ?˝) + ("\\textgravedbl" . 757) + ("\\texttildelow" . 759) + ("\\textbaht" . ?฿) + ("\\textendash" . ?–) + ("\\textemdash" . ?—) + ("\\textbardbl" . ?‖) + ("\\textquoteleft" . 8216) + ("\\textquoteright" . 8217) + ("\\quotesinglbase" . 8218) + ("\\textquotedblleft" . 8220) + ("\\textquotedblright" . 8221) + ("\\quotedblbase" . 8222) + ;; \textdagger and \textdied are replaced with DAGGER (#x2020) and + ;; not with LATIN CROSS (#x271d) + ("\\textdagger" . ?†) + ("\\textdied" . ?†) + ("\\textdaggerdbl" . ?‡) + ("\\textbullet" . ?•) + ("\\textellipsis" . ?…) + ("\\textperthousand" . ?‰) + ("\\textpertenthousand" . ?‱) + ("\\guilsinglleft" . ?‹) + ("\\guilsinglright" . ?›) + ("\\textreferencemark" . ?※) + ("\\textinterrobang" . ?‽) ("\\textfractionsolidus" . ?⁄) - ("\\textbigcircle" . ?⃝) - ("\\textmusicalnote" . ?♪) - ("\\textdied" . ?✝) + ("\\textlquill" . 8261) ; Literal ?⁅ breaks indentation + ("\\textrquill" . 8262) ; Literal ?⁆ breaks indentation + ("\\textdiscount" . ?⁒) ("\\textcolonmonetary" . ?₡) - ("\\textwon" . ?₩) + ("\\textlira" . ?₤) ("\\textnaira" . ?₦) + ("\\textwon" . ?₩) + ("\\textdong" . ?₫) + ("\\texteuro" . ?€) ("\\textpeso" . ?₱) - ("\\textlira" . ?₤) - ("\\textrecipe" . ?℞) - ("\\textinterrobang" . ?‽) - ("\\textpertenthousand" . ?‱) - ("\\textbaht" . ?฿) + ("\\textguarani" . ?₲) + ("\\textcelsius" . ?℃) ("\\textnumero" . ?№) - ("\\textdiscount" . ?⁒) + ("\\textcircledP" . ?℗) + ("\\textrecipe" . ?℞) + ("\\textservicemark" . ?℠) + ("\\texttrademark" . ?™) + ("\\textohm" . ?Ω) + ("\\textmho" . ?℧) ("\\textestimated" . ?℮) + ("\\textleftarrow" . ?←) + ("\\textuparrow" . ?↑) + ("\\textrightarrow" . ?→) + ("\\textdownarrow" . ?↓) + ("\\textminus" . ?−) + ("\\textsurd" . ?√) + ("\\textlangle" . 9001) ; Literal ?〈 breaks indentation + ("\\textrangle" . 9002) ; Literal ?〉 breaks indentation + ("\\textblank" . ?␢) + ("\\textvisiblespace" . ?␣) ("\\textopenbullet" . ?◦) - ("\\textlquill" . 8261) ; Literal ?⁅ breaks indentation. - ("\\textrquill" . 8262) ; Literal ?⁆ breaks indentation. - ("\\textcircledP" . ?℗) - ("\\textreferencemark" . ?※)) + ;; \textbigcircle is replaced with LARGE CIRCLE (#x25ef) and not + ;; with COMBINING ENCLOSING CIRCLE (#x20dd) + ("\\textbigcircle" . ?◯) + ("\\textmusicalnote" . ?♪) + ("\\textmarried" . ?⚭) + ("\\textdivorced" . ?⚮) + ("\\textlbrackdbl" . 10214) ; Literal ?⟦ breaks indentation + ("\\textrbrackdbl" . 10215) ; Literal ?⟧ breaks indentation + ("\\textinterrobangdown" . ?⸘)) "A `prettify-symbols-alist' usable for (La)TeX modes.") (defun tex--prettify-symbols-compose-p (_start end _match) diff --git a/lisp/textmodes/texinfo.el b/lisp/textmodes/texinfo.el index 81ac45eb6c4..5d6f5deae1b 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 @@ -32,6 +31,16 @@ ;;; Code: +(eval-when-compile (require 'cl-lib) + (require 'flymake) + (require 'rx)) +(declare-function flymake-diag-region "flymake" + (buffer line &optional col)) +(declare-function flymake-make-diagnostic "flymake" + ( locus beg end type text + &optional data overlay-properties)) +(declare-function flymake--log-1 "flymake" (level sublog msg &rest args)) + (eval-when-compile (require 'tex-mode)) (declare-function tex-buffer "tex-mode" ()) (declare-function tex-region "tex-mode" (beg end)) @@ -336,6 +345,69 @@ Subexpression 1 is what goes into the corresponding `@end' statement.") (if (re-search-backward "^@node[ \t]+\\([^,\n]+\\)" nil t) (match-string-no-properties 1)))) +;;; Flymake support +(defvar-local texinfo--flymake-proc nil) +(defun texinfo-flymake (report-fn &rest _) + "Texinfo checking for Flymake. + +REPORT-FN is the callback function." + (let ((executable (or (executable-find "makeinfo") + (executable-find "texi2any"))) + (source (current-buffer))) + + (unless executable + (error "Flymake for Texinfo requires `makeinfo' or `texi2any'")) + + (when (process-live-p texinfo--flymake-proc) + (kill-process texinfo--flymake-proc)) + + (save-restriction + (widen) + (setq texinfo--flymake-proc + (make-process + :name "texinfo-flymake" + :noquery t + :connection-type 'pipe + :buffer (generate-new-buffer " *texinfo-flymake*") + :command `(,executable "-o" ,null-device "-") + :sentinel + (lambda (proc _event) + (when (memq (process-status proc) '(exit signal)) + (unwind-protect + (if (eq (buffer-local-value 'texinfo--flymake-proc + source) + proc) + (with-current-buffer (process-buffer proc) + (goto-char (point-min)) + (cl-loop + while (search-forward-regexp + (rx line-start + "-:" + (group-n 1 (0+ digit)) ; Line + (optional ":" (group-n 2 (0+ digit))) ; col + ": " + (optional (group-n 3 "warning: ")) ; warn + (group-n 4 (0+ nonl)) ; Message + line-end) + nil t) + for msg = (match-string 4) + for (beg . end) = (flymake-diag-region + source + (string-to-number (match-string 1))) + for type = (if (match-string 3) + :warning + :error) + collect (flymake-make-diagnostic + source beg end type msg) + into diags + finally (funcall report-fn diags))) + (flymake-log :warning "Cancelling obsolete check %s" + proc)) + (kill-buffer (process-buffer proc))))))) + (process-send-region texinfo--flymake-proc (point-min) (point-max)) + (process-send-eof texinfo--flymake-proc)))) + + ;;; Texinfo mode ;;;###autoload @@ -411,13 +483,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) @@ -455,8 +527,63 @@ value of `texinfo-mode-hook'." (let ((prevent-filling "^@\\(def\\|multitable\\)")) (if (null auto-fill-inhibit-regexp) prevent-filling - (concat auto-fill-inhibit-regexp "\\|" prevent-filling))))) - + (concat auto-fill-inhibit-regexp "\\|" prevent-filling)))) + + ;; Set up Flymake support. + (add-hook 'flymake-diagnostic-functions #'texinfo-flymake nil t)) + +(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/textmodes/word-wrap-mode.el b/lisp/textmodes/word-wrap-mode.el new file mode 100644 index 00000000000..c354fc773a7 --- /dev/null +++ b/lisp/textmodes/word-wrap-mode.el @@ -0,0 +1,80 @@ +;;; word-wrap-mode.el --- minor mode for `word-wrap' tweaks -*- lexical-binding: t; -*- + +;; Copyright (C) 2022 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: + +;; The list below lists all characters that have a general-category of +;; Zs, but with the ones we don't want to add here commented out. +(defcustom word-wrap-whitespace-characters + '(;;?\N{SPACE} + ;;?\N{NO-BREAK SPACE} + ?\N{OGHAM SPACE MARK} + ?\N{EN QUAD} + ?\N{EM QUAD} + ?\N{EN SPACE} + ?\N{EM SPACE} + ?\N{THREE-PER-EM SPACE} + ?\N{FOUR-PER-EM SPACE} + ?\N{SIX-PER-EM SPACE} + ?\N{FIGURE SPACE} + ?\N{PUNCTUATION SPACE} + ?\N{THIN SPACE} + ?\N{HAIR SPACE} + ;;?\N{NARROW NO-BREAK SPACE} + ?\N{MEDIUM MATHEMATICAL SPACE} + ?\N{IDEOGRAPHIC SPACE} + ;; Not in the Zs category: + ?\N{ZERO WIDTH SPACE}) + "Characters that `word-wrap-whitespace-mode' should add to `word-wrap'." + :version "29.1" + :type '(repeat character) + :group 'display) + +(defvar word-wrap-mode--previous-state) + +;;;###autoload +(define-minor-mode word-wrap-whitespace-mode + "Allow `word-wrap' to fold on all breaking whitespace characters. +The characters to break on are defined by `word-wrap-whitespace-characters'." + :group 'display + (if word-wrap-whitespace-mode + (progn + (setq-local word-wrap-mode--previous-state + (cons (category-table) + (buffer-local-set-state + word-wrap-by-category t + word-wrap t))) + (set-category-table (copy-category-table)) + (dolist (char word-wrap-whitespace-characters) + (modify-category-entry char ?|))) + (set-category-table (car word-wrap-mode--previous-state)) + (buffer-local-restore-state (cdr word-wrap-mode--previous-state)))) + +;;;###autoload +(define-globalized-minor-mode global-word-wrap-whitespace-mode + word-wrap-whitespace-mode word-wrap-whitespace-mode + :group 'display) + +(provide 'word-wrap-mode) + +;;; word-wrap-mode.el ends here diff --git a/lisp/thingatpt.el b/lisp/thingatpt.el index b13b7b95cd0..b3dca5890f1 100644 --- a/lisp/thingatpt.el +++ b/lisp/thingatpt.el @@ -82,7 +82,7 @@ question. (defun forward-thing (thing &optional n) "Move forward to the end of the Nth next THING. THING should be a symbol specifying a type of syntactic entity. -Possibilities include `symbol', `list', `sexp', `defun', +Possibilities include `symbol', `list', `sexp', `defun', `number', `filename', `url', `email', `uuid', `word', `sentence', `whitespace', `line', and `page'." (let ((forward-op (or (get thing 'forward-op) @@ -97,7 +97,7 @@ Possibilities include `symbol', `list', `sexp', `defun', (defun bounds-of-thing-at-point (thing) "Determine the start and end buffer locations for the THING at point. THING should be a symbol specifying a type of syntactic entity. -Possibilities include `symbol', `list', `sexp', `defun', +Possibilities include `symbol', `list', `sexp', `defun', `number', `filename', `url', `email', `uuid', `word', `sentence', `whitespace', `line', and `page'. @@ -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) @@ -499,14 +508,14 @@ If no URL is found, return nil. If optional argument LAX is non-nil, look for URLs that are not well-formed, such as foo@bar or <nobody>. -If optional arguments BOUNDS are non-nil, it should be a cons +If optional argument BOUNDS is non-nil, it should be a cons cell of the form (START . END), containing the beginning and end positions of the URI. Otherwise, these positions are detected automatically from the text around point. If the scheme component is absent, either because a URI delimited with <url:...> lacks one, or because an ill-formed URI was found -with LAX or BEG and END, try to add a scheme in the returned URI. +with LAX or BOUNDS, try to add a scheme in the returned URI. The scheme is chosen heuristically: \"mailto:\" if the address looks like an email address, \"ftp://\" if it starts with \"ftp\", etc." @@ -723,6 +732,7 @@ Signal an error if the entire string was not used." "Return the symbol at point, or nil if none is found." (let ((thing (thing-at-point 'symbol))) (if thing (intern thing)))) + ;;;###autoload (defun number-at-point () "Return the number at point, or nil if none is found. @@ -737,7 +747,9 @@ like \"0xBEEF09\" or \"#xBEEF09\", are recognized." (string-to-number (buffer-substring (match-beginning 0) (match-end 0)))))) +(put 'number 'forward-op 'forward-word) (put 'number 'thing-at-point 'number-at-point) + ;;;###autoload (defun list-at-point (&optional ignore-comment-or-string) "Return the Lisp list at point, or nil if none is found. diff --git a/lisp/thread.el b/lisp/thread.el index fbbee26929e..1e6e9e75a72 100644 --- a/lisp/thread.el +++ b/lisp/thread.el @@ -30,6 +30,13 @@ (eval-when-compile (require 'pcase)) (eval-when-compile (require 'subr-x)) +(declare-function thread-name "thread.c") +(declare-function thread-signal "thread.c") +(declare-function thread--blocker "thread.c") +(declare-function current-thread "thread.c") +(declare-function thread-live-p "thread.c") +(declare-function all-threads "thread.c") + ;;;###autoload (defun thread-handle-event (event) "Handle thread events, propagated by `thread-signal'. diff --git a/lisp/thumbs.el b/lisp/thumbs.el index d54cb79622c..3bf08dd6a58 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,12 @@ 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-supported-file-p img) :file ,img))) + t))) (concat (number-to-string (round (car i))) "x" (number-to-string (round (cdr i)))))) @@ -410,7 +400,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-supported-file-p img) 0))))) (defun thumbs-find-image-at-point (&optional img otherwin) "Display image IMG for thumbnail at point. @@ -544,7 +534,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-supported-file-p img) 0) (goto-char (point-min)))) (setq thumbs-image-num num thumbs-current-image-filename img)))) @@ -775,6 +765,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-supported-file-p "29.1") + (provide 'thumbs) ;;; thumbs.el ends here diff --git a/lisp/time.el b/lisp/time.el index 29216416d9d..cd985bfb288 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)) @@ -355,7 +355,7 @@ update which can wait for the next redisplay." (am-pm (if (>= hour 12) "pm" "am")) (minutes (substring time 14 16)) (seconds (substring time 17 19)) - (time-zone (car (cdr (current-time-zone now)))) + (time-zone (format-time-string "%Z" now)) (day (substring time 8 10)) (year (format-time-string "%Y" now)) (monthname (substring time 4 7)) @@ -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 881af4dd74c..1e257c62d39 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 @@ -302,11 +299,10 @@ Return a list in the same format as `current-time-zone's result, or nil if the local time zone could not be computed. DATE is the number of days elapsed since the (imaginary) Gregorian date Sunday, December 31, 1 BC." - (and (fboundp 'current-time-zone) - (let ((utc-time (timezone-time-from-absolute date seconds))) - (and utc-time - (let ((zone (current-time-zone utc-time))) - (and (car zone) zone)))))) + (let ((utc-time (timezone-time-from-absolute date seconds))) + (and utc-time + (let ((zone (current-time-zone utc-time))) + (and (car zone) zone))))) (defun timezone-fix-time (date local timezone) "Convert DATE (default timezone LOCAL) to YYYY-MM-DD-HH-MM-SS-ZONE vector. diff --git a/lisp/tool-bar.el b/lisp/tool-bar.el index 7ec5c0beccc..82b458e0107 100644 --- a/lisp/tool-bar.el +++ b/lisp/tool-bar.el @@ -89,15 +89,29 @@ functions.") (declare-function image-mask-p "image.c" (spec &optional frame)) -(defconst tool-bar-keymap-cache (make-hash-table :weakness t :test 'equal)) +(defconst tool-bar-keymap-cache (make-hash-table :test #'equal)) + +(defun tool-bar--cache-key () + (cons (frame-terminal) (sxhash-eq tool-bar-map))) + +(defun tool-bar--flush-cache () + "Remove all cached entries that refer to the current `tool-bar-map'." + (let ((id (sxhash-eq tool-bar-map)) + (entries nil)) + (maphash (lambda (k _) + (when (equal (cdr k) id) + (push k entries))) + tool-bar-keymap-cache) + (dolist (k entries) + (remhash k tool-bar-keymap-cache)))) (defun tool-bar-make-keymap (&optional _ignore) "Generate an actual keymap from `tool-bar-map'. Its main job is to figure out which images to use based on the display's color capability and based on the available image libraries." - (let ((key (cons (frame-terminal) tool-bar-map))) - (or (gethash key tool-bar-keymap-cache) - (puthash key (tool-bar-make-keymap-1) tool-bar-keymap-cache)))) + (or (gethash (tool-bar--cache-key) tool-bar-keymap-cache) + (setf (gethash (tool-bar--cache-key) tool-bar-keymap-cache) + (tool-bar-make-keymap-1)))) (defun tool-bar-make-keymap-1 () "Generate an actual keymap from `tool-bar-map', without caching." @@ -139,7 +153,8 @@ ICON.xbm, using `find-image'. Use this function only to make bindings in the global value of `tool-bar-map'. To define items in any other map, use `tool-bar-local-item'." - (apply #'tool-bar-local-item icon def key tool-bar-map props)) + (apply #'tool-bar-local-item icon def key tool-bar-map props) + (tool-bar--flush-cache)) (defun tool-bar--image-expression (icon) "Return an expression that evaluates to an image spec for ICON." @@ -177,6 +192,7 @@ ICON.xbm, using `find-image'." (let* ((image-exp (tool-bar--image-expression icon))) (define-key-after map (vector key) `(menu-item ,(symbol-name key) ,def :image ,image-exp ,@props)) + (tool-bar--flush-cache) (force-mode-line-update))) ;;;###autoload @@ -243,6 +259,7 @@ holds a keymap." (setq rest (cdr rest))) (append `(menu-item ,(car defn) ,rest) (list :image image-exp) props)))) + (tool-bar--flush-cache) (force-mode-line-update)))) ;;; Set up some global items. Additions/deletions up for grabs. diff --git a/lisp/tooltip.el b/lisp/tooltip.el index d1628842307..3e9c16a445a 100644 --- a/lisp/tooltip.el +++ b/lisp/tooltip.el @@ -58,9 +58,11 @@ echo area, instead of making a pop-up window." (if (and tooltip-mode (fboundp 'x-show-tip)) (progn (add-hook 'pre-command-hook 'tooltip-hide) - (add-hook 'tooltip-functions 'tooltip-help-tips)) + (add-hook 'tooltip-functions 'tooltip-help-tips) + (add-hook 'x-pre-popup-menu-hook 'tooltip-hide)) (unless (and (boundp 'gud-tooltip-mode) gud-tooltip-mode) - (remove-hook 'pre-command-hook 'tooltip-hide)) + (remove-hook 'pre-command-hook 'tooltip-hide) + (remove-hook 'x-pre-popup-menu-hook 'tooltip-hide)) (remove-hook 'tooltip-functions 'tooltip-help-tips)) (setq show-help-function (if tooltip-mode 'tooltip-show-help 'tooltip-show-help-non-mode))) @@ -228,25 +230,42 @@ change the existing association. Value is the resulting alist." (declare-function x-show-tip "xfns.c" (string &optional frame parms timeout dx dy)) -(defun tooltip-show (text &optional use-echo-area) +(defun tooltip-show (text &optional use-echo-area text-face default-face) "Show a tooltip window displaying TEXT. Text larger than `x-max-tooltip-size' is clipped. -If the alist in `tooltip-frame-parameters' includes `left' and `top' -parameters, they determine the x and y position where the tooltip -is displayed. Otherwise, the tooltip pops at offsets specified by -`tooltip-x-offset' and `tooltip-y-offset' from the current mouse -position. +If the alist in `tooltip-frame-parameters' includes `left' and +`top' parameters, they determine the x and y position where the +tooltip is displayed. Otherwise, the tooltip pops at offsets +specified by `tooltip-x-offset' and `tooltip-y-offset' from the +current mouse position. + +The text properties of TEXT are also modified to add the +appropriate faces before displaying the tooltip. If your code +depends on them, you should copy the tooltip string before +passing it to this function. Optional second arg USE-ECHO-AREA non-nil means to show tooltip -in echo area." +in echo area. + +The third and fourth args TEXT-FACE and DEFAULT-FACE specify +faces used to display the tooltip, and default to `tooltip' if +not specified. TEXT-FACE specifies a face used to display text +in the tooltip, while DEFAULT-FACE specifies a face that provides +the background, foreground and border colors of the tooltip +frame. + +Note that the last two arguments are not respected when +`use-system-tooltips' is non-nil and Emacs is built with support +for system tooltips, such as on NS, Haiku, and with the GTK +toolkit." (if use-echo-area (tooltip-show-help-non-mode text) (condition-case error (let ((params (copy-sequence tooltip-frame-parameters)) - (fg (face-attribute 'tooltip :foreground)) - (bg (face-attribute 'tooltip :background))) + (fg (face-attribute (or default-face 'tooltip) :foreground)) + (bg (face-attribute (or default-face 'tooltip) :background))) (when (stringp fg) (setf (alist-get 'foreground-color params) fg) (setf (alist-get 'border-color params) fg)) @@ -256,7 +275,8 @@ in echo area." ;; faces used in our TEXT. Among other things, this allows ;; tooltips to use the `help-key-binding' face used in ;; `substitute-command-keys' substitutions. - (add-face-text-property 0 (length text) 'tooltip t text) + (add-face-text-property 0 (length text) + (or text-face 'tooltip) t text) (x-show-tip text (selected-frame) params @@ -339,6 +359,8 @@ This is used by `tooltip-show-help' and (defvar tooltip-previous-message nil "The previous content of the echo area.") +(defvar haiku-use-system-tooltips) + (defun tooltip-show-help-non-mode (help) "Function installed as `show-help-function' when Tooltip mode is off. It is also called if Tooltip mode is on, for text-only displays." @@ -368,10 +390,16 @@ 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) + ;; Tooltips can't be displayed on top of the global menu + ;; bar on NS. + (or (not (eq window-system 'ns)) + (not (menu-or-popup-active-p)))) (let ((previous-help tooltip-help-message)) (setq tooltip-help-message msg) (cond ((null msg) diff --git a/lisp/transient.el b/lisp/transient.el index 0d7f9d0317b..d329bbdbcd1 100644 --- a/lisp/transient.el +++ b/lisp/transient.el @@ -61,10 +61,10 @@ (eval-when-compile (require 'subr-x)) -(declare-function info 'info) -(declare-function Man-find-section 'man) -(declare-function Man-next-section 'man) -(declare-function Man-getpage-in-background 'man) +(declare-function info "info") +(declare-function Man-find-section "man") +(declare-function Man-next-section "man") +(declare-function Man-getpage-in-background "man") (defvar Man-notify-method) @@ -1384,7 +1384,7 @@ The optional argument COMMAND is intended for internal use. If you are contemplating using it in your own code, then you should probably use this instead: - (get COMMAND 'transient--suffix)" + (get COMMAND \\='transient--suffix)" (when command (cl-check-type command command)) (if (or transient--prefix diff --git a/lisp/tree-widget.el b/lisp/tree-widget.el index ec258888c8b..4ba96a36a47 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 69540f35d8f..2c787ae5595 100644 --- a/lisp/tutorial.el +++ b/lisp/tutorial.el @@ -385,7 +385,7 @@ correspond to what the tutorial says.\n\n") "Find the key bindings used in the tutorial that have changed. Return a list with elements of the form - '(KEY DEF-FUN DEF-FUN-TXT WHERE REMARK QUIET) + (KEY DEF-FUN DEF-FUN-TXT WHERE REMARK QUIET) where @@ -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) @@ -651,13 +649,15 @@ with some explanatory links." (unless (eq prop-val 'key-sequence) (delete-region prop-start prop-end)))))) +(defvar tutorial--starting-point) (defun tutorial--save-on-kill () "Query the user about saving the tutorial when killing Emacs." (when (buffer-live-p tutorial--buffer) (with-current-buffer tutorial--buffer - (if (y-or-n-p "Save your position in the tutorial? ") - (tutorial--save-tutorial-to (tutorial--saved-file)) - (message "Tutorial position not saved")))) + (unless (= (point) tutorial--starting-point) + (if (y-or-n-p "Save your position in the tutorial? ") + (tutorial--save-tutorial-to (tutorial--saved-file)) + (message "Tutorial position not saved"))))) t) (defun tutorial--save-tutorial () @@ -736,7 +736,6 @@ See `tutorial--save-tutorial' for more information." (message "Can't save tutorial: %s is not a directory" tutorial-dir))))) - ;;;###autoload (defun help-with-tutorial (&optional arg dont-ask-for-revert) "Select the Emacs learn-by-doing tutorial. @@ -916,6 +915,7 @@ Run the Viper tutorial? ")) (forward-line 1) (newline (- n (/ n 2))))) (goto-char (point-min))) + (setq-local tutorial--starting-point (point)) (setq buffer-undo-list nil) (set-buffer-modified-p nil))))) diff --git a/lisp/uniquify.el b/lisp/uniquify.el index 6b48fe3df62..2ef1f04f70d 100644 --- a/lisp/uniquify.el +++ b/lisp/uniquify.el @@ -476,34 +476,32 @@ For use on `kill-buffer-hook'." ;; rename-buffer and create-file-buffer. (Setting find-file-hook isn't ;; sufficient.) -(advice-add 'rename-buffer :around #'uniquify--rename-buffer-advice) -(defun uniquify--rename-buffer-advice (rb-fun newname &optional unique &rest args) +;; (advice-add 'rename-buffer :around #'uniquify--rename-buffer-advice) +(defun uniquify--rename-buffer-advice (newname &optional unique) + ;; BEWARE: This is called directly from `buffer.c'! "Uniquify buffer names with parts of directory name." - (let ((retval (apply rb-fun newname unique args))) (uniquify-maybe-rerationalize-w/o-cb) - (if (null unique) + (if (null unique) ;; Mark this buffer so it won't be renamed by uniquify. (setq uniquify-managed nil) (when uniquify-buffer-name-style ;; Rerationalize w.r.t the new name. (uniquify-rationalize-file-buffer-names - newname + newname (uniquify-buffer-file-name (current-buffer)) - (current-buffer)) - (setq retval (buffer-name (current-buffer))))) - retval)) + (current-buffer))))) -(advice-add 'create-file-buffer :around #'uniquify--create-file-buffer-advice) -(defun uniquify--create-file-buffer-advice (cfb-fun filename &rest args) +;; (advice-add 'create-file-buffer :around #'uniquify--create-file-buffer-advice) +(defun uniquify--create-file-buffer-advice (buf filename) + ;; BEWARE: This is called directly from `files.el'! "Uniquify buffer names with parts of directory name." - (let ((retval (apply cfb-fun filename args))) - (if uniquify-buffer-name-style - (let ((filename (expand-file-name (directory-file-name filename)))) - (uniquify-rationalize-file-buffer-names - (file-name-nondirectory filename) - (file-name-directory filename) retval))) - retval)) + (when uniquify-buffer-name-style + (let ((filename (expand-file-name (directory-file-name filename)))) + (uniquify-rationalize-file-buffer-names + (file-name-nondirectory filename) + (file-name-directory filename) + buf)))) (defun uniquify-unload-function () "Unload the uniquify library." @@ -513,8 +511,6 @@ For use on `kill-buffer-hook'." (set-buffer buf) (when uniquify-managed (push (cons buf (uniquify-item-base (car uniquify-managed))) buffers))) - (advice-remove 'rename-buffer #'uniquify--rename-buffer-advice) - (advice-remove 'create-file-buffer #'uniquify--create-file-buffer-advice) (dolist (buf buffers) (set-buffer (car buf)) (rename-buffer (cdr buf) t)))) diff --git a/lisp/url/url-auth.el b/lisp/url/url-auth.el index 585010d21c5..53cefb46e4b 100644 --- a/lisp/url/url-auth.el +++ b/lisp/url/url-auth.el @@ -87,11 +87,13 @@ instead of the filename inheritance method." ((and prompt (not byserv)) (setq user (or (url-do-auth-source-search server type :user) - (read-string (url-auth-user-prompt href realm) - (or user (user-real-login-name)))) + (and (url-interactive-p) + (read-string (url-auth-user-prompt href realm) + (or user (user-real-login-name))))) pass (or (url-do-auth-source-search server type :secret) - (read-passwd "Password: " nil (or pass "")))) + (and (url-interactive-p) + (read-passwd "Password: " nil (or pass ""))))) (set url-basic-auth-storage (cons (list server (cons file @@ -117,11 +119,13 @@ instead of the filename inheritance method." (progn (setq user (or (url-do-auth-source-search server type :user) - (read-string (url-auth-user-prompt href realm) - (user-real-login-name))) + (and (url-interactive-p) + (read-string (url-auth-user-prompt href realm) + (user-real-login-name)))) pass (or (url-do-auth-source-search server type :secret) - (read-passwd "Password: ")) + (and (url-interactive-p) + (read-passwd "Password: "))) retval (base64-encode-string (format "%s:%s" user pass) t) byserv (assoc server (symbol-value url-basic-auth-storage))) (setcdr byserv @@ -233,11 +237,13 @@ CREDS is a plist that may have properties `:user' and `:secret'." ;; plist-put modify the same plist. (setq creds (plist-put creds :user - (read-string (url-auth-user-prompt url realm) - (or (plist-get creds :user) - (user-real-login-name))))) + (and (url-interactive-p) + (read-string (url-auth-user-prompt url realm) + (or (plist-get creds :user) + (user-real-login-name)))))) (plist-put creds :secret - (read-passwd "Password: " nil (plist-get creds :secret)))) + (and (url-interactive-p) + (read-passwd "Password: " nil (plist-get creds :secret))))) (defun url-digest-auth-directory-id-assoc (dirkey keylist) "Find the best match for DIRKEY in key alist KEYLIST. @@ -301,8 +307,8 @@ object." (defun url-digest-auth-build-response (key url realm attrs) "Compute authorization string for the given challenge using KEY. -The string looks like 'Digest username=\"John\", realm=\"The -Realm\", ...' +The string looks like \"Digest username=\"John\", realm=\"The +Realm\", ...\" Part of the challenge is already solved in a pre-computed KEY which is list of a realm (or a directory), user name, and hash diff --git a/lisp/url/url-cookie.el b/lisp/url/url-cookie.el index 6b9ce5da93e..42e1fa22fac 100644 --- a/lisp/url/url-cookie.el +++ b/lisp/url/url-cookie.el @@ -494,12 +494,10 @@ Use \\<url-cookie-mode-map>\\[url-cookie-delete] to remove cookies." (url-cookie--generate-buffer) (goto-char point)))) -(defvar url-cookie-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [delete] 'url-cookie-delete) - (define-key map [(control k)] 'url-cookie-delete) - (define-key map [(control _)] 'url-cookie-undo) - map)) +(defvar-keymap url-cookie-mode-map + "<delete>" #'url-cookie-delete + "C-k" #'url-cookie-delete + "C-_" #'url-cookie-undo) (define-derived-mode url-cookie-mode special-mode "URL Cookie" "Mode for listing cookies. diff --git a/lisp/url/url-dired.el b/lisp/url/url-dired.el index 1bbd741c1a7..e2c23a8b6d9 100644 --- a/lisp/url/url-dired.el +++ b/lisp/url/url-dired.el @@ -25,12 +25,10 @@ (autoload 'dired-get-filename "dired") -(defvar url-dired-minor-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\C-m" 'url-dired-find-file) - (define-key map [mouse-2] 'url-dired-find-file-mouse) - map) - "Keymap used when browsing directories.") +(defvar-keymap url-dired-minor-mode-map + :doc "Keymap used when browsing directories." + "C-m" #'url-dired-find-file + "<mouse-2>" #'url-dired-find-file-mouse) (defun url-dired-find-file () "In dired, visit the file or directory named on this line." diff --git a/lisp/url/url-file.el b/lisp/url/url-file.el index 31e5c07234c..3863ac99144 100644 --- a/lisp/url/url-file.el +++ b/lisp/url/url-file.el @@ -29,6 +29,12 @@ (require 'url-dired) (declare-function mm-disable-multibyte "mm-util" ()) +(defvar url-allow-non-local-files nil + "If non-nil, allow URL to fetch non-local files. +By default, this is not allowed, since that would allow rendering +HTML to fetch files on other systems if given a <img +src=\"/ssh:host...\"> element, which can be disturbing.") + (defconst url-file-default-port 21 "Default FTP port.") (defconst url-file-asynchronous-p t "FTP transfers are asynchronous.") (defalias 'url-file-expand-file-name 'url-default-expander) @@ -70,18 +76,15 @@ to them." buff func func args args efs)) - (let ((size (file-attribute-size (file-attributes name)))) - (with-current-buffer buff - (goto-char (point-max)) - (if (/= -1 size) - (insert (format "Content-length: %d\n" size))) - (insert "\n") - (insert-file-contents-literally name) - (if (not (url-file-host-is-local-p (url-host url-current-object))) - (condition-case () - (delete-file name) - (error nil))) - (apply func args)))) + (with-current-buffer buff + (goto-char (point-max)) + (insert-file-contents-literally name) + (insert (format "Content-length: %d\n\n" (buffer-size))) + (if (not (url-file-host-is-local-p (url-host url-current-object))) + (condition-case () + (delete-file name) + (error nil))) + (apply func args))) (declare-function ange-ftp-set-passwd "ange-ftp" (host user passwd)) (declare-function ange-ftp-copy-file-internal "ange-ftp" @@ -111,7 +114,8 @@ to them." (memq system-type '(ms-dos windows-nt))) (substring file 1)) ;; file: URL with a file:/bar:/foo-like spec. - ((string-match "\\`/[^/]+:/" file) + ((and (not url-allow-non-local-files) + (string-match "\\`/[^/]+:/" file)) (concat "/:" file)) (t file)))) diff --git a/lisp/url/url-handlers.el b/lisp/url/url-handlers.el index 2da24ff6042..74f77cd2383 100644 --- a/lisp/url/url-handlers.el +++ b/lisp/url/url-handlers.el @@ -396,7 +396,8 @@ if it had been inserted from a file named URL." (url-handlers-create-wrapper file-writable-p (url)) (url-handlers-create-wrapper file-directory-p (url)) (url-handlers-create-wrapper file-executable-p (url)) -(url-handlers-create-wrapper directory-files (url &optional full match nosort)) +(url-handlers-create-wrapper + directory-files (url &optional full match nosort count)) (url-handlers-create-wrapper file-truename (url &optional counter prev-dirs)) (add-hook 'find-file-hook #'url-handlers-set-buffer-mode) diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el index 16c3a6a1e62..4e5d017036c 100644 --- a/lisp/url/url-http.el +++ b/lisp/url/url-http.el @@ -36,6 +36,7 @@ (defvar url-current-object) (defvar url-http-after-change-function) (defvar url-http-chunked-counter) +(defvar url-http-chunked-last-crlf-missing) (defvar url-http-chunked-length) (defvar url-http-chunked-start) (defvar url-http-connection-opened) @@ -332,7 +333,10 @@ Use `url-http-referer' as the Referer-header (subject to `url-privacy-level')." (if (and using-proxy ;; Bug#35969. (not (equal "https" (url-type url-http-target-url)))) - (url-recreate-url url-http-target-url) real-fname)) + (let ((url (copy-sequence url-http-target-url))) + (setf (url-host url) (puny-encode-domain (url-host url))) + (url-recreate-url url)) + real-fname)) " HTTP/" url-http-version "\r\n" ;; Version of MIME we speak "MIME-Version: 1.0\r\n" @@ -585,6 +589,13 @@ should be shown to the user." (url-http-debug "url-http-parse-headers called in (%s)" (buffer-name)) (url-http-parse-response) (mail-narrow-to-head) + (when url-debug + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (url-http-debug "Response: %s" + (buffer-substring (point) (line-end-position))) + (forward-line 1)))) ;;(narrow-to-region (point-min) url-http-end-of-headers) (let ((connection (mail-fetch-field "Connection"))) ;; In HTTP 1.0, keep the connection only if there is a @@ -1068,90 +1079,105 @@ the callback to be triggered." Cannot give a sophisticated percentage, but we need a different function to look for the special 0-length chunk that signifies the end of the document." - (save-excursion - (goto-char st) - (let ((read-next-chunk t) - (case-fold-search t) - (regexp nil) - (no-initial-crlf nil)) - ;; We need to loop thru looking for more chunks even within - ;; one after-change-function call. - (while read-next-chunk - (setq no-initial-crlf (= 0 url-http-chunked-counter)) - (if url-http-content-type + (if url-http-chunked-last-crlf-missing + (progn + (goto-char url-http-chunked-last-crlf-missing) + (if (not (looking-at "\r\n")) + (url-http-debug + "Still spinning for the terminator of last chunk...") + (url-http-debug "Saw the last CRLF.") + (delete-region (match-beginning 0) (match-end 0)) + (when (url-http-parse-headers) + (url-http-activate-callback)))) + (save-excursion + (goto-char st) + (let ((read-next-chunk t) + (case-fold-search t) + (regexp nil) + (no-initial-crlf nil)) + ;; We need to loop thru looking for more chunks even within + ;; one after-change-function call. + (while read-next-chunk + (setq no-initial-crlf (= 0 url-http-chunked-counter)) + (if url-http-content-type + (url-display-percentage nil + "Reading [%s]... chunk #%d" + url-http-content-type url-http-chunked-counter) (url-display-percentage nil - "Reading [%s]... chunk #%d" - url-http-content-type url-http-chunked-counter) - (url-display-percentage nil - "Reading... chunk #%d" - url-http-chunked-counter)) - (url-http-debug "Reading chunk %d (%d %d %d)" - url-http-chunked-counter st nd length) - (setq regexp (if no-initial-crlf - "\\([0-9a-z]+\\).*\r?\n" - "\r?\n\\([0-9a-z]+\\).*\r?\n")) - - (if url-http-chunked-start - ;; We know how long the chunk is supposed to be, skip over - ;; leading crap if possible. - (if (> nd (+ url-http-chunked-start url-http-chunked-length)) - (progn - (url-http-debug "Got to the end of chunk #%d!" - url-http-chunked-counter) - (goto-char (+ url-http-chunked-start - url-http-chunked-length))) - (url-http-debug "Still need %d bytes to hit end of chunk" - (- (+ url-http-chunked-start - url-http-chunked-length) - nd)) - (setq read-next-chunk nil))) - (if (not read-next-chunk) - (url-http-debug "Still spinning for next chunk...") - (if no-initial-crlf (skip-chars-forward "\r\n")) - (if (not (looking-at regexp)) - (progn - ;; Must not have received the entirety of the chunk header, - ;; need to spin some more. - (url-http-debug "Did not see start of chunk @ %d!" (point)) - (setq read-next-chunk nil)) - ;; The data we got may have started in the middle of the - ;; initial chunk header, so move back to the start of the - ;; line and re-compute. - (when (= url-http-chunked-counter 0) - (beginning-of-line) - (looking-at regexp)) - (add-text-properties (match-beginning 0) (match-end 0) - (list 'chunked-encoding t - 'face 'cursor - 'invisible t)) - (setq url-http-chunked-length (string-to-number (buffer-substring - (match-beginning 1) - (match-end 1)) - 16) - url-http-chunked-counter (1+ url-http-chunked-counter) - url-http-chunked-start (set-marker - (or url-http-chunked-start - (make-marker)) - (match-end 0))) - (delete-region (match-beginning 0) (match-end 0)) - (url-http-debug "Saw start of chunk %d (length=%d, start=%d" - url-http-chunked-counter url-http-chunked-length - (marker-position url-http-chunked-start)) - (if (= 0 url-http-chunked-length) - (progn - ;; Found the end of the document! Wheee! - (url-http-debug "Saw end of stream chunk!") - (setq read-next-chunk nil) - (url-display-percentage nil nil) - ;; Every chunk, even the last 0-length one, is - ;; terminated by CRLF. Skip it. - (when (looking-at "\r?\n") - (url-http-debug "Removing terminator of last chunk") - (delete-region (match-beginning 0) (match-end 0))) - (if (re-search-forward "^\r?\n" nil t) - (url-http-debug "Saw end of trailers...")) - (if (url-http-parse-headers) - (url-http-activate-callback)))))))))) + "Reading... chunk #%d" + url-http-chunked-counter)) + (url-http-debug "Reading chunk %d (%d %d %d)" + url-http-chunked-counter st nd length) + (setq regexp (if no-initial-crlf + "\\([0-9a-z]+\\).*\r?\n" + "\r?\n\\([0-9a-z]+\\).*\r?\n")) + + (if url-http-chunked-start + ;; We know how long the chunk is supposed to be, skip over + ;; leading crap if possible. + (if (> nd (+ url-http-chunked-start url-http-chunked-length)) + (progn + (url-http-debug "Got to the end of chunk #%d!" + url-http-chunked-counter) + (goto-char (+ url-http-chunked-start + url-http-chunked-length))) + (url-http-debug "Still need %d bytes to hit end of chunk" + (- (+ url-http-chunked-start + url-http-chunked-length) + nd)) + (setq read-next-chunk nil))) + (if (not read-next-chunk) + (url-http-debug "Still spinning for next chunk...") + (if no-initial-crlf (skip-chars-forward "\r\n")) + (if (not (looking-at regexp)) + (progn + ;; Must not have received the entirety of the chunk header, + ;; need to spin some more. + (url-http-debug "Did not see start of chunk @ %d!" (point)) + (setq read-next-chunk nil)) + ;; The data we got may have started in the middle of the + ;; initial chunk header, so move back to the start of the + ;; line and re-compute. + (when (= url-http-chunked-counter 0) + (beginning-of-line) + (looking-at regexp)) + (add-text-properties (match-beginning 0) (match-end 0) + (list 'chunked-encoding t + 'face 'cursor + 'invisible t)) + (setq url-http-chunked-length + (string-to-number (buffer-substring (match-beginning 1) + (match-end 1)) + 16) + url-http-chunked-counter (1+ url-http-chunked-counter) + url-http-chunked-start (set-marker + (or url-http-chunked-start + (make-marker)) + (match-end 0))) + (delete-region (match-beginning 0) (match-end 0)) + (url-http-debug "Saw start of chunk %d (length=%d, start=%d" + url-http-chunked-counter url-http-chunked-length + (marker-position url-http-chunked-start)) + (if (= 0 url-http-chunked-length) + (progn + ;; Found the end of the document! Wheee! + (url-http-debug "Saw end of stream chunk!") + (setq read-next-chunk nil) + (url-display-percentage nil nil) + ;; Every chunk, even the last 0-length one, is + ;; terminated by CRLF. Skip it. + (if (not (looking-at "\r?\n")) + (progn + (url-http-debug + "Spinning for the terminator of last chunk...") + (setq url-http-chunked-last-crlf-missing + (point))) + (url-http-debug "Removing terminator of last chunk") + (delete-region (match-beginning 0) (match-end 0)) + (when (re-search-forward "^\r?\n" nil t) + (url-http-debug "Saw end of trailers...")) + (when (url-http-parse-headers) + (url-http-activate-callback)))))))))))) (defun url-http-wait-for-headers-change-function (_st nd _length) ;; This will wait for the headers to arrive and then splice in the @@ -1304,9 +1330,7 @@ The return value of this function is the retrieval buffer." (cl-check-type url url "Need a pre-parsed URL.") (let* (;; (host (url-host (or url-using-proxy url))) ;; (port (url-port (or url-using-proxy url))) - (nsm-noninteractive (or url-request-noninteractive - (and (boundp 'url-http-noninteractive) - url-http-noninteractive))) + (nsm-noninteractive (not (url-interactive-p))) ;; The following binding is needed in url-open-stream, which ;; is called from url-http-find-free-connection. (url-current-object url) @@ -1337,6 +1361,7 @@ The return value of this function is the retrieval buffer." url-http-after-change-function url-http-response-version url-http-response-status + url-http-chunked-last-crlf-missing url-http-chunked-length url-http-chunked-counter url-http-chunked-start @@ -1361,6 +1386,7 @@ The return value of this function is the retrieval buffer." url-http-noninteractive url-request-noninteractive url-http-data url-request-data url-http-process connection + url-http-chunked-last-crlf-missing nil url-http-chunked-length nil url-http-chunked-start nil url-http-chunked-counter 0 @@ -1407,10 +1433,10 @@ The return value of this function is the retrieval buffer." (and proxy-auth (concat "Proxy-Authorization: " proxy-auth "\r\n"))) "\r\n") - (url-host url-current-object) + (puny-encode-domain (url-host url-current-object)) (or (url-port url-current-object) url-https-default-port) - (url-host url-current-object)))) + (puny-encode-domain (url-host url-current-object))))) (defun url-https-proxy-after-change-function (_st _nd _length) (let* ((process-buffer (current-buffer)) @@ -1432,12 +1458,12 @@ The return value of this function is the retrieval buffer." (condition-case e (let ((tls-connection (gnutls-negotiate :process proc - :hostname (url-host url-current-object) + :hostname (puny-encode-domain (url-host url-current-object)) :verify-error nil))) ;; check certificate validity (setq tls-connection (nsm-verify-connection tls-connection - (url-host url-current-object) + (puny-encode-domain (url-host url-current-object)) (url-port url-current-object))) (with-current-buffer process-buffer (erase-buffer)) (set-process-buffer tls-connection process-buffer) diff --git a/lisp/url/url-privacy.el b/lisp/url/url-privacy.el index 78bb78b1ee2..f897248fe4c 100644 --- a/lisp/url/url-privacy.el +++ b/lisp/url/url-privacy.el @@ -48,6 +48,7 @@ (pcase (or window-system 'tty) ('x "X11") ('ns "OpenStep") + ('pgtk "PureGTK") ('tty "TTY") (_ nil))))) diff --git a/lisp/url/url-queue.el b/lisp/url/url-queue.el index 8741bca9423..b2e24607e11 100644 --- a/lisp/url/url-queue.el +++ b/lisp/url/url-queue.el @@ -31,6 +31,7 @@ (eval-when-compile (require 'cl-lib)) (require 'browse-url) (require 'url-parse) +(require 'url-file) (defcustom url-queue-parallel-processes 6 "The number of concurrent processes." @@ -155,14 +156,16 @@ The variable `url-queue-timeout' sets a timeout." (defun url-queue-start-retrieve (job) (setf (url-queue-buffer job) (ignore-errors - (with-current-buffer (if (buffer-live-p (url-queue-context-buffer job)) + (with-current-buffer (if (buffer-live-p + (url-queue-context-buffer job)) (url-queue-context-buffer job) (current-buffer)) - (let ((url-request-noninteractive t)) - (url-retrieve (url-queue-url job) - #'url-queue-callback-function (list job) - (url-queue-silentp job) - (url-queue-inhibit-cookiesp job))))))) + (let ((url-request-noninteractive t) + (url-allow-non-local-files t)) + (url-retrieve (url-queue-url job) + #'url-queue-callback-function (list job) + (url-queue-silentp job) + (url-queue-inhibit-cookiesp job))))))) (defun url-queue-prune-old-entries () (let (dead-jobs) diff --git a/lisp/url/url-util.el b/lisp/url/url-util.el index b8b7980e40b..fc84d451760 100644 --- a/lisp/url/url-util.el +++ b/lisp/url/url-util.el @@ -1,7 +1,6 @@ ;;; url-util.el --- Miscellaneous helper routines for URL library -*- lexical-binding: t -*- -;; Copyright (C) 1996-1999, 2001, 2004-2022 Free Software Foundation, -;; Inc. +;; Copyright (C) 1996-2022 Free Software Foundation, Inc. ;; Author: Bill Perry <wmperry@gnu.org> ;; Maintainer: emacs-devel@gnu.org @@ -217,9 +216,7 @@ Will not do anything if `url-show-status' is nil." ;;;###autoload (defun url-percentage (x y) - (if (fboundp 'float) - (round (* 100 (/ x (float y)))) - (/ (* x 100) y))) + (round (* 100 (/ x (float y))))) ;;;###autoload (defalias 'url-basepath 'url-file-directory) diff --git a/lisp/url/url-vars.el b/lisp/url/url-vars.el index 83c089a930a..1012525568b 100644 --- a/lisp/url/url-vars.el +++ b/lisp/url/url-vars.el @@ -1,7 +1,6 @@ ;;; url-vars.el --- Variables for Uniform Resource Locator tool -*- lexical-binding:t -*- -;; Copyright (C) 1996-1999, 2001, 2004-2022 Free Software Foundation, -;; Inc. +;; Copyright (C) 1996-2022 Free Software Foundation, Inc. ;; Keywords: comm, data, processes, hypermedia @@ -131,7 +130,7 @@ Samples: This variable controls several other variables and is _NOT_ automatically updated. Call the function `url-setup-privacy-info' after modifying this variable." - :initialize 'custom-initialize-default + :initialize #'custom-initialize-default :set (lambda (sym val) (set-default sym val) (url-setup-privacy-info)) :type '(radio (const :tag "None (you believe in the basic goodness of humanity)" :value none) @@ -204,10 +203,9 @@ from the ACCESS_proxy environment variables." :type 'boolean :group 'url-cache) -(defvar url-mime-separator-chars (mapcar 'identity - (concat "ABCDEFGHIJKLMNOPQRSTUVWXYZ" - "abcdefghijklmnopqrstuvwxyz" - "0123456789'()+_,-./=?")) +(defvar url-mime-separator-chars (append "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + "abcdefghijklmnopqrstuvwxyz" + "0123456789'()+_,-./=?") "Characters allowable in a MIME multipart separator.") (defcustom url-bad-port-list @@ -254,7 +252,7 @@ Generated according to current coding system priorities." (push (car elt) accum))) (nreverse accum))))) (concat (format "%s;q=1, " (pop ordered)) - (mapconcat 'symbol-name ordered ";q=0.5, ") + (mapconcat #'symbol-name ordered ";q=0.5, ") ";q=0.5"))) (defvar url-mime-charset-string nil @@ -398,7 +396,7 @@ Should be one of: (defvar url-lazy-message-time 0) ;; Fixme: We may not be able to run SSL. -(defvar url-extensions-header "Security/Digest Security/SSL") +(defvar url-extensions-header nil) (defvar url-parse-syntax-table (copy-syntax-table emacs-lisp-mode-syntax-table) @@ -424,11 +422,15 @@ Should be one of: This should be set, e.g. by mail user agents rendering HTML to avoid `bugs' which call home.") +(defun url-interactive-p () + "Non-nil when the current request is from an interactive context." + (not (or url-request-noninteractive + (bound-and-true-p url-http-noninteractive)))) + ;; Obsolete (defconst url-version "Emacs" "Version number of URL package.") (make-obsolete-variable 'url-version 'emacs-version "28.1") (provide 'url-vars) - ;;; url-vars.el ends here diff --git a/lisp/userlock.el b/lisp/userlock.el index 818353f366f..a8e699385c7 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/add-log.el b/lisp/vc/add-log.el index 8b55a78f84d..beaad2e835f 100644 --- a/lisp/vc/add-log.el +++ b/lisp/vc/add-log.el @@ -590,9 +590,8 @@ Compatibility function for \\[next-error] invocations." ["Go To Source" change-log-goto-source :help "Go to source location of ChangeLog tag near point"])) -;; It used to be called change-log-time-zone-rule but really should be -;; called add-log-time-zone-rule since it's only used from add-log-* code. -(defvaralias 'change-log-time-zone-rule 'add-log-time-zone-rule) +(define-obsolete-variable-alias 'change-log-time-zone-rule + 'add-log-time-zone-rule "29.1") (defvar add-log-time-zone-rule nil "Time zone rule used for calculating change log time stamps. If nil, use local time. If t, use Universal Time. @@ -1069,8 +1068,23 @@ the change log file in another window." (insert-before-markers "(")) (error nil))))) +;; If we're filling a line that has a whole bunch of file names, and +;; we're still in the file names, then transform this so that it'll +;; still font-lock properly. +(defun change-log-fill-file-list () + (save-excursion + (unless (bobp) + (forward-line -1) + (when (looking-at change-log-file-names-re) + (goto-char (match-end 0)) + (while (looking-at "\\=, \\([^ ,:([\n]+\\)") + (goto-char (match-end 0))) + (when (looking-at ", *\n") + (replace-match ":\n *" t t)))))) + (defun change-log-indent () (change-log-fill-parenthesized-list) + (change-log-fill-file-list) (let* ((indent (save-excursion (beginning-of-line) diff --git a/lisp/vc/cvs-status.el b/lisp/vc/cvs-status.el index c368da88754..7f921a73398 100644 --- a/lisp/vc/cvs-status.el +++ b/lisp/vc/cvs-status.el @@ -29,23 +29,21 @@ ;;; Code: (require 'cl-lib) -(require 'pcvs-util) +(require 'pcvs) ;;; -(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 cd1e1b9d087..0fd67422d55 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 @@ -1476,6 +1479,14 @@ See `after-change-functions' for the meaning of BEG, END and LEN." (defvar whitespace-style) (defvar whitespace-trailing-regexp) +(defvar-local diff-mode-read-only nil + "Non-nil when read-only diff buffer uses short keys.") + +;; It should be lower than `outline-minor-mode' and `view-mode'. +(or (assq 'diff-mode-read-only minor-mode-map-alist) + (nconc minor-mode-map-alist + (list (cons 'diff-mode-read-only diff-mode-shared-map)))) + ;;;###autoload (define-derived-mode diff-mode fundamental-mode "Diff" "Major mode for viewing/editing context diffs. @@ -1494,7 +1505,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 @@ -1514,23 +1524,23 @@ a diff with \\[diff-reverse-direction]. (diff-setup-whitespace) - (if diff-default-read-only - (setq buffer-read-only t)) + ;; read-only setup + (when diff-default-read-only + (setq buffer-read-only t)) + (when buffer-read-only + (setq diff-mode-read-only t)) + (add-hook 'read-only-mode-hook + (lambda () + (setq diff-mode-read-only buffer-read-only)) + nil t) + ;; setup change hooks (if (not diff-update-on-the-fly) (add-hook 'write-contents-functions #'diff-write-contents-hooks nil t) (make-local-variable 'diff-unhandled-changes) (add-hook 'after-change-functions #'diff-after-change-function nil t) (add-hook 'post-command-hook #'diff-post-command-hook nil t)) - ;; Neat trick from Dave Love to add more bindings in read-only mode: - (let ((ro-bind (cons 'buffer-read-only diff-mode-shared-map))) - (add-to-list 'minor-mode-overriding-map-alist ro-bind) - ;; Turn off this little trick in case the buffer is put in view-mode. - (add-hook 'view-mode-hook - (lambda () - (setq minor-mode-overriding-map-alist - (delq ro-bind minor-mode-overriding-map-alist))) - nil t)) + ;; add-log support (setq-local add-log-current-defun-function #'diff-current-defun) (setq-local add-log-buffer-file-name-function @@ -1539,11 +1549,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 +1585,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 @@ -2251,21 +2272,24 @@ Return new point, if it was moved." "Iterate over all hunks between point and MAX. Call FUN with two args (BEG and END) for each hunk." (save-excursion - (let* ((beg (or (ignore-errors (diff-beginning-of-hunk)) - (ignore-errors (diff-hunk-next) (point)) - max))) - (while (< beg max) - (goto-char beg) - (cl-assert (looking-at diff-hunk-header-re)) - (let ((end - (save-excursion (diff-end-of-hunk) (point)))) - (cl-assert (< beg end)) - (funcall fun beg end) - (goto-char end) - (setq beg (if (looking-at diff-hunk-header-re) - end - (or (ignore-errors (diff-hunk-next) (point)) - max)))))))) + (catch 'malformed + (let* ((beg (or (ignore-errors (diff-beginning-of-hunk)) + (ignore-errors (diff-hunk-next) (point)) + max))) + (while (< beg max) + (goto-char beg) + (unless (looking-at diff-hunk-header-re) + (throw 'malformed nil)) + (let ((end + (save-excursion (diff-end-of-hunk) (point)))) + (unless (< beg end) + (throw 'malformed nil)) + (funcall fun beg end) + (goto-char end) + (setq beg (if (looking-at diff-hunk-header-re) + end + (or (ignore-errors (diff-hunk-next) (point)) + max))))))))) (defun diff--font-lock-refined (max) "Apply hunk refinement from font-lock." @@ -2576,40 +2600,93 @@ fixed, visit it in a buffer." (defun diff--font-lock-prettify (limit) (when diff-font-lock-prettify - (save-excursion - ;; FIXME: Include the first space for context-style hunks! - (while (re-search-forward "^[-+! ]" limit t) - (let ((spec (alist-get (char-before) - '((?+ . (left-fringe diff-fringe-add diff-indicator-added)) - (?- . (left-fringe diff-fringe-del diff-indicator-removed)) - (?! . (left-fringe diff-fringe-rep diff-indicator-changed)) - (?\s . (left-fringe diff-fringe-nul fringe)))))) - (put-text-property (match-beginning 0) (match-end 0) 'display spec)))) + (when (> (frame-parameter nil 'left-fringe) 0) + (save-excursion + ;; FIXME: Include the first space for context-style hunks! + (while (re-search-forward "^[-+! ]" limit t) + (unless (eq (get-text-property (match-beginning 0) 'face) + 'diff-header) + (put-text-property + (match-beginning 0) (match-end 0) + 'display + (alist-get + (char-before) + '((?+ . (left-fringe diff-fringe-add diff-indicator-added)) + (?- . (left-fringe diff-fringe-del diff-indicator-removed)) + (?! . (left-fringe diff-fringe-rep diff-indicator-changed)) + (?\s . (left-fringe diff-fringe-nul fringe))))))))) ;; Mimicks the output of Magit's diff. ;; FIXME: This has only been tested with Git's diff output. + ;; FIXME: Add support for Git's "rename from/to"? (while (re-search-forward "^diff " limit t) - ;; FIXME: Switching between context<->unified leads to messed up - ;; file headers by cutting the `display' property in chunks! + ;; We split the regexp match into a search plus a looking-at because + ;; we want to use LIMIT for the search but we still want to match + ;; all the header's lines even if LIMIT falls in the middle of it. (when (save-excursion (forward-line 0) (looking-at (eval-when-compile - (concat "diff.*\n" - "\\(?:\\(?:new file\\|deleted\\).*\n\\)?" - "\\(?:index.*\n\\)?" - "--- \\(?:" null-device "\\|a/\\(.*\\)\\)\n" - "\\+\\+\\+ \\(?:" null-device "\\|b/\\(.*\\)\\)\n")))) - (put-text-property (match-beginning 0) - (or (match-beginning 2) (match-beginning 1)) - 'display (propertize - (cond - ((null (match-beginning 1)) "new file ") - ((null (match-beginning 2)) "deleted ") - (t "modified ")) - 'face '(diff-file-header diff-header))) - (unless (match-beginning 2) - (put-text-property (match-end 1) (1- (match-end 0)) - 'display ""))))) + (let* ((index "\\(?:index.*\n\\)?") + (file4 (concat + "\\(?:" null-device "\\|[ab]/\\(?4:.*\\)\\)")) + (file5 (concat + "\\(?:" null-device "\\|[ab]/\\(?5:.*\\)\\)")) + (header (concat "--- " file4 "\n" + "\\+\\+\\+ " file5 "\n")) + (binary (concat + "Binary files " file4 + " and " file5 " \\(?7:differ\\)\n")) + (horb (concat "\\(?:" header "\\|" binary "\\)?"))) + (concat "diff.*?\\(?: a/\\(.*?\\) b/\\(.*\\)\\)?\n" + "\\(?:" + ;; For new/deleted files, there might be no + ;; header (and no hunk) if the file is/was empty. + "\\(?3:new\\(?6:\\)\\|deleted\\) file mode \\(?10:[0-7]\\{6\\}\\)\n" + index horb + ;; Normal case. There might be no header + ;; (and no hunk) if only the file mode + ;; changed. + "\\|" + "\\(?:old mode \\(?8:[0-7]\\{6\\}\\)\n\\)?" + "\\(?:new mode \\(?9:[0-7]\\{6\\}\\)\n\\)?" + index horb "\\)"))))) + ;; The file names can be extracted either from the `diff' line + ;; or from the two header lines. Prefer the header line info if + ;; available since the `diff' line is ambiguous in case the + ;; file names include " b/" or " a/". + ;; FIXME: This prettification throws away all the information + ;; about the index hashes. + (let ((oldfile (or (match-string 4) (match-string 1))) + (newfile (or (match-string 5) (match-string 2))) + (kind (if (match-beginning 7) " BINARY" + (unless (or (match-beginning 4) + (match-beginning 5) + (not (match-beginning 3))) + " empty"))) + (filemode + (cond + ((match-beginning 10) + (concat " file with mode " (match-string 10) " ")) + ((and (match-beginning 8) (match-beginning 9)) + (concat " file (mode changed from " + (match-string 8) " to " (match-string 9) ") ")) + (t " file ")))) + (add-text-properties + (match-beginning 0) (1- (match-end 0)) + (list 'display + (propertize + (cond + ((match-beginning 3) + (concat (capitalize (match-string 3)) kind filemode + (if (match-beginning 6) newfile oldfile))) + ((and (null (match-string 4)) (match-string 5)) + (concat "New " kind filemode newfile)) + ((null (match-string 2)) + (concat "Deleted" kind filemode oldfile)) + (t + (concat "Modified" kind filemode oldfile))) + 'face '(diff-file-header diff-header)) + 'font-lock-multiline t)))))) nil) ;;; Syntax highlighting from font-lock @@ -2654,7 +2731,8 @@ When OLD is non-nil, highlight the hunk from the old source." ;; Trim a trailing newline to find hunk in diff-syntax-fontify-props ;; in diffs that have no newline at end of diff file. (text (string-trim-right - (or (with-demoted-errors (diff-hunk-text hunk (not old) nil)) + (or (with-demoted-errors "Error getting hunk text: %S" + (diff-hunk-text hunk (not old) nil)) ""))) (line (if (looking-at "\\(?:\\*\\{15\\}.*\n\\)?[-@* ]*\\([0-9,]+\\)\\([ acd+]+\\([0-9,]+\\)\\)?") (if old (match-string 1) diff --git a/lisp/vc/diff.el b/lisp/vc/diff.el index 341a2891265..3e35a3329b1 100644 --- a/lisp/vc/diff.el +++ b/lisp/vc/diff.el @@ -52,6 +52,12 @@ set (`vc-git-diff-switches' for git, for instance), and "The command to use to run diff." :type 'string) +(defcustom diff-entire-buffers t + "If non-nil, diff the entire buffers, not just the visible part. +If nil, only use the narrowed-to parts of the buffers." + :type 'boolean + :version "29.1") + ;; prompt if prefix arg present (defun diff-switches () (if current-prefix-arg @@ -96,15 +102,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))) @@ -119,7 +125,9 @@ temporary file with the buffer's contents." (if (bufferp file-or-buf) (with-current-buffer file-or-buf (let ((tempfile (make-temp-file "buffer-content-"))) - (write-region nil nil tempfile nil 'nomessage) + (if diff-entire-buffers + (write-region nil nil tempfile nil 'nomessage) + (write-region (point-min) (point-max) tempfile nil 'nomessage)) tempfile)) (file-local-copy file-or-buf))) @@ -145,7 +153,7 @@ Possible values are: ;; Noninteractive helper for creating and reverting diff buffers "Compare the OLD and NEW file/buffer. If the optional SWITCHES is nil, the switches specified in the -variable ‘diff-switches’ are passed to the diff command, +variable `diff-switches' are passed to the diff command, otherwise SWITCHES is used. SWITCHES can be a string or a list of strings. @@ -274,7 +282,9 @@ interactively for diff switches. Otherwise, the switches specified in the variable `diff-switches' are passed to the diff command. -OLD and NEW may each be a buffer or a buffer name." +OLD and NEW may each be a buffer or a buffer name. + +Also see the `diff-entire-buffers' variable." (interactive (let ((newb (read-buffer "Diff new buffer" (current-buffer) t)) (oldb (read-buffer "Diff original buffer" diff --git a/lisp/vc/ediff-diff.el b/lisp/vc/ediff-diff.el index ca56a2851db..07b853817d1 100644 --- a/lisp/vc/ediff-diff.el +++ b/lisp/vc/ediff-diff.el @@ -85,7 +85,10 @@ options after the default ones. This variable is not for customizing the look of the differences produced by the command \\[ediff-show-diff-output]. Use the variable -`ediff-custom-diff-options' for that." +`ediff-custom-diff-options' for that. + +Setting this variable directly may not yield the expected +results. It should be set via the Customize interface instead." :set #'ediff-set-diff-options :type 'string) diff --git a/lisp/vc/ediff-help.el b/lisp/vc/ediff-help.el index 1a970f344e5..4e412041691 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 896773067b7..de0a4d71ed2 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-merg.el b/lisp/vc/ediff-merg.el index de8c587b1ca..aae6ad549ea 100644 --- a/lisp/vc/ediff-merg.el +++ b/lisp/vc/ediff-merg.el @@ -54,7 +54,7 @@ Valid values are the symbols `default-A', `default-B', and `combined'." The value must be a list of the form \(STRING1 bufspec1 STRING2 bufspec2 STRING3 bufspec3 STRING4) where bufspec is the symbol A, B, or Ancestor. For instance, if the value is -'(STRING1 A STRING2 Ancestor STRING3 B STRING4) then the +`(STRING1 A STRING2 Ancestor STRING3 B STRING4)' then the combined text will look like this: STRING1 diff --git a/lisp/vc/ediff-ptch.el b/lisp/vc/ediff-ptch.el index 8a6785e2c58..17654f80ec7 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 c757f71818b..040a9a63c5a 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 @@ -3435,6 +3431,9 @@ Without an argument, it saves customized diff argument, if available )) (defun ediff-show-diff-output (arg) + "With prefix argument ARG, show plain diff output. +Without an argument, save the customized diff argument, if available +(and plain output, if customized output was not generated)." (interactive "P") (ediff-barf-if-not-control-buffer) (ediff-compute-custom-diffs-maybe) @@ -3442,7 +3441,10 @@ Without an argument, it saves customized diff argument, if available (ediff-skip-unsuitable-frames ' ok-unsplittable)) (let ((buf (cond ((and arg (ediff-buffer-live-p ediff-diff-buffer)) ediff-diff-buffer) - ((ediff-buffer-live-p ediff-custom-diff-buffer) + ((and (ediff-buffer-live-p ediff-custom-diff-buffer) + ;; We may not have gotten a custom output if + ;; we're working on unsaved buffers. + (> (buffer-size ediff-custom-diff-buffer) 0)) ediff-custom-diff-buffer) ((ediff-buffer-live-p ediff-diff-buffer) ediff-diff-buffer) diff --git a/lisp/vc/ediff.el b/lisp/vc/ediff.el index 7841c256034..840ab8cf51c 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 c2000c7eec3..e958673fea8 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'." @@ -712,10 +710,14 @@ different header separator appropriate for `log-edit-mode'." (interactive) (when (or (called-interactively-p 'interactive) (log-edit-empty-buffer-p)) - (insert "Summary: ") - (when log-edit-setup-add-author - (insert "\nAuthor: ")) - (insert "\n\n") + (dolist (header (append '("Summary") (and log-edit-setup-add-author + '("Author")))) + ;; Make `C-a' work like in other buffers with header names. + (insert (propertize (concat header ": ") + 'field 'header + 'rear-nonsticky t) + "\n")) + (insert "\n") (message-position-point))) (defun log-edit-insert-cvs-template () diff --git a/lisp/vc/log-view.el b/lisp/vc/log-view.el index bb2f49a7b65..415b1564eda 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,19 @@ :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) (easy-menu-define log-view-mode-menu log-view-mode-map "Log-View Display Menu." @@ -181,9 +162,15 @@ ["Previous Log Entry" log-view-msg-prev :help "Go to the previous count'th log message"] ["Next File" log-view-file-next - :help "Go to the next count'th file"] + :help "Go to the next count'th file" + :active (derived-mode-p vc-cvs-log-view-mode + vc-rcs-log-view-mode + vc-sccs-log-view-mode)] ["Previous File" log-view-file-prev - :help "Go to the previous count'th file"])) + :help "Go to the previous count'th file" + :active (derived-mode-p vc-cvs-log-view-mode + vc-rcs-log-view-mode + vc-sccs-log-view-mode)])) (defvar log-view-mode-hook nil "Hook run at the end of `log-view-mode'.") diff --git a/lisp/vc/pcvs-defs.el b/lisp/vc/pcvs-defs.el index f6b1895a5ca..2f11716bde9 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-info.el b/lisp/vc/pcvs-info.el index 11d14f95766..b48a4a1cbf1 100644 --- a/lisp/vc/pcvs-info.el +++ b/lisp/vc/pcvs-info.el @@ -130,9 +130,11 @@ to confuse some users sometimes." (defvar cvs-bakprefix ".#" "The prefix that CVS prepends to files when rcsmerge'ing.") -(easy-mmode-defmap cvs-status-map - '(([(mouse-2)] . cvs-mode-toggle-mark)) - "Local keymap for text properties of status.") +(declare-function cvs-mode-toggle-mark "pcvs" (e)) + +(defvar-keymap cvs-status-map + :doc "Local keymap for text properties of status." + "<mouse-2>" #'cvs-mode-toggle-mark) ;; Constructor: diff --git a/lisp/vc/pcvs.el b/lisp/vc/pcvs.el index 59b3d63c64a..c19fe9bd2ad 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 51ad8293f65..003b26eca41 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) @@ -926,8 +925,11 @@ Its behavior has mainly two restrictions: to `smerge-refine-regions'. This only matters if `smerge-refine-weight-hack' is nil.") -(defvar smerge-refine-ignore-whitespace t - "If non-nil, `smerge-refine' should try to ignore change in whitespace.") +(defcustom smerge-refine-ignore-whitespace t + "If non-nil, `smerge-refine' should try to ignore change in whitespace." + :type 'boolean + :version "29.1" + :group 'diff) (defvar smerge-refine-weight-hack t "If non-nil, pass to diff as many lines as there are chars in the region. diff --git a/lisp/vc/vc-annotate.el b/lisp/vc/vc-annotate.el index bd4ff3e015a..4a511f1f688 100644 --- a/lisp/vc/vc-annotate.el +++ b/lisp/vc/vc-annotate.el @@ -57,7 +57,7 @@ is applied to the background." :set (lambda (symbol value) (set-default symbol value) (when (boundp 'vc-annotate-color-map) - (with-demoted-errors + (with-demoted-errors "VC color map error: %S" ;; Update the value of the dependent variable. (custom-reevaluate-setting 'vc-annotate-color-map)))) :version "25.1" diff --git a/lisp/vc/vc-cvs.el b/lisp/vc/vc-cvs.el index 8f06d5a847a..1f81ff2e0fe 100644 --- a/lisp/vc/vc-cvs.el +++ b/lisp/vc/vc-cvs.el @@ -26,6 +26,7 @@ (require 'vc-rcs) (eval-when-compile (require 'vc)) +(require 'log-view) (declare-function vc-checkout "vc" (file &optional rev)) (declare-function vc-expand-dirs "vc" (file-or-dir-list backend)) @@ -1257,6 +1258,14 @@ ignore file." (if sort (sort-lines nil (point-min) (point-max))) (save-buffer))))) +(defvar-keymap vc-cvs-log-view-mode-map + "N" #'log-view-file-next + "P" #'log-view-file-prev + "M-n" #'log-view-file-next + "M-p" #'log-view-file-prev) + +(define-derived-mode vc-cvs-log-view-mode log-view-mode "CVS-Log-View") + (provide 'vc-cvs) ;;; vc-cvs.el ends here diff --git a/lisp/vc/vc-dir.el b/lisp/vc/vc-dir.el index 9cf6422de00..9335da10065 100644 --- a/lisp/vc/vc-dir.el +++ b/lisp/vc/vc-dir.el @@ -325,6 +325,7 @@ See `run-hooks'." (define-key map "U" #'vc-dir-unmark-all-files) (define-key map "\C-?" #'vc-dir-unmark-file-up) (define-key map "\M-\C-?" #'vc-dir-unmark-all-files) + (define-key map "%" #'vc-dir-mark-by-regexp) ;; Movement. (define-key map "n" #'vc-dir-next-line) (define-key map " " #'vc-dir-next-line) @@ -750,6 +751,23 @@ share the same state." (vc-dir-mark-file crt))) (setq crt (ewoc-next vc-ewoc crt)))))))) +(defun vc-dir-mark-by-regexp (regexp &optional unmark) + "Mark all files that match REGEXP. +If UNMARK (interactively, the prefix), unmark instead." + (interactive "sMark files matching: \nP") + (ewoc-map + (lambda (filearg) + (when (and (not (vc-dir-fileinfo->directory filearg)) + (eq (not unmark) + (not (vc-dir-fileinfo->marked filearg))) + ;; We don't want to match on the part of the file + ;; that's above the current directory. + (string-match-p regexp (file-relative-name + (vc-dir-fileinfo->name filearg)))) + (setf (vc-dir-fileinfo->marked filearg) (not unmark)) + t)) + vc-ewoc)) + (defun vc-dir-mark-files (mark-files) "Mark files specified by file names in the argument MARK-FILES. MARK-FILES should be a list of absolute filenames." @@ -1433,7 +1451,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 @@ -1539,9 +1562,8 @@ These are the commands available for use in the file status buffer: This implements the `bookmark-make-record-function' type for `vc-dir' buffers." (let* ((bookmark-name - (concat "(" (symbol-name vc-dir-backend) ") " - (file-name-nondirectory - (directory-file-name default-directory)))) + (file-name-nondirectory + (directory-file-name default-directory))) (defaults (list bookmark-name default-directory))) `(,bookmark-name ,@(bookmark-make-record-default 'no-file) @@ -1561,6 +1583,8 @@ type returned by `vc-dir-bookmark-make-record'." (bookmark-default-handler `("" (buffer . ,buf) . ,(bookmark-get-bookmark-record bmk))))) +(put 'vc-dir-bookmark-jump 'bookmark-handler-type "VC") + (provide 'vc-dir) diff --git a/lisp/vc/vc-dispatcher.el b/lisp/vc/vc-dispatcher.el index a55954467e0..5c664d58f1a 100644 --- a/lisp/vc/vc-dispatcher.el +++ b/lisp/vc/vc-dispatcher.el @@ -127,8 +127,12 @@ preserve the setting." :group 'vc) (defcustom vc-command-messages nil - "If non-nil, display run messages from back-end commands." - :type 'boolean + "If non-nil, display and log messages about running back-end commands. +If the value is `log', messages about running VC back-end commands are +logged in the *Messages* buffer, but not displayed." + :type '(choice (const :tag "No messages" nil) + (const :tag "Display and log messages" t) + (const :tag "Log messages, but don't display" log)) :group 'vc) (defcustom vc-suppress-confirm nil @@ -311,7 +315,10 @@ case, and the process object in the asynchronous case." (substring command 0 -1) command) " " (vc-delistify flags) - " " (vc-delistify files)))) + " " (vc-delistify files))) + (vc-inhibit-message + (or (eq vc-command-messages 'log) + (eq (selected-window) (active-minibuffer-window))))) (save-current-buffer (unless (or (eq buffer t) (and (stringp buffer) @@ -335,7 +342,7 @@ case, and the process object in the asynchronous case." (apply #'start-file-process command (current-buffer) command squeezed)))) (when vc-command-messages - (let ((inhibit-message (eq (selected-window) (active-minibuffer-window)))) + (let ((inhibit-message vc-inhibit-message)) (message "Running in background: %s" full-command))) ;; Get rid of the default message insertion, in case we don't ;; set a sentinel explicitly. @@ -345,11 +352,11 @@ case, and the process object in the asynchronous case." (when vc-command-messages (vc-run-delayed (let ((message-truncate-lines t) - (inhibit-message (eq (selected-window) (active-minibuffer-window)))) + (inhibit-message vc-inhibit-message)) (message "Done in background: %s" full-command))))) ;; Run synchronously (when vc-command-messages - (let ((inhibit-message (eq (selected-window) (active-minibuffer-window)))) + (let ((inhibit-message vc-inhibit-message)) (message "Running in foreground: %s" full-command))) (let ((buffer-undo-list t)) (setq status (apply #'process-file command nil t nil squeezed))) @@ -364,7 +371,7 @@ case, and the process object in the asynchronous case." (if (integerp status) (format "status %d" status) status) full-command)) (when vc-command-messages - (let ((inhibit-message (eq (selected-window) (active-minibuffer-window)))) + (let ((inhibit-message vc-inhibit-message)) (message "Done (status=%d): %s" status full-command))))) (vc-run-delayed (run-hook-with-args 'vc-post-command-functions diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 7072b8e483b..8937454d111 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -290,12 +290,14 @@ Good example of file name that needs this: \"test[56].xx\".") (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) @@ -1597,7 +1599,7 @@ This requires git 1.8.4 or later, for the \"-L\" option of \"git log\"." (declare-function grep-read-regexp "grep" ()) (declare-function grep-read-files "grep" (regexp)) (declare-function grep-expand-template "grep" - (template &optional regexp files dir excl)) + (template &optional regexp files dir excl more-opts)) (defvar compilation-environment) ;; Derived from `lgrep'. @@ -1680,7 +1682,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") @@ -1693,8 +1695,8 @@ This command shares argument histories with \\[rgrep] and \\[grep]." (vc-setup-buffer "*vc-git-stash*") (vc-git-command "*vc-git-stash*" 'async nil "stash" "show" "-p" name) (set-buffer "*vc-git-stash*") - (diff-mode) (setq buffer-read-only t) + (diff-mode) (pop-to-buffer (current-buffer))) (defun vc-git-stash-apply (name) @@ -1725,12 +1727,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 @@ -1867,6 +1868,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 1b94311a817..026f125396e 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 ee295b17c73..76d97716724 100644 --- a/lisp/vc/vc-hooks.el +++ b/lisp/vc/vc-hooks.el @@ -143,6 +143,7 @@ visited and a warning displayed." (const :tag "Visit link and warn" nil) (const :tag "Follow link" t)) :group 'vc) +(put 'vc-follow-symlinks 'safe-local-variable #'null) (defcustom vc-display-status t "If non-nil, display revision number and lock status in mode line. @@ -798,9 +799,10 @@ In the latter case, VC mode is deactivated for this buffer." (add-hook 'vc-mode-line-hook #'vc-mode-line nil t) (let (backend) (cond - ((setq backend (with-demoted-errors (vc-backend buffer-file-name))) - ;; Let the backend setup any buffer-local things he needs. - (vc-call-backend backend 'find-file-hook) + ((setq backend (with-demoted-errors "VC refresh error: %S" + (vc-backend buffer-file-name))) + ;; Let the backend setup any buffer-local things he needs. + (vc-call-backend backend 'find-file-hook) ;; Compute the state and put it in the mode line. (vc-mode-line buffer-file-name backend) (unless vc-make-backup-files @@ -864,7 +866,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) @@ -963,7 +966,7 @@ In the latter case, VC mode is deactivated for this buffer." (defalias 'vc-menu-map vc-menu-map) -(declare-function vc-responsible-backend "vc" (file)) +(declare-function vc-responsible-backend "vc" (file &optional no-error)) (defun vc-menu-map-filter (orig-binding) (if (and (symbolp orig-binding) (fboundp orig-binding)) diff --git a/lisp/vc/vc-rcs.el b/lisp/vc/vc-rcs.el index fb57b2bbc6e..a4345c7d7e2 100644 --- a/lisp/vc/vc-rcs.el +++ b/lisp/vc/vc-rcs.el @@ -40,6 +40,7 @@ (eval-when-compile (require 'cl-lib) (require 'vc)) +(require 'log-view) (declare-function vc-read-revision "vc" (prompt &optional files backend default initial-input)) @@ -99,7 +100,7 @@ to use --brief and sets this variable to remember whether it worked." "Where to look for RCS master files. For a description of possible values, see `vc-check-master-templates'." :type '(choice (const :tag "Use standard RCS file names" - '("%sRCS/%s,v" "%s%s,v" "%sRCS/%s")) + ("%sRCS/%s,v" "%s%s,v" "%sRCS/%s")) (repeat :tag "User-specified" (choice string function))) @@ -1062,9 +1063,9 @@ file." (defun vc-rcs-consult-headers (file) "Search for RCS headers in FILE, and set properties accordingly. -Returns: nil if no headers were found - 'rev if a workfile revision was found - 'rev-and-lock if revision and lock info was found" +Returns: nil if no headers were found + `rev' if a workfile revision was found + `rev-and-lock' if revision and lock info was found" (cond ((not (get-file-buffer file)) nil) ((let (status version) @@ -1456,6 +1457,14 @@ The `:insn' key is a keyword to distinguish it as a vc-rcs.el extension." `((headers ,desc ,@headers) (revisions ,@revs))))) +(defvar-keymap vc-rcs-log-view-mode-map + "N" #'log-view-file-next + "P" #'log-view-file-prev + "M-n" #'log-view-file-next + "M-p" #'log-view-file-prev) + +(define-derived-mode vc-rcs-log-view-mode log-view-mode "RCS-Log-View") + (provide 'vc-rcs) ;;; vc-rcs.el ends here diff --git a/lisp/vc/vc-sccs.el b/lisp/vc/vc-sccs.el index 0df70c8f232..9622bf5e097 100644 --- a/lisp/vc/vc-sccs.el +++ b/lisp/vc/vc-sccs.el @@ -27,6 +27,7 @@ (eval-when-compile (require 'vc)) +(require 'log-view) ;;; ;;; Customization options @@ -216,7 +217,7 @@ to the SCCS command." ;; TODO: check for all the patterns in vc-sccs-master-templates (or (and (file-directory-p (expand-file-name "SCCS" (file-name-directory file))) - file) + (file-name-directory file)) (let ((dir (vc-sccs-search-project-dir (or (file-name-directory file) "") (file-name-nondirectory file)))) (and (stringp dir) @@ -518,6 +519,14 @@ If NAME is nil or a revision number string it's just passed through." (file-name-directory (vc-master-name file)))) (vc-parse-buffer (concat name "\t:\t" file "\t\\(.+\\)") 1)))) +(defvar-keymap vc-sccs-log-view-mode-map + "N" #'log-view-file-next + "P" #'log-view-file-prev + "M-n" #'log-view-file-next + "M-p" #'log-view-file-prev) + +(define-derived-mode vc-sccs-log-view-mode log-view-mode "SCCS-Log-View") + (provide 'vc-sccs) ;;; vc-sccs.el ends here diff --git a/lisp/vc/vc-src.el b/lisp/vc/vc-src.el index 5a252c55cb2..432448bde58 100644 --- a/lisp/vc/vc-src.el +++ b/lisp/vc/vc-src.el @@ -120,7 +120,7 @@ If nil, use the value of `vc-diff-switches'. If t, use no switches." "Where to look for SRC master files. For a description of possible values, see `vc-check-master-templates'." :type '(choice (const :tag "Use standard SRC file names" - '("%s.src/%s,v")) + ("%s.src/%s,v")) (repeat :tag "User-specified" (choice string function)))) diff --git a/lisp/vc/vc-svn.el b/lisp/vc/vc-svn.el index b38a676acbd..270877041aa 100644 --- a/lisp/vc/vc-svn.el +++ b/lisp/vc/vc-svn.el @@ -201,8 +201,8 @@ switches." ;; FIXME are there other possible combinations? (cond ((eq state 'edited) (setq state 'needs-merge)) ((not state) (setq state 'needs-update)))) - (when (and state (not (string= "." filename))) - (setq result (cons (list filename state) result))))) + (when state + (setq result (cons (list filename state) result))))) (funcall callback result))) ;; dir-status-files called from vc-dir, which loads vc, @@ -212,7 +212,7 @@ switches." (autoload 'vc-expand-dirs "vc") (defun vc-svn-dir-status-files (_dir files callback) - "Run 'svn status' for DIR and update BUFFER via CALLBACK. + "Run \"svn status\" for DIR and update BUFFER via CALLBACK. CALLBACK is called as (CALLBACK RESULT BUFFER), where RESULT is a list of conses (FILE . STATE) for directory DIR." ;; FIXME shouldn't this rather default to all the files in dir? diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index bebd0946dee..3508f684c49 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)))) @@ -994,13 +1004,14 @@ responsible for the given file." ;; ;; First try: find a responsible backend. If this is for registration, ;; it must be a backend under which FILE is not yet registered. - (let ((dirs (delq nil - (mapcar - (lambda (backend) - (when-let ((dir (vc-call-backend - backend 'responsible-p file))) - (cons backend dir))) - vc-handled-backends)))) + (let* ((file (expand-file-name file)) + (dirs (delq nil + (mapcar + (lambda (backend) + (when-let ((dir (vc-call-backend + backend 'responsible-p file))) + (cons backend dir))) + vc-handled-backends)))) ;; Just a single response (or none); use it. (if (< (length dirs) 2) (caar dirs) @@ -1188,7 +1199,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)) @@ -1716,21 +1731,48 @@ to override the value of `vc-diff-switches' and `diff-switches'." ;; any switches in diff-switches. (when (listp switches) switches)))) -(defun vc-diff-finish (buffer messages) +(defun vc-shrink-buffer-window (&optional buffer) + "Call `shrink-window-if-larger-than-buffer' only when BUFFER is visible. +BUFFER defaults to the current buffer." + (let ((window (get-buffer-window buffer t))) + (when window + (shrink-window-if-larger-than-buffer window)))) + +(defvar vc-diff-finish-functions '(vc-shrink-buffer-window) + "Functions run at the end of the diff command. +Each function runs in the diff output buffer without args.") + +(defun vc-diff-restore-buffer (original new) + "Restore point in buffer NEW to where it was in ORIGINAL. + +This function works by updating buffer ORIGINAL with the contents +of NEW (without destroying existing markers), swapping their text +objects, and finally killing buffer ORIGINAL." + (with-current-buffer original + (let ((inhibit-read-only t)) + (replace-buffer-contents new))) + (with-current-buffer new + (buffer-swap-text original)) + (kill-buffer original)) + +(defun vc-diff-finish (buffer messages &optional oldbuf) ;; The empty sync output case has already been handled, so the only ;; possibility of an empty output is for an async process. (when (buffer-live-p buffer) - (let ((window (get-buffer-window buffer t)) - (emptyp (zerop (buffer-size buffer)))) + (let ((emptyp (zerop (buffer-size buffer)))) (with-current-buffer buffer (and messages emptyp (let ((inhibit-read-only t)) (insert (cdr messages) ".\n") (message "%s" (cdr messages)))) (diff-setup-whitespace) - (goto-char (point-min)) - (when window - (shrink-window-if-larger-than-buffer window))) + (diff-setup-buffer-type) + ;; `oldbuf' is the buffer that used to show this diff. Make + ;; sure that we restore point in it if it's given. + (if oldbuf + (vc-diff-restore-buffer oldbuf buffer) + (goto-char (point-min))) + (run-hooks 'vc-diff-finish-functions)) (when (and messages (not emptyp)) (message "%sdone" (car messages)))))) @@ -1754,7 +1796,11 @@ Return t if the buffer had changes, nil otherwise." ;; but the only way to set it for each file included would ;; be to call the back end separately for each file. (coding-system-for-read - (if files (vc-coding-system-for-diff (car files)) 'undecided))) + (if files (vc-coding-system-for-diff (car files)) 'undecided)) + (orig-diff-buffer-clone + (if revert-buffer-in-progress-p + (clone-buffer + (generate-new-buffer-name " *vc-diff-clone*") nil)))) ;; On MS-Windows and MS-DOS, Diff is likely to produce DOS-style ;; EOLs, which will look ugly if (car files) happens to have Unix ;; EOLs. @@ -1793,16 +1839,16 @@ Return t if the buffer had changes, nil otherwise." (setq files (nreverse filtered)))) (vc-call-backend (car vc-fileset) 'diff files rev1 rev2 buffer async) (set-buffer buffer) + ;; Make the *vc-diff* buffer read only, the diff-mode key + ;; bindings are nicer for read only buffers. pcl-cvs does the + ;; same thing. + (setq buffer-read-only t) (diff-mode) (setq-local diff-vc-backend (car vc-fileset)) (setq-local diff-vc-revisions (list rev1 rev2)) (setq-local revert-buffer-function (lambda (_ignore-auto _noconfirm) (vc-diff-internal async vc-fileset rev1 rev2 verbose))) - ;; Make the *vc-diff* buffer read only, the diff-mode key - ;; bindings are nicer for read only buffers. pcl-cvs does the - ;; same thing. - (setq buffer-read-only t) (if (and (zerop (buffer-size)) (not (get-buffer-process (current-buffer)))) ;; Treat this case specially so as not to pop the buffer. @@ -1815,7 +1861,8 @@ Return t if the buffer had changes, nil otherwise." ;; after `pop-to-buffer'; the former assumes the diff buffer is ;; shown in some window. (let ((buf (current-buffer))) - (vc-run-delayed (vc-diff-finish buf (when verbose messages)))) + (vc-run-delayed (vc-diff-finish buf (when verbose messages) + orig-diff-buffer-clone))) ;; In the async case, we return t even if there are no differences ;; because we don't know that yet. t))) @@ -1863,13 +1910,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 +2126,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 +2422,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)) @@ -2486,6 +2530,10 @@ earlier revisions. Show up to LIMIT entries (non-nil means unlimited)." (put 'vc-log-view-type 'permanent-local t) (defvar vc-sentinel-movepoint) +(defvar vc-log-finish-functions '(vc-shrink-buffer-window) + "Functions run at the end of the log command. +Each function runs in the log output buffer without args.") + (defun vc-log-internal-common (backend buffer-name files @@ -2517,11 +2565,11 @@ earlier revisions. Show up to LIMIT entries (non-nil means unlimited)." (vc-run-delayed (let ((inhibit-read-only t)) (funcall setup-buttons-func backend files retval) - (shrink-window-if-larger-than-buffer) (when goto-location-func (funcall goto-location-func backend) (setq vc-sentinel-movepoint (point))) - (set-buffer-modified-p nil))))) + (set-buffer-modified-p nil) + (run-hooks 'vc-log-finish-functions))))) (defun vc-incoming-outgoing-internal (backend remote-location buffer-name type) (vc-log-internal-common @@ -2743,7 +2791,7 @@ to the working revision (except for keyword expansion)." (unwind-protect (when (if vc-revert-show-diff (progn - (setq diff-buffer (generate-new-buffer-name "*vc-diff*")) + (setq diff-buffer (generate-new-buffer "*vc-diff*")) (vc-diff-internal vc-allow-async-revert vc-fileset nil nil nil diff-buffer)) ;; Avoid querying the user again. diff --git a/lisp/vcursor.el b/lisp/vcursor.el index 819a051b514..a54227c1bce 100644 --- a/lisp/vcursor.el +++ b/lisp/vcursor.el @@ -216,23 +216,17 @@ ;; Key bindings ;; ============ ;; -;; There is an alternative set of key bindings which will be used -;; automatically for a PC if Oemacs is detected. This set uses separate -;; control, shift and meta keys with function keys 1 to 10. In -;; particular, movement keys are concentrated on f5 to f8 with (in -;; increasing order of distance traveled) C-, M- and S- as prefixes. -;; See the actual bindings below (search for C-f1). This is because the -;; C-S- prefix is represented by weird key sequences and the set is -;; incomplete; if you don't mind that, some hints are given in comments -;; below. +;; There is an alternative set of key bindings named "Oemacs" (for +;; historical reasons). This set uses separate control, shift and +;; meta keys with function keys 1 to 10. In particular, movement keys +;; are concentrated on f5 to f8 with (in increasing order of distance +;; traveled) C-, M- and S- as prefixes. See the actual bindings below +;; (search for C-f1). This is because the C-S- prefix is represented +;; by weird key sequences and the set is incomplete; if you don't mind +;; that, some hints are given in comments below. ;; -;; You can specify the usual or the Oemacs bindings by setting the -;; variable vcursor-key-bindings to `xterm' or `oemacs'. You can also set -;; it to nil, in which case vcursor will not make any key bindings -;; and you can define your own. The default is t, which makes vcursor -;; guess (it will use xterm unless it thinks Oemacs is running). The -;; oemacs set will work on an X terminal with function keys, but the -;; xterm set will not work under Oemacs. +;; You can specify which set of key bindings to use by customizing the +;; user option `vcursor-key-bindings'. ;; ;; Usage on dumb terminals ;; ======================= @@ -355,8 +349,7 @@ on loading vcursor and from the customize package." (set var value) (cond ((not value)) ;; Don't set any key bindings. - ((or (eq value 'oemacs) - (and (eq value t) (fboundp 'oemacs-version))) + ((eq value 'oemacs) (global-set-key [C-f1] #'vcursor-toggle-copy) (global-set-key [C-f2] #'vcursor-copy) (global-set-key [C-f3] #'vcursor-copy-word) @@ -386,33 +379,6 @@ on loading vcursor and from the customize package." (global-set-key [S-f9] #'vcursor-execute-key) (global-set-key [S-f10] #'vcursor-execute-command) - - ;; Partial dictionary of Oemacs key sequences for you to roll your own, - ;; e.g C-S-up: (global-set-key "\M-[\C-f\M-\C-m" 'vcursor-previous-line) - ;; Sequence: Sends: - ;; "\M-[\C-f\M-\C-m" C-S-up - ;; "\M-[\C-f\M-\C-q" C-S-down - ;; "\M-[\C-fs" C-S-left - ;; "\M-[\C-ft" C-S-right - ;; - ;; "\M-[\C-fw" C-S-home - ;; "\M-[\C-b\C-o" S-tab - ;; "\M-[\C-f\M-\C-r" C-S-insert - ;; "\M-[\C-fu" C-S-end - ;; "\M-[\C-f\M-\C-s" C-S-delete - ;; "\M-[\C-f\M-\C-d" C-S-prior - ;; "\M-[\C-fv" C-S-next - ;; - ;; "\M-[\C-f^" C-S-f1 - ;; "\M-[\C-f_" C-S-f2 - ;; "\M-[\C-f`" C-S-f3 - ;; "\M-[\C-fa" C-S-f4 - ;; "\M-[\C-fb" C-S-f5 - ;; "\M-[\C-fc" C-S-f6 - ;; "\M-[\C-fd" C-S-f7 - ;; "\M-[\C-fe" C-S-f8 - ;; "\M-[\C-ff" C-S-f9 - ;; "\M-[\C-fg" C-S-f10 ) (t (global-set-key (vcursor-cs-binding "up") #'vcursor-previous-line) @@ -456,11 +422,12 @@ on loading vcursor and from the customize package." (global-set-key (vcursor-cs-binding "f10") #'vcursor-execute-command) ))) +;; TODO: Get rid of references to "oemacs", which was an ancient +;; MS-DOS compatible release of Emacs 19. (defcustom vcursor-key-bindings nil "How to bind keys when vcursor is loaded. -If t, guess; if `xterm', use bindings suitable for an X terminal; if -`oemacs', use bindings which work on a PC with Oemacs. If nil, don't -define any key bindings. +If t or `xterm', use the default bindings; if `oemacs', use +alternative key bindings. If nil, don't define any key bindings. Default is nil." :type '(choice (const t) (const nil) (const xterm) (const oemacs)) @@ -788,9 +755,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. @@ -854,9 +821,7 @@ Arguments N and optional ALL-FRAMES are the same as with `other-window'. ALL-FRAMES is also used to decide whether to split the window." (interactive "p") - (if (if (fboundp 'oemacs-version) - (one-window-p nil) - (one-window-p nil all-frames)) + (if (one-window-p nil all-frames) (display-buffer (current-buffer) t)) (save-excursion (save-window-excursion diff --git a/lisp/version.el b/lisp/version.el index fa755c78676..7e360209d85 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) "Display the version of Emacs that is running in this session. With a prefix argument, insert the Emacs version string at point @@ -76,6 +78,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 a90a7631f04..3343136c1cc 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/w32-fns.el b/lisp/w32-fns.el index f353566b060..85e37ec609a 100644 --- a/lisp/w32-fns.el +++ b/lisp/w32-fns.el @@ -312,8 +312,8 @@ names." ;;;; System name and version for emacsbug.el -(declare-function w32-version "w32-win" ()) -(declare-function w32-read-registry "w32fns" (root key name)) +(declare-function w32-version "term/w32-win" ()) +(declare-function w32-read-registry "w32fns.c" (root key name)) (defun w32--os-description () "Return a string describing the underlying OS and its version." @@ -359,23 +359,6 @@ names." ;;;; Support for build process -;; From autoload.el -(defvar autoload-make-program) -(defvar generated-autoload-file) - -(defun w32-batch-update-autoloads () - "Like `batch-update-autoloads', but takes the name of the autoloads file -from the command line. - -This is required because some Windows build environments, such as MSYS, -munge command-line arguments that include file names to a horrible mess -that Emacs is unable to cope with." - (let ((generated-autoload-file - (expand-file-name (pop command-line-args-left))) - ;; I can only assume the same considerations may apply here... - (autoload-make-program (pop command-line-args-left))) - (batch-update-autoloads))) - (defun w32-append-code-lines (orig extra) "Append non-empty non-comment lines in the file EXTRA to the file ORIG. diff --git a/lisp/wdired.el b/lisp/wdired.el index f6d2b37904a..d2a6bad0f28 100644 --- a/lisp/wdired.el +++ b/lisp/wdired.el @@ -155,26 +155,30 @@ nonexistent directory will fail." :version "26.1" :type 'boolean) -(defvar wdired-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "\C-x\C-s" #'wdired-finish-edit) - (define-key map "\C-c\C-c" #'wdired-finish-edit) - (define-key map "\C-c\C-k" #'wdired-abort-changes) - (define-key map "\C-c\C-[" #'wdired-abort-changes) - (define-key map "\C-x\C-q" #'wdired-exit) - (define-key map "\C-m" #'undefined) - (define-key map "\C-j" #'undefined) - (define-key map "\C-o" #'undefined) - (define-key map [up] #'wdired-previous-line) - (define-key map "\C-p" #'wdired-previous-line) - (define-key map [down] #'wdired-next-line) - (define-key map "\C-n" #'wdired-next-line) - (define-key map [remap upcase-word] #'wdired-upcase-word) - (define-key map [remap capitalize-word] #'wdired-capitalize-word) - (define-key map [remap downcase-word] #'wdired-downcase-word) - (define-key map [remap self-insert-command] #'wdired--self-insert) - map) - "Keymap used in `wdired-mode'.") +(defcustom wdired-search-replace-filenames t + "Non-nil to search and replace in file names only." + :version "29.1" + :type 'boolean) + +(defvar-keymap wdired-mode-map + :doc "Keymap used in `wdired-mode'." + "C-x C-s" #'wdired-finish-edit + "C-c C-c" #'wdired-finish-edit + "C-c C-k" #'wdired-abort-changes + "C-c C-[" #'wdired-abort-changes + "C-x C-q" #'wdired-exit + "RET" #'undefined + "C-j" #'undefined + "C-o" #'undefined + "<up>" #'wdired-previous-line + "C-p" #'wdired-previous-line + "<down>" #'wdired-next-line + "C-n" #'wdired-next-line + "C-(" #'dired-hide-details-mode + "<remap> <upcase-word>" #'wdired-upcase-word + "<remap> <capitalize-word>" #'wdired-capitalize-word + "<remap> <downcase-word>" #'wdired-downcase-word + "<remap> <self-insert-command>" #'wdired--self-insert) (easy-menu-define wdired-mode-menu wdired-mode-map "Menu for `wdired-mode'." @@ -218,6 +222,7 @@ symbolic link targets, and filenames permission." (error "This mode can be enabled only by `wdired-change-to-wdired-mode'")) (put 'wdired-mode 'mode-class 'special) +(declare-function dired-isearch-search-filenames "dired-aux") ;;;###autoload (defun wdired-change-to-wdired-mode () @@ -238,9 +243,16 @@ See `wdired-mode'." (dired-remember-marks (point-min) (point-max))) (setq-local wdired--old-point (point)) (wdired--set-permission-bounds) - (setq-local query-replace-skip-read-only t) - (add-function :after-while (local 'isearch-filter-predicate) - #'wdired-isearch-filter-read-only) + (when wdired-search-replace-filenames + (add-function :around (local 'isearch-search-fun-function) + #'dired-isearch-search-filenames + '((isearch-message-prefix . "filename "))) + (setq-local replace-search-function + (setq-local replace-re-search-function + (funcall isearch-search-fun-function))) + ;; Original dired hook removes dired-isearch-search-filenames that + ;; is needed outside isearch for lazy-highlighting in query-replace. + (remove-hook 'isearch-mode-hook #'dired-isearch-filenames-setup t)) (use-local-map wdired-mode-map) (force-mode-line-update) (setq buffer-read-only nil) @@ -320,11 +332,6 @@ or \\[wdired-abort-changes] to abort changes"))) ;; Is this good enough? Assumes no extra white lines from dired. (put-text-property (1- (point-max)) (point-max) 'read-only t))))))) -(defun wdired-isearch-filter-read-only (beg end) - "Skip matches that have a read-only property." - (not (text-property-not-all (min beg end) (max beg end) - 'read-only nil))) - ;; Protect the buffer so only the filenames can be changed, and put ;; properties so filenames (old and new) can be easily found. (defun wdired--preprocess-files () @@ -439,8 +446,13 @@ non-nil means return old filename." (remove-text-properties (point-min) (point-max) '(front-sticky nil rear-nonsticky nil read-only nil keymap nil))) - (remove-function (local 'isearch-filter-predicate) - #'wdired-isearch-filter-read-only) + (when wdired-search-replace-filenames + (remove-function (local 'isearch-search-fun-function) + #'dired-isearch-search-filenames) + (kill-local-variable 'replace-search-function) + (kill-local-variable 'replace-re-search-function) + ;; Restore dired hook + (add-hook 'isearch-mode-hook #'dired-isearch-filenames-setup nil t)) (use-local-map dired-mode-map) (force-mode-line-update) (setq buffer-read-only t) @@ -872,21 +884,19 @@ Like original function but it skips read-only words." ;; The following code deals with changing the access bits (or ;; permissions) of the files. -(defvar wdired-perm-mode-map - (let ((map (make-sparse-keymap))) - (define-key map " " #'wdired-toggle-bit) - (define-key map "r" #'wdired-set-bit) - (define-key map "w" #'wdired-set-bit) - (define-key map "x" #'wdired-set-bit) - (define-key map "-" #'wdired-set-bit) - (define-key map "S" #'wdired-set-bit) - (define-key map "s" #'wdired-set-bit) - (define-key map "T" #'wdired-set-bit) - (define-key map "t" #'wdired-set-bit) - (define-key map "s" #'wdired-set-bit) - (define-key map "l" #'wdired-set-bit) - (define-key map [mouse-1] #'wdired-mouse-toggle-bit) - map)) +(defvar-keymap wdired-perm-mode-map + "SPC" #'wdired-toggle-bit + "r" #'wdired-set-bit + "w" #'wdired-set-bit + "x" #'wdired-set-bit + "-" #'wdired-set-bit + "S" #'wdired-set-bit + "s" #'wdired-set-bit + "T" #'wdired-set-bit + "t" #'wdired-set-bit + "s" #'wdired-set-bit + "l" #'wdired-set-bit + "<mouse-1>" #'wdired-mouse-toggle-bit) ;; Put a keymap property to the permission bits of the files, and store the ;; original name and permissions as a property diff --git a/lisp/whitespace.el b/lisp/whitespace.el index 13917206cae..8e726c40dd8 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 ae2a43654e0..29b6e13bc60 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" @@ -432,8 +437,9 @@ the :notify function can't know the new value.") (follow-link (widget-get widget :follow-link)) (help-echo (widget-get widget :help-echo))) (widget-put widget :button-overlay overlay) - (if (functionp help-echo) + (when (functionp help-echo) (setq help-echo 'widget-mouse-help)) + (overlay-put overlay 'before-string #(" " 0 1 (invisible t))) (overlay-put overlay 'button widget) (overlay-put overlay 'keymap (widget-get widget :keymap)) (overlay-put overlay 'evaporate t) @@ -2963,7 +2969,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 +3327,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) @@ -3453,7 +3460,7 @@ It reads a directory name from an editable text field." map)) (define-widget 'key-sequence 'restricted-sexp - "A key sequence." + "A key sequence. This is obsolete; use the `key' type instead." :prompt-value 'widget-field-prompt-value :prompt-internal 'widget-symbol-prompt-internal ; :prompt-match 'fboundp ;; What was this good for? KFS @@ -3519,6 +3526,31 @@ It reads a directory name from an editable text field." value)) +(defvar widget-key-prompt-value-history nil + "History of input to `widget-key-prompt-value'.") + +(define-widget 'key 'editable-field + "A key sequence." + :prompt-value 'widget-field-prompt-value + :match #'widget-key-valid-p + :format "%{%t%}: %v" + :validate 'widget-key-validate + :keymap widget-key-sequence-map + :help-echo "C-q: insert KEY, EVENT, or CODE; RET: enter value" + :tag "Key") + +(defun widget-key-valid-p (_widget value) + "Non-nil if VALUE is a valid value for the key widget WIDGET." + (key-valid-p value)) + +(defun widget-key-validate (widget) + (unless (and (stringp (widget-value widget)) + (key-valid-p (widget-value widget))) + (widget-put widget :error (format "Invalid key: %S" + (widget-value widget))) + widget)) + + (define-widget 'sexp 'editable-field "An arbitrary Lisp expression." :tag "Lisp expression" diff --git a/lisp/widget.el b/lisp/widget.el index 34885f7d1f0..300a95bd229 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 6c239dcd1ba..c8ea4fd1e54 100644 --- a/lisp/windmove.el +++ b/lisp/windmove.el @@ -448,6 +448,7 @@ unless `windmove-create-window' is non-nil and a new window is created." (defvar windmove-mode-map (make-sparse-keymap) "Map used by `windmove-install-defaults'.") +;;;###autoload (define-minor-mode windmove-mode "Global minor mode for default windmove commands." :keymap windmove-mode-map @@ -700,7 +701,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 a47a1216d10..5da867715f6 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. @@ -2504,15 +2488,23 @@ and no others." (defalias 'some-window 'get-window-with-predicate) +(defcustom display-buffer-avoid-small-windows nil + "If non-nil, windows that have fewer lines than this are avoided. +This is used by `get-lru-window'. The value is interpreted in units +of the frame's canonical line height, like `window-total-height' does." + :type '(choice (const nil) number) + :version "29.1" + :group 'windows) + (defun get-lru-window (&optional all-frames dedicated not-selected no-other) - "Return the least recently used window on frames specified by ALL-FRAMES. + "Return the least recently used window on frames specified by ALL-FRAMES. Return a full-width window if possible. A minibuffer window is never a candidate. A dedicated window is never a candidate unless DEDICATED is non-nil, so if all windows are dedicated, the value is nil. Avoid returning the selected window if possible. Optional argument NOT-SELECTED non-nil means never return the selected window. Optional argument NO-OTHER non-nil means to -never return a window whose 'no-other-window' parameter is +never return a window whose `no-other-window' parameter is non-nil. The following non-nil values of the optional argument ALL-FRAMES @@ -2529,15 +2521,23 @@ have special meanings: - A frame means consider all windows on that frame only. Any other value of ALL-FRAMES means consider all windows on the -selected frame and no others." - (let (best-window best-time second-best-window second-best-time time) - (dolist (window (window-list-1 nil 'nomini all-frames)) +selected frame and no others. + +`display-buffer-avoid-small-windows', if non-nil, is also taken into +consideration. Windows whose height is smaller that the value of that +variable will be avoided if larger windows are available." + (let ((windows (window-list-1 nil 'nomini all-frames)) + best-window best-time second-best-window second-best-time time) + (dolist (window windows) (when (and (or dedicated (not (window-dedicated-p window))) (or (not not-selected) (not (eq window (selected-window)))) (or (not no-other) (not (window-parameter window 'no-other-window)))) (setq time (window-use-time window)) (if (or (eq window (selected-window)) + (and display-buffer-avoid-small-windows + (< (window-height window) + display-buffer-avoid-small-windows)) (not (window-full-width-p window))) (when (or (not second-best-time) (< time second-best-time)) (setq second-best-time time) @@ -2554,7 +2554,7 @@ never a candidate unless DEDICATED is non-nil, so if all windows are dedicated, the value is nil. Optional argument NOT-SELECTED non-nil means never return the selected window. Optional argument NO-OTHER non-nil means to never return a window whose -'no-other-window' parameter is non-nil. +`no-other-window' parameter is non-nil. The following non-nil values of the optional argument ALL-FRAMES have special meanings: @@ -2590,7 +2590,7 @@ never a candidate unless DEDICATED is non-nil, so if all windows are dedicated, the value is nil. Optional argument NOT-SELECTED non-nil means never return the selected window. Optional argument NO-OTHER non-nil means to never return a window whose -'no-other-window' parameter is non-nil. +`no-other-window' parameter is non-nil. The following non-nil values of the optional argument ALL-FRAMES have special meanings: @@ -4181,8 +4181,8 @@ another live window on that frame to serve as its selected window. This option allows to control which window gets selected instead. -The possible choices are 'mru' (the default) to select the most -recently used window on that frame, and 'pos' to choose the +The possible choices are `mru' (the default) to select the most +recently used window on that frame, and `pos' to choose the window at the frame coordinates of point of the previously selected window. If this is nil, choose the frame's first window instead. A window with a non-nil `no-other-window' parameter is @@ -4594,7 +4594,9 @@ as well. In that case, if this option specifies a function, it will be called with the third argument nil. Under certain circumstances `switch-to-prev-buffer' may ignore -this option, for example, when there is only one buffer left." +this option, for example, when there is only one buffer left. + +Also see `switch-to-prev-buffer-skip-regexp'." :type '(choice (const :tag "Never" nil) (const :tag "This frame" this) @@ -4605,16 +4607,37 @@ this option, for example, when there is only one buffer left." :version "27.1" :group 'windows) +(defcustom switch-to-prev-buffer-skip-regexp nil + "Buffers that `switch-to-prev-buffer' and `switch-to-next-buffer' should skip. +The value can either be a regexp or a list of regexps. Buffers whose +names match these regexps are skipped by `switch-to-prev-buffer' +and `switch-to-next-buffer'. + +Also see `switch-to-prev-buffer-skip'." + :type '(choice regexp + (repeat regexp)) + :version "29.1" + :group 'windows) + (defun switch-to-prev-buffer-skip-p (skip window buffer &optional bury-or-kill) "Return non-nil if `switch-to-prev-buffer' should skip BUFFER. SKIP is a value derived from `switch-to-prev-buffer-skip', WINDOW the window `switch-to-prev-buffer' acts upon. Optional argument BURY-OR-KILL is passed unchanged by `switch-to-prev-buffer' and omitted in calls from `switch-to-next-buffer'." - (when skip - (if (functionp skip) - (funcall skip window buffer bury-or-kill) - (get-buffer-window buffer skip)))) + (or (and skip + (if (functionp skip) + (funcall skip window buffer bury-or-kill) + (get-buffer-window buffer skip))) + (and switch-to-prev-buffer-skip-regexp + (or (and (stringp switch-to-prev-buffer-skip-regexp) + (string-match-p switch-to-prev-buffer-skip-regexp + (buffer-name buffer))) + (and (consp switch-to-prev-buffer-skip-regexp) + (catch 'found + (dolist (regexp switch-to-prev-buffer-skip-regexp) + (when (string-match-p regexp (buffer-name buffer)) + (throw 'tag t))))))))) (defun switch-to-prev-buffer (&optional window bury-or-kill) "In WINDOW switch to previous buffer. @@ -4902,10 +4925,7 @@ the buffer `*scratch*', creating it if necessary." (setq frame (or frame (selected-frame))) (or (get-next-valid-buffer (nreverse (buffer-list frame)) buffer visible-ok frame) - (get-buffer "*scratch*") - (let ((scratch (get-buffer-create "*scratch*"))) - (set-buffer-major-mode scratch) - scratch))) + (get-scratch-buffer-create))) (defcustom frame-auto-hide-function #'iconify-frame "Function called to automatically hide frames. @@ -5023,7 +5043,11 @@ minibuffer window or is dedicated to its buffer." BUFFER-OR-NAME may be a buffer or the name of an existing buffer and defaults to the current buffer. -Interactively, prompt for the buffer. +Interactively, this command will prompt for the buffer name. A +prefix argument of 0 (zero) means that only windows in the +current terminal's frames will be deleted. Any other prefix +argument means that only windows in the current frame will be +deleted. The following non-nil values of the optional argument FRAME have special meanings: @@ -5060,7 +5084,21 @@ If the buffer specified by BUFFER-OR-NAME is shown in a minibuffer window, do nothing for that window. For any window that does not show that buffer, remove the buffer from that window's lists of previous and next buffers." - (interactive "bDelete windows on (buffer):\nP") + (interactive + (let ((frame (cond + ((and (numberp current-prefix-arg) + (zerop current-prefix-arg)) + 0) + (current-prefix-arg t)))) + (list (read-buffer "Delete windows on (buffer): " + nil nil + (lambda (buf) + (get-buffer-window + (if (consp buf) (car buf) buf) + (cond + ((null frame) t) + ((numberp frame) frame))))) + frame))) (let ((buffer (window-normalize-buffer buffer-or-name)) ;; Handle the "inverted" meaning of the FRAME argument wrt other ;; `window-list-1' based function. @@ -5120,6 +5158,14 @@ all window-local buffer lists." :version "27.1" :group 'windows) +(defun window--quit-restore-select-window (window) + "Select WINDOW after having quit another one. +Do not select an inactive minibuffer window." + (when (and (window-live-p window) + (or (not (window-minibuffer-p window)) + (minibuffer-window-active-p window))) + (select-window window))) + (defun quit-restore-window (&optional window bury-or-kill) "Quit WINDOW and deal with its buffer. WINDOW must be a live window and defaults to the selected one. @@ -5133,7 +5179,7 @@ parameter to nil. See Info node `(elisp) Quitting Windows' for more details. If WINDOW's dedicated flag is t, try to delete WINDOW. If it -equals the value 'side', restore that value when WINDOW is not +equals the value `side', restore that value when WINDOW is not deleted. Optional second argument BURY-OR-KILL tells how to proceed with @@ -5158,6 +5204,7 @@ nil means to not handle the buffer in a particular way. This (setq window (window-normalize-window window t)) (let* ((buffer (window-buffer window)) (quit-restore (window-parameter window 'quit-restore)) + (quit-restore-2 (nth 2 quit-restore)) (prev-buffer (catch 'prev-buffer (dolist (buf (window-prev-buffers window)) (unless (eq (car buf) buffer) @@ -5169,15 +5216,13 @@ nil means to not handle the buffer in a particular way. This ((and dedicated (not (eq dedicated 'side)) (window--delete window 'dedicated (eq bury-or-kill 'kill))) ;; If the previously selected window is still alive, select it. - (when (window-live-p (nth 2 quit-restore)) - (select-window (nth 2 quit-restore)))) + (window--quit-restore-select-window quit-restore-2)) ((and (not prev-buffer) (eq (nth 1 quit-restore) 'tab) (eq (nth 3 quit-restore) buffer)) (tab-bar-close-tab) ;; If the previously selected window is still alive, select it. - (when (window-live-p (nth 2 quit-restore)) - (select-window (nth 2 quit-restore)))) + (window--quit-restore-select-window quit-restore-2)) ((and (not prev-buffer) (or (eq (nth 1 quit-restore) 'frame) (and (eq (nth 1 quit-restore) 'window) @@ -5189,8 +5234,7 @@ nil means to not handle the buffer in a particular way. This ;; Delete WINDOW if possible. (window--delete window nil (eq bury-or-kill 'kill))) ;; If the previously selected window is still alive, select it. - (when (window-live-p (nth 2 quit-restore)) - (select-window (nth 2 quit-restore)))) + (window--quit-restore-select-window quit-restore-2)) ((and (listp (setq quad (nth 1 quit-restore))) (buffer-live-p (car quad)) (eq (nth 3 quit-restore) buffer)) @@ -5234,8 +5278,8 @@ nil means to not handle the buffer in a particular way. This ;; Reset the quit-restore parameter. (set-window-parameter window 'quit-restore nil) ;; Select old window. - (when (window-live-p (nth 2 quit-restore)) - (select-window (nth 2 quit-restore)))) + ;; If the previously selected window is still alive, select it. + (window--quit-restore-select-window quit-restore-2)) (t ;; Show some other buffer in WINDOW and reset the quit-restore ;; parameter. @@ -5248,8 +5292,8 @@ nil means to not handle the buffer in a particular way. This (when (eq dedicated 'side) (set-window-dedicated-p window 'side)) (window--delete window nil (eq bury-or-kill 'kill)) - (when (window-live-p (nth 2 quit-restore)) - (select-window (nth 2 quit-restore)))))) + ;; If the previously selected window is still alive, select it. + (window--quit-restore-select-window quit-restore-2)))) ;; Deal with the buffer. (cond @@ -5714,12 +5758,12 @@ right, if any." ;;; Balancing windows. ;; The following routine uses the recycled code from an old version of -;; `window--resize-child-windows'. It's not very pretty, but coding it the way the -;; new `window--resize-child-windows' code does would hardly make it any shorter or -;; more readable (FWIW we'd need three loops - one to calculate the -;; minimum sizes per window, one to enlarge or shrink windows until the -;; new parent-size matches, and one where we shrink the largest/enlarge -;; the smallest window). +;; `window--resize-child-windows'. It's not very pretty, but coding it +;; the way the new `window--resize-child-windows' code does would hardly +;; make it any shorter or more readable (FWIW we'd need three loops - +;; one to calculate the minimum sizes per window, one to enlarge or +;; shrink windows until the new parent-size matches, and one where we +;; shrink the largest/enlarge the smallest window). (defun balance-windows-2 (window horizontal) "Subroutine of `balance-windows-1'. WINDOW must be a vertical combination (horizontal if HORIZONTAL @@ -5730,9 +5774,10 @@ is non-nil)." (first (window-child window)) (sub first) (number-of-children 0) + (rest 0) (parent-size (window-new-pixel window)) (total-sum parent-size) - failed size sub-total sub-delta sub-amount rest) + failed size sub-total sub-delta sub-amount) (while sub (if (window-size-fixed-p sub horizontal) (progn @@ -7257,11 +7302,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) @@ -7272,29 +7321,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) @@ -7305,12 +7368,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) @@ -7321,13 +7395,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) @@ -7366,6 +7451,7 @@ The actual non-nil value of this variable will be copied to the (const display-buffer-pop-up-window) (const display-buffer-same-window) (const display-buffer-pop-up-frame) + (const display-buffer-full-frame) (const display-buffer-in-child-frame) (const display-buffer-below-selected) (const display-buffer-at-bottom) @@ -7415,9 +7501,9 @@ Its value takes effect before processing the ACTION argument of If non-nil, this is an alist of elements (CONDITION . ACTION), where: - CONDITION is either a regexp matching buffer names, or a - function that takes two arguments - a buffer name and the - ACTION argument of `display-buffer' - and returns a boolean. + CONDITION is passed to `buffer-match-p', along with the buffer + that is to be displayed and the ACTION argument of + `display-buffer', to check if ACTION should be used. ACTION is a cons cell (FUNCTIONS . ALIST), where FUNCTIONS is an action function or a list of action functions and ALIST is an @@ -7470,22 +7556,16 @@ all fail. It should never be set by programs or users. See `display-buffer'.") (put 'display-buffer-fallback-action 'risky-local-variable t) -(defun display-buffer-assq-regexp (buffer-name alist action) - "Retrieve ALIST entry corresponding to BUFFER-NAME. -This returns the cdr of the alist entry ALIST if either its key -is a string that matches BUFFER-NAME, as reported by -`string-match-p'; or if the key is a function that returns -non-nil when called with three arguments: the ALIST key, -BUFFER-NAME and ACTION. ACTION should have the form of the -action argument passed to `display-buffer'." +(defun display-buffer-assq-regexp (buffer-or-name alist action) + "Retrieve ALIST entry corresponding to buffer specified by BUFFER-OR-NAME. +This returns the cdr of the alist entry ALIST if the entry's +key (its car) and BUFFER-OR-NAME satisfy `buffer-match-p', using +the key as CONDITION argument of `buffer-match-p'. ACTION should +have the form of the action argument passed to `display-buffer'." (catch 'match (dolist (entry alist) - (let ((key (car entry))) - (when (or (and (stringp key) - (string-match-p key buffer-name)) - (and (functionp key) - (funcall key buffer-name action))) - (throw 'match (cdr entry))))))) + (when (buffer-match-p (car entry) buffer-or-name action) + (throw 'match (cdr entry)))))) (defvar display-buffer--same-window-action '(display-buffer-same-window @@ -7518,6 +7598,7 @@ to an expression containing one of these \"action\" functions: `display-buffer-use-least-recent-window' -- Try to avoid re-using windows that have recently been switched to. `display-buffer-pop-up-window' -- Pop up a new window. + `display-buffer-full-frame' -- Delete other windows and use the full frame. `display-buffer-below-selected' -- Use or pop up a window below the selected one. `display-buffer-at-bottom' -- Use or pop up a window at the @@ -7530,7 +7611,7 @@ to an expression containing one of these \"action\" functions: For instance: - (setq display-buffer-alist '((\".*\" display-buffer-at-bottom))) + (setq display-buffer-alist \\='((\".*\" display-buffer-at-bottom))) Buffer display can be further customized to a very high degree; the rest of this docstring explains some of the many @@ -7570,6 +7651,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 @@ -7579,20 +7663,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 @@ -7608,9 +7705,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 @@ -7638,7 +7735,7 @@ specified by the ACTION argument." ;; Otherwise, use the defined actions. (let* ((user-action (display-buffer-assq-regexp - (buffer-name buffer) display-buffer-alist action)) + buffer display-buffer-alist action)) (special-action (display-buffer--special-action buffer)) ;; Extra actions from the arguments to this function: (extra-action @@ -7735,6 +7832,23 @@ indirectly called by the latter." (window-dedicated-p)) (window--display-buffer buffer (selected-window) 'reuse alist))) +(defun display-buffer-full-frame (buffer alist) + "Display BUFFER in the current frame, taking the entire frame. +ALIST is an association list of action symbols and values. See +Info node `(elisp) Buffer Display Action Alists' for details of +such alists. + +This is an action function for buffer display, see Info +node `(elisp) Buffer Display Action Functions'. It should be +called only by `display-buffer' or a function directly or +indirectly called by the latter." + (when-let ((window (or (display-buffer-reuse-window buffer alist) + (display-buffer-same-window buffer alist) + (display-buffer-pop-up-window buffer alist) + (display-buffer-use-some-window buffer alist)))) + (delete-other-windows window) + window)) + (defun display-buffer--maybe-same-window (buffer alist) "Conditionally display BUFFER in the selected window. ALIST is an association list of action symbols and values. See @@ -8531,6 +8645,14 @@ currently selected window; otherwise it will be displayed in another window." (pop-to-buffer buffer display-buffer--same-window-action norecord)) +(defcustom display-comint-buffer-action display-buffer--same-window-action + "`display-buffer' action for displaying comint buffers." + :type display-buffer--action-custom-type + :risky t + :version "29.1" + :group 'windows + :group 'comint) + (defun read-buffer-to-switch (prompt) "Read the name of a buffer to switch to, prompting with PROMPT. Return the name of the buffer as a string. @@ -8541,7 +8663,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 @@ -8560,12 +8682,13 @@ If BUFFER-OR-NAME is nil, return the buffer returned by `other-buffer'. Else, if a buffer specified by BUFFER-OR-NAME exists, return that buffer. If no such buffer exists, create a buffer with the name BUFFER-OR-NAME and return that buffer." - (if buffer-or-name - (or (get-buffer buffer-or-name) - (let ((buffer (get-buffer-create buffer-or-name))) - (set-buffer-major-mode buffer) - buffer)) - (other-buffer))) + (pcase buffer-or-name + ('nil (other-buffer)) + ("*scratch*" (get-scratch-buffer-create)) + (_ (or (get-buffer buffer-or-name) + (let ((buffer (get-buffer-create buffer-or-name))) + (set-buffer-major-mode buffer) + buffer))))) (defcustom switch-to-buffer-preserve-window-point t "If non-nil, `switch-to-buffer' tries to preserve `window-point'. @@ -9970,6 +10093,11 @@ When point is already on that position, then signal an error." (defun scroll-up-command (&optional arg) "Scroll text of selected window upward ARG lines; or near full screen if no ARG. +Interactively, giving this command a numerical prefix will scroll +up by that many lines (and down by that many lines if the number +is negative). Without a prefix, scroll up by a full screen. +If given a `C-u -' prefix, scroll a full page down instead. + If `scroll-error-top-bottom' is non-nil and `scroll-up' cannot scroll window further, move cursor to the bottom line. When point is already on that position, then signal an error. @@ -10002,6 +10130,11 @@ If ARG is the atom `-', scroll downward by nearly full screen." (defun scroll-down-command (&optional arg) "Scroll text of selected window down ARG lines; or near full screen if no ARG. +Interactively, giving this command a numerical prefix will scroll +down by that many lines (and up by that many lines if the number +is negative). Without a prefix, scroll down by a full screen. +If given a `C-u -' prefix, scroll a full page up instead. + If `scroll-error-top-bottom' is non-nil and `scroll-down' cannot scroll window further, move cursor to the top line. When point is already on that position, then signal an error. @@ -10032,6 +10165,24 @@ If ARG is the atom `-', scroll upward by nearly full screen." (put 'scroll-down-command 'scroll-command t) +(defun scroll-other-window (&optional lines) + "Scroll next window upward LINES lines; or near full screen if no ARG. +See `scroll-up-command' for details." + (interactive "P") + (with-selected-window (other-window-for-scrolling) + (funcall (or (command-remapping #'scroll-up-command) + #'scroll-up-command) + lines))) + +(defun scroll-other-window-down (&optional lines) + "Scroll next window downward LINES lines; or near full screen if no ARG. +See `scroll-down-command' for details." + (interactive "P") + (with-selected-window (other-window-for-scrolling) + (funcall (or (command-remapping #'scroll-down-command) + #'scroll-down-command) + lines))) + ;;; Scrolling commands which scroll a line instead of full screen. (defun scroll-up-line (&optional arg) diff --git a/lisp/woman.el b/lisp/woman.el index 2e0d9a9090d..fd5fee2005a 100644 --- a/lisp/woman.el +++ b/lisp/woman.el @@ -1813,8 +1813,7 @@ Argument EVENT is the invoking mouse event." "--" ["Describe (Wo)Man Mode" describe-mode t] ["Mini Help" woman-mini-help t] - ,@(if (fboundp 'customize-group) - '(["Customize..." (customize-group 'woman) t])) + ["Customize..." (customize-group 'woman) t] "--" ("Advanced" ["View Source" (view-file woman-last-file-name) woman-last-file-name] @@ -2280,9 +2279,9 @@ Currently set only from \\='\\\" t in the first line of the source file.") (replace-match woman-unpadded-space-string t t)) ;; Discard optional hyphen \%; concealed newlines \<newline>; - ;; point-size change function \sN,\s+N, \s-N: + ;; kerning \/, \,; point-size change function \sN,\s+N, \s-N: (goto-char from) - (while (re-search-forward "\\\\\\([%\n]\\|s[-+]?[0-9]+\\)" nil t) + (while (re-search-forward "\\\\\\([%\n/,]\\|s[-+]?[0-9]+\\)" nil t) (woman-delete-match 0)) ;; BEWARE: THIS SHOULD PROBABLY ALL BE DONE MUCH LATER!!!!! @@ -4579,6 +4578,8 @@ logging the message." (bookmark-default-handler `("" (buffer . ,buf) . ,(bookmark-get-bookmark-record bookmark))))) +(put 'woman-bookmark-jump 'bookmark-handler-type "WoMan") + ;; Obsolete. (defvar woman-version "0.551 (beta)" "WoMan version information.") diff --git a/lisp/x-dnd.el b/lisp/x-dnd.el index 559679131bd..f3abb9d5e6d 100644 --- a/lisp/x-dnd.el +++ b/lisp/x-dnd.el @@ -115,6 +115,17 @@ the type we want for the drop, the action we want for the drop, any protocol specific data.") +(declare-function x-get-selection-internal "xselect.c" + (selection-symbol target-type &optional time-stamp terminal)) + +(defconst x-dnd-xdnd-to-action + '(("XdndActionPrivate" . private) + ("XdndActionCopy" . copy) + ("XdndActionMove" . move) + ("XdndActionLink" . link) + ("XdndActionAsk" . ask)) + "Mapping from XDND action types to Lisp symbols.") + (defvar x-dnd-empty-state [nil nil nil nil nil nil nil]) (declare-function x-register-dnd-atom "xselect.c") @@ -336,21 +347,41 @@ nil if not." Currently XDND, Motif and old KDE 1.x protocols are recognized." (interactive "e") (let* ((client-message (car (cdr (cdr event)))) - (window (posn-window (event-start event))) - (message-atom (aref client-message 0)) - (frame (aref client-message 1)) - (format (aref client-message 2)) - (data (aref client-message 3))) - - (cond ((equal "DndProtocol" message-atom) ; Old KDE 1.x. - (x-dnd-handle-old-kde event frame window message-atom format data)) - - ((equal "_MOTIF_DRAG_AND_DROP_MESSAGE" message-atom) ; Motif - (x-dnd-handle-motif event frame window message-atom format data)) - - ((and (> (length message-atom) 4) ; XDND protocol. - (equal "Xdnd" (substring message-atom 0 4))) - (x-dnd-handle-xdnd event frame window message-atom format data))))) + (window (posn-window (event-start event)))) + (if (eq (and (consp client-message) + (car client-message)) + 'XdndSelection) + ;; This is an internal Emacs message caused by something being + ;; dropped on top of a frame. + (progn + (let ((action (cdr (assoc (symbol-name (cadr client-message)) + x-dnd-xdnd-to-action))) + (targets (cddr client-message))) + (x-dnd-save-state window nil nil + (apply #'vector targets)) + (x-dnd-maybe-call-test-function window action) + (unwind-protect + (x-dnd-drop-data event (if (framep window) window + (window-frame window)) + window + (x-get-selection-internal + 'XdndSelection + (intern (x-dnd-current-type window))) + (x-dnd-current-type window)) + (x-dnd-forget-drop window)))) + (let ((message-atom (aref client-message 0)) + (frame (aref client-message 1)) + (format (aref client-message 2)) + (data (aref client-message 3))) + (cond ((equal "DndProtocol" message-atom) ; Old KDE 1.x. + (x-dnd-handle-old-kde event frame window message-atom format data)) + + ((equal "_MOTIF_DRAG_AND_DROP_MESSAGE" message-atom) ; Motif + (x-dnd-handle-motif event frame window message-atom format data)) + + ((and (> (length message-atom) 4) ; XDND protocol. + (equal "Xdnd" (substring message-atom 0 4))) + (x-dnd-handle-xdnd event frame window message-atom format data))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -371,16 +402,8 @@ Currently XDND, Motif and old KDE 1.x protocols are recognized." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; XDND protocol. -(defconst x-dnd-xdnd-to-action - '(("XdndActionPrivate" . private) - ("XdndActionCopy" . copy) - ("XdndActionMove" . move) - ("XdndActionLink" . link) - ("XdndActionAsk" . ask)) - "Mapping from XDND action types to Lisp symbols.") - (declare-function x-change-window-property "xfns.c" - (prop value &optional frame type format outer-P)) + (prop value &optional frame type format outer-P window-id)) (defun x-dnd-init-xdnd-for-frame (frame) "Set the XdndAware property for FRAME to indicate that we do XDND." @@ -425,8 +448,6 @@ otherwise return the frame coordinates." (declare-function x-get-atom-name "xselect.c" (value &optional frame)) (declare-function x-send-client-message "xselect.c" (display dest from message-type format values)) -(declare-function x-get-selection-internal "xselect.c" - (selection-symbol target-type &optional time-stamp terminal)) (defun x-dnd-version-from-flags (flags) "Return the version byte from the 32 bit FLAGS in an XDndEnter message." @@ -446,7 +467,6 @@ FORMAT is 32 (not used). MESSAGE is the data part of an XClientMessageEvent." (version (x-dnd-version-from-flags flags)) (more-than-3 (x-dnd-more-than-3-from-flags flags)) (dnd-source (aref data 0))) - (message "%s %s" version more-than-3) (if version ;; If flags is bad, version will be nil. (x-dnd-save-state window nil nil @@ -479,7 +499,7 @@ FORMAT is 32 (not used). MESSAGE is the data part of an XClientMessageEvent." ))) (x-send-client-message frame dnd-source frame "XdndStatus" 32 list-to-send) - )) + (dnd-handle-movement (event-start event)))) ((equal "XdndLeave" message) (x-dnd-forget-drop window)) @@ -583,178 +603,195 @@ FORMAT is 32 (not used). MESSAGE is the data part of an XClientMessageEvent." (2 . private)) ; Motif does not have private, so use copy for private. "Mapping from number to operation for Motif DND.") -(defun x-dnd-handle-motif (event frame window message-atom _format data) - (let* ((message-type (cdr (assoc (aref data 0) x-dnd-motif-message-types))) +(defun x-dnd-handle-motif (event frame window _message-atom _format data) + (let* ((message-type (cdr (assoc (logand (aref data 0) #x3f) + x-dnd-motif-message-types))) + (initiator-p (eq (lsh (aref data 0) -7) 0)) (source-byteorder (aref data 1)) (my-byteorder (byteorder)) (source-flags (x-dnd-get-motif-value data 2 2 source-byteorder)) (source-action (cdr (assoc (logand ?\xF source-flags) x-dnd-motif-to-action)))) - (cond ((eq message-type 'XmTOP_LEVEL_ENTER) - (let* ((dnd-source (x-dnd-get-motif-value - data 8 4 source-byteorder)) - (selection-atom (x-dnd-get-motif-value - data 12 4 source-byteorder)) - (atom-name (x-get-atom-name selection-atom)) - (types (when atom-name - (x-get-selection-internal (intern atom-name) - 'TARGETS)))) - (x-dnd-forget-drop frame) - (when types (x-dnd-save-state window nil nil - types - dnd-source)))) - - ;; Can not forget drop here, LEAVE comes before DROP_START and - ;; we need the state in DROP_START. - ((eq message-type 'XmTOP_LEVEL_LEAVE) - nil) - - ((eq message-type 'XmDRAG_MOTION) - (let* ((state (x-dnd-get-state-for-frame frame)) - (timestamp (x-dnd-motif-value-to-list - (x-dnd-get-motif-value data 4 4 - source-byteorder) - 4 my-byteorder)) - (x (x-dnd-motif-value-to-list - (x-dnd-get-motif-value data 8 2 source-byteorder) + (when initiator-p + (cond ((eq message-type 'XmTOP_LEVEL_ENTER) + (let* ((dnd-source (x-dnd-get-motif-value + data 8 4 source-byteorder)) + (selection-atom (x-dnd-get-motif-value + data 12 4 source-byteorder)) + (atom-name (x-get-atom-name selection-atom)) + (types (when atom-name + (x-get-selection-internal (intern atom-name) + 'TARGETS)))) + (x-dnd-forget-drop frame) + (when types (x-dnd-save-state window nil nil + types + dnd-source)))) + + ;; Can not forget drop here, LEAVE comes before DROP_START and + ;; we need the state in DROP_START. + ((eq message-type 'XmTOP_LEVEL_LEAVE) + nil) + + ((eq message-type 'XmDRAG_MOTION) + (let* ((state (x-dnd-get-state-for-frame frame)) + (timestamp (x-dnd-motif-value-to-list + (x-dnd-get-motif-value data 4 4 + source-byteorder) + 4 my-byteorder)) + (x (x-dnd-motif-value-to-list + (x-dnd-get-motif-value data 8 2 source-byteorder) + 2 my-byteorder)) + (y (x-dnd-motif-value-to-list + (x-dnd-get-motif-value data 10 2 source-byteorder) + 2 my-byteorder)) + (dnd-source (aref state 6)) + (first-move (not (aref state 3))) + (action-type (x-dnd-maybe-call-test-function + window + source-action)) + (reply-action (car (rassoc (car action-type) + x-dnd-motif-to-action))) + (reply-flags + (x-dnd-motif-value-to-list + (if reply-action + (+ reply-action + ?\x30 ; 30: valid drop site + ?\x700) ; 700: can do copy, move or link + ?\x30) ; 30: drop site, but noop. 2 my-byteorder)) - (y (x-dnd-motif-value-to-list - (x-dnd-get-motif-value data 10 2 source-byteorder) - 2 my-byteorder)) - (dnd-source (aref state 6)) - (first-move (not (aref state 3))) - (action-type (x-dnd-maybe-call-test-function - window - source-action)) - (reply-action (car (rassoc (car action-type) - x-dnd-motif-to-action))) - (reply-flags - (x-dnd-motif-value-to-list - (if reply-action - (+ reply-action - ?\x30 ; 30: valid drop site - ?\x700) ; 700: can do copy, move or link - ?\x30) ; 30: drop site, but noop. - 2 my-byteorder)) - (reply (append - (list - (+ ?\x80 ; 0x80 indicates a reply. - (if first-move - 3 ; First time, reply is SITE_ENTER. - 2)) ; Not first time, reply is DRAG_MOTION. - my-byteorder) - reply-flags - timestamp - x - y))) - (x-send-client-message frame - dnd-source - frame - "_MOTIF_DRAG_AND_DROP_MESSAGE" - 8 - reply))) - - ((eq message-type 'XmOPERATION_CHANGED) - (let* ((state (x-dnd-get-state-for-frame frame)) - (timestamp (x-dnd-motif-value-to-list - (x-dnd-get-motif-value data 4 4 source-byteorder) - 4 my-byteorder)) - (dnd-source (aref state 6)) - (action-type (x-dnd-maybe-call-test-function - window - source-action)) - (reply-action (car (rassoc (car action-type) - x-dnd-motif-to-action))) - (reply-flags - (x-dnd-motif-value-to-list - (if reply-action - (+ reply-action - ?\x30 ; 30: valid drop site - ?\x700) ; 700: can do copy, move or link - ?\x30) ; 30: drop site, but noop - 2 my-byteorder)) - (reply (append - (list - (+ ?\x80 ; 0x80 indicates a reply. - 8) ; 8 is OPERATION_CHANGED - my-byteorder) - reply-flags - timestamp))) - (x-send-client-message frame - dnd-source - frame - "_MOTIF_DRAG_AND_DROP_MESSAGE" - 8 - reply))) - - ((eq message-type 'XmDROP_START) - (let* ((x (x-dnd-motif-value-to-list - (x-dnd-get-motif-value data 8 2 source-byteorder) + (reply (append + (list + (+ ?\x80 ; 0x80 indicates a reply. + (if first-move + 3 ; First time, reply is SITE_ENTER. + 2)) ; Not first time, reply is DRAG_MOTION. + my-byteorder) + reply-flags + timestamp + x + y))) + (x-send-client-message frame + dnd-source + frame + "_MOTIF_DRAG_AND_DROP_MESSAGE" + 8 + reply) + (dnd-handle-movement (event-start event)))) + + ((eq message-type 'XmOPERATION_CHANGED) + (let* ((state (x-dnd-get-state-for-frame frame)) + (timestamp (x-dnd-motif-value-to-list + (x-dnd-get-motif-value data 4 4 source-byteorder) + 4 my-byteorder)) + (dnd-source (aref state 6)) + (action-type (x-dnd-maybe-call-test-function + window + source-action)) + (reply-action (car (rassoc (car action-type) + x-dnd-motif-to-action))) + (reply-flags + (x-dnd-motif-value-to-list + (if reply-action + (+ reply-action + ?\x30 ; 30: valid drop site + ?\x700) ; 700: can do copy, move or link + ?\x30) ; 30: drop site, but noop 2 my-byteorder)) - (y (x-dnd-motif-value-to-list - (x-dnd-get-motif-value data 10 2 source-byteorder) + (reply (append + (list + (+ ?\x80 ; 0x80 indicates a reply. + 8) ; 8 is OPERATION_CHANGED + my-byteorder) + reply-flags + timestamp))) + (x-send-client-message frame + dnd-source + frame + "_MOTIF_DRAG_AND_DROP_MESSAGE" + 8 + reply))) + + ((eq message-type 'XmDROP_START) + (let* ((x (x-dnd-motif-value-to-list + (x-dnd-get-motif-value data 8 2 source-byteorder) + 2 my-byteorder)) + (y (x-dnd-motif-value-to-list + (x-dnd-get-motif-value data 10 2 source-byteorder) + 2 my-byteorder)) + (selection-atom (x-dnd-get-motif-value + data 12 4 source-byteorder)) + (atom-name (x-get-atom-name selection-atom)) + (dnd-source (x-dnd-get-motif-value + data 16 4 source-byteorder)) + (action-type (x-dnd-maybe-call-test-function + window + source-action)) + (reply-action (car (rassoc (car action-type) + x-dnd-motif-to-action))) + (reply-flags + (x-dnd-motif-value-to-list + (if reply-action + (+ reply-action + ?\x30 ; 30: valid drop site + ?\x700) ; 700: can do copy, move or link + (+ ?\x30 ; 30: drop site, but noop. + ?\x200)) ; 200: drop cancel. 2 my-byteorder)) - (selection-atom (x-dnd-get-motif-value - data 12 4 source-byteorder)) - (atom-name (x-get-atom-name selection-atom)) - (dnd-source (x-dnd-get-motif-value - data 16 4 source-byteorder)) - (action-type (x-dnd-maybe-call-test-function - window - source-action)) - (reply-action (car (rassoc (car action-type) - x-dnd-motif-to-action))) - (reply-flags - (x-dnd-motif-value-to-list - (if reply-action - (+ reply-action - ?\x30 ; 30: valid drop site - ?\x700) ; 700: can do copy, move or link - (+ ?\x30 ; 30: drop site, but noop. - ?\x200)) ; 200: drop cancel. - 2 my-byteorder)) - (reply (append - (list - (+ ?\x80 ; 0x80 indicates a reply. - 5) ; DROP_START. - my-byteorder) - reply-flags - x - y)) - (timestamp (x-dnd-get-motif-value - data 4 4 source-byteorder)) - action) - - (x-send-client-message frame - dnd-source - frame - "_MOTIF_DRAG_AND_DROP_MESSAGE" - 8 - reply) - (setq action - (when (and reply-action atom-name) - (let* ((value (x-get-selection-internal - (intern atom-name) - (intern (x-dnd-current-type window))))) - (when value - (condition-case info - (x-dnd-drop-data event frame window value - (x-dnd-current-type window)) - (error - (message "Error: %s" info) - nil)))))) - (x-get-selection-internal - (intern atom-name) - (if action 'XmTRANSFER_SUCCESS 'XmTRANSFER_FAILURE) - timestamp) - (x-dnd-forget-drop frame))) - - (t (error "Unknown Motif DND message %s %s" message-atom data))))) + (reply (append + (list + (+ ?\x80 ; 0x80 indicates a reply. + 5) ; DROP_START. + my-byteorder) + reply-flags + x + y)) + (timestamp (x-dnd-get-motif-value + data 4 4 source-byteorder)) + action) + + (x-send-client-message frame + dnd-source + frame + "_MOTIF_DRAG_AND_DROP_MESSAGE" + 8 + reply) + (setq action + (when (and reply-action atom-name) + (let* ((value (x-get-selection-internal + (intern atom-name) + (intern (x-dnd-current-type window))))) + (when value + (condition-case info + (x-dnd-drop-data event frame window value + (x-dnd-current-type window)) + (error + (message "Error: %s" info) + nil)))))) + (x-get-selection-internal + (intern atom-name) + (if action 'XmTRANSFER_SUCCESS 'XmTRANSFER_FAILURE) + timestamp) + (x-dnd-forget-drop frame))) + + (t (message "Unknown Motif drag-and-drop message: %s" (logand (aref data 0) #x3f))))))) ;;; + + +;;; Handling drops. + +(defun x-dnd-handle-unsupported-drop (targets _x _y action _window-id _frame _time) + "Return non-nil if the drop described by TARGETS and ACTION should not proceed." + (not (and (or (eq action 'XdndActionCopy) + (eq action 'XdndActionMove)) + (or (member "STRING" targets) + (member "UTF8_STRING" targets) + (member "COMPOUND_TEXT" targets) + (member "TEXT" targets))))) + (provide 'x-dnd) ;;; x-dnd.el ends here diff --git a/lisp/xdg.el b/lisp/xdg.el index 60e643964e8..6a0b1dedd1d 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 94c4f91ce04..9c9f1d9b172 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 5662f0a3ea6..88bc8ff6c5e 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 &optional arguments 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,34 @@ (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)) +(declare-function xwidget-info "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 +93,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. @@ -111,7 +139,7 @@ Interactively, URL defaults to the string looking like a url around point." Get the URL of current session, then browse to the URL in `split-window-below' with a new xwidget webkit session." (interactive nil xwidget-webkit-mode) - (let ((url (xwidget-webkit-current-url))) + (let ((url (xwidget-webkit-uri (xwidget-webkit-current-session)))) (with-selected-window (split-window-below) (xwidget-webkit-new-session url)))) @@ -120,10 +148,49 @@ in `split-window-below' with a new xwidget webkit session." Get the URL of current session, then browse to the URL in `split-window-right' with a new xwidget webkit session." (interactive nil xwidget-webkit-mode) - (let ((url (xwidget-webkit-current-url))) + (let ((url (xwidget-webkit-uri (xwidget-webkit-current-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 +200,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 +234,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) @@ -214,23 +348,36 @@ If N is omitted or nil, scroll down by one line." (defun xwidget-webkit-scroll-forward (&optional n) "Scroll webkit horizontally by N chars. -The width of char is calculated with `window-font-width'. -If N is omitted or nil, scroll forwards by one char." +If the widget is larger than the window, hscroll by N columns +instead. The width of char is calculated with +`window-font-width'. If N is omitted or nil, scroll forwards by +one char." (interactive "p" xwidget-webkit-mode) - (xwidget-webkit-execute-script - (xwidget-webkit-current-session) - (format "window.scrollBy(%d, 0);" - (* n (window-font-width))))) + (let ((session (xwidget-webkit-current-session))) + (if (> (- (aref (xwidget-info session) 2) + (window-text-width nil t)) + (window-font-width)) + (set-window-hscroll nil (+ (window-hscroll) n)) + (xwidget-webkit-execute-script session + (format "window.scrollBy(%d, 0);" + (* n (window-font-width))))))) (defun xwidget-webkit-scroll-backward (&optional n) "Scroll webkit back by N chars. -The width of char is calculated with `window-font-width'. -If N is omitted or nil, scroll backwards by one char." +If the widget is larger than the window, hscroll backwards by N +columns instead. The width of char is calculated with +`window-font-width'. If N is omitted or nil, scroll backwards by +one char." (interactive "p" xwidget-webkit-mode) - (xwidget-webkit-execute-script - (xwidget-webkit-current-session) - (format "window.scrollBy(-%d, 0);" - (* n (window-font-width))))) + (let ((session (xwidget-webkit-current-session))) + (if (and (> (- (aref (xwidget-info session) 2) + (window-text-width nil t)) + (window-font-width)) + (> (window-hscroll) 0)) + (set-window-hscroll nil (- (window-hscroll) n)) + (xwidget-webkit-execute-script session + (format "window.scrollBy(%-d, 0);" + (* n (window-font-width))))))) (defun xwidget-webkit-scroll-top () "Scroll webkit to the very top." @@ -246,10 +393,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 +415,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 +434,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 function 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 +498,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)) @@ -343,24 +545,31 @@ directory, URL is saved at the specified directory as FILE-NAME." ;;; Bookmarks integration (defcustom xwidget-webkit-bookmark-jump-new-session nil - "Control bookmark jump to use new session or not. -If non-nil, use a new xwidget webkit session after bookmark jump. -Otherwise, it will use `xwidget-webkit-last-session'. -When you set this variable to nil, consider further customization with -`xwidget-webkit-last-session-buffer'." + "Whether to jump to a bookmarked URL in a new xwidget webkit session. +If non-nil, create a new xwidget webkit session, otherwise use +the value of `xwidget-webkit-last-session'." :version "28.1" :type 'boolean) (defun xwidget-webkit-bookmark-make-record () - "Create bookmark record in webkit xwidget. -See `xwidget-webkit-bookmark-jump-new-session' for whether this -should create a new session or not." + "Create a bookmark record for a webkit xwidget." (nconc (bookmark-make-record-default t t) `((page . ,(xwidget-webkit-uri (xwidget-webkit-current-session))) - (handler . (lambda (bmk) - (xwidget-webkit-browse-url - (bookmark-prop-get bmk 'page) - xwidget-webkit-bookmark-jump-new-session)))))) + (handler . xwidget-webkit-bookmark-jump-handler)))) + +;;;###autoload +(defun xwidget-webkit-bookmark-jump-handler (bookmark) + "Jump to the web page bookmarked by the bookmark record BOOKMARK. +If `xwidget-webkit-bookmark-jump-new-session' is non-nil, create +a new xwidget-webkit session, otherwise use an existing session." + (let* ((url (bookmark-prop-get bookmark 'page)) + (xwbuf (if (or xwidget-webkit-bookmark-jump-new-session + (not (xwidget-webkit-current-session))) + (xwidget-webkit--create-new-session-buffer url) + (xwidget-buffer (xwidget-webkit-current-session))))) + (with-current-buffer xwbuf + (xwidget-webkit-goto-uri (xwidget-webkit-current-session) url)) + (set-buffer xwbuf))) ;;; xwidget webkit session @@ -386,6 +595,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){ @@ -604,34 +817,91 @@ For example, use this to display an anchor." (add-to-list 'window-size-change-functions 'xwidget-webkit-adjust-size-in-frame)) -(defun xwidget-webkit-new-session (url &optional callback) - "Create a new webkit session buffer with URL." - (let* - ((bufname (generate-new-buffer-name "*xwidget-webkit*")) - (callback (or callback #'xwidget-webkit-callback)) - xw) - (setq xwidget-webkit-last-session-buffer (switch-to-buffer - (get-buffer-create bufname))) +(defun xwidget-webkit--create-new-session-buffer (url &optional callback) + "Create a new webkit session buffer to display URL in an xwidget. +Optional function CALLBACK specifies the callback for webkit xwidgets; +see `xwidget-webkit-callback'." + (let* ((bufname + ;; Generate a temp-name based on current buffer name. The + ;; buffer will subsequently be renamed by + ;; `xwidget-webkit-callback'. This approach can avoid + ;; 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 (get-buffer-create bufname)) ;; The xwidget id is stored in a text property, so we need to have ;; at least character in this buffer. ;; Insert invisible url, good default for next `g' to browse url. - (let ((start (point))) - (insert url) - (put-text-property start (+ start (length url)) 'invisible t) - (setq xw (xwidget-insert - start 'webkit bufname - (xwidget-window-inside-pixel-width (selected-window)) - (xwidget-window-inside-pixel-height (selected-window))))) - (xwidget-put xw 'callback callback) - (xwidget-webkit-mode) - (xwidget-webkit-goto-uri (xwidget-webkit-last-session) url))) - + (with-current-buffer xwidget-webkit-last-session-buffer + (let ((start (point))) + (insert url) + (put-text-property start (+ start (length url)) 'invisible t) + (setq xw (xwidget-insert + start 'webkit bufname + (xwidget-window-inside-pixel-width (selected-window)) + (xwidget-window-inside-pixel-height (selected-window)) + 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-last-session-buffer)) + +(defun xwidget-webkit-new-session (url) + "Display URL in a new webkit xwidget." + (switch-to-buffer (xwidget-webkit--create-new-session-buffer url)) + (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 +925,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 +963,276 @@ 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-key xwidget-webkit-edit-mode-map [C-backspace] '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..5cd75eb3186 --- /dev/null +++ b/lisp/yank-media.el @@ -0,0 +1,190 @@ +;;; yank-media.el --- Yanking images and HTML -*- lexical-binding:t -*- + +;; Copyright (C) 2021-2022 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 (yank-media--utf-16-p data))) + (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))) + +(defun yank-media--utf-16-p (data) + (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 + ((> (/ (float (elt stats 0)) (/ (length data) 2)) + 0.9) + ;; Big endian. + 'utf-16-be) + ((> (/ (float (elt stats 1)) (/ (length data) 2)) + 0.9) + ;; Little endian. + 'utf-16-le))))) + +(provide 'yank-media) + +;;; yank-media.el ends here |